one prob left for v9

7 files changed, 141 insertions, 8 deletions

diff --git a/80-89/80.hs b/80-89/80.hs
index 4dc2956..5f58f76 100644
--- a/80-89/80.hs
+++ b/80-89/80.hs
@@ -1,13 +1,10 @@
 import Data.List (sort)
 
-data Graph a = Graph [a] [(a, a)]
-               deriving (Show, Eq)
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
                 
-data Adjacency a = Adj [(a, [a])]
-           deriving (Show, Eq)
+data Adjacency a = Adj [(a, [a])] deriving (Show, Eq)
             
-data Friendly a = Edge [(a, a)]
-          deriving (Show, Eq)
+data Friendly a = Edge [(a, a)] deriving (Show, Eq)
 
 graphToAdj :: Eq a => Graph a -> Adjacency a
 
diff --git a/80-89/83.hs b/80-89/83.hs
index f9d9038..0b3517c 100644
--- a/80-89/83.hs
+++ b/80-89/83.hs
@@ -4,8 +4,7 @@ import Data.List (foldl')
 import Data.Maybe (fromJust)
 import Control.Monad (foldM, mapM)
 
-data Graph a = Graph [a] [(a, a)]
-               deriving (Show, Eq)
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
                 
 k4 = Graph ['a', 'b', 'c', 'd']
      [('a', 'b'), ('b', 'c'), ('c', 'd'),
diff --git a/80-89/84.hs b/80-89/84.hs
new file mode 100644
index 0000000..1d2143b
--- /dev/null
+++ b/80-89/84.hs
@@ -0,0 +1,48 @@
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List (foldl', sortBy)
+import Control.Monad (foldM, mapM)
+
+data Graph a b = Graph [a] [(a, a, b)] deriving (Show, Eq)
+                
+graph = Graph [1,2,3,4,5] [(1,2,12),(1,3,34),(1,5,78),(2,4,55),
+                           (2,5,32),(3,4,61),(3,5,44),(4,5,93)]
+
+newElem :: Ord a => Map a a -> a -> Maybe (Map a a)
+findLead :: Ord a => Map a a -> a -> Maybe (Map a a, a)
+unionSet :: Ord a => Map a a -> a -> a -> Maybe (Map a a)
+
+newElem m v = Just (Map.insert v v m)
+findLead m v = do pv <- Map.lookup v m
+                  if pv == v then return (m, v) else do
+                    (m', v') <- findLead m pv
+                    return (Map.adjust (\_ -> v') v m', v')
+unionSet m u v = do (m', lu) <- findLead m u
+                    (m'', lv) <- findLead m' v
+                    return (Map.adjust (\_ -> lv) lu m'')
+
+-- The above lines implement a monadic union-find-set, e.g:
+-- z = do m <- newElem Map.empty 1
+--        m1 <- newElem m 2
+--        m2 <- newElem m1 3
+--        m3 <- newElem m2 4
+--        m4 <- unionSet m3 1 2
+--        m5 <- unionSet m4 3 4
+--        m6 <- unionSet m5 2 3
+--        (m7, _) <- findLead m6 1
+--        return m7
+
+kruskal :: (Ord a, Ord b, Num b) => Graph a b -> Maybe b
+
+kruskal (Graph [] _) = Nothing
+kruskal (Graph v e) = span (sortBy (\(_, _, c) (_, _, c') -> c `compare` c') e)
+                           (foldM (\acc u -> newElem acc u) Map.empty v) 0
+    where span [] comp0 cost = return cost
+          span ((u, v, c):es) comp0 cost =
+              do comp <- comp0
+                 (comp', lu) <- findLead comp u
+                 (comp'', lv) <- findLead comp' v
+                 comp''' <- unionSet comp'' u v
+                 let (compf, cost') = if lu == lv then (comp'', cost)
+                                                  else (comp''', cost + c)
+                 span es (return compf) cost'
diff --git a/80-89/85.hs b/80-89/85.hs
new file mode 100644
index 0000000..929347d
--- /dev/null
+++ b/80-89/85.hs
@@ -0,0 +1,27 @@
+import Data.List (permutations, sort)
+
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
+
+iso :: Ord a => Graph a -> Graph a -> Bool
+
+-- assumption: the graphs are bi-directional, without duplicate edges
+
+iso (Graph v1 e1) (Graph v2 e2)
+    | length v1 /= length v2 || length e1 /= length e2 = False
+    | otherwise = let perm = permutations v2
+                      t = takeWhile id $
+                            scanl (\acc perm ->
+                                let tab = zip v1 perm
+                                    trans x = snd . head $ filter ((== x) . fst) tab in
+                                    acc && (sort (map (\(u, v) -> (trans u, trans v)) e1') /= e2''))
+                            True perm in length t /= length perm + 1
+        where adjust e = e >>= (\(u, v) -> [(u, v), (v, u)])
+              e1' = adjust e1
+              e2'' = sort $ adjust e2
+
+graphG1 = Graph [1,2,3,4,5,6,7,8]
+                [(1,5),(1,6),(1,7),(2,5),(2,6),(2,8),(3,5),(3,7),(3,8),(4,6),(4,7),(4,8)]
+graphH1 = Graph [1,2,3,4,5,6,7,8]
+                [(1,2),(1,4),(1,5),(6,2),(6,5),(6,7),(8,4),(8,5),(8,7),(3,2),(3,4),(3,7)]
+graphH1' = Graph [1,2,3,4,5,6,7,8]
+                [(1,2),(1,4),(1,5),(6,2),(6,5),(6,7),(8,4),(8,5),(8,7),(3,2),(3,4),(3,6)]
diff --git a/80-89/87.hs b/80-89/87.hs
new file mode 100644
index 0000000..0c119e3
--- /dev/null
+++ b/80-89/87.hs
@@ -0,0 +1,18 @@
+import Data.List (partition, foldl')
+
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
+
+depthFirst :: Eq a => Graph a -> a -> [a]
+
+depthFirst (Graph v e) s = fst $ dfs s []
+    where adjust u (a, b)
+              | a == u = [b]
+              | b == u = [a]
+              | otherwise = []
+          dfs u vis
+              | u `elem` vis = ([], vis)
+              | otherwise = let vs = (e >>= (adjust u)) in
+                                foldl' (\(s, vis') v ->
+                                        let (s', vis'') = dfs v vis' in
+                                            (s ++ s', vis''))
+                                       ([u], u:vis) vs
diff --git a/80-89/88.hs b/80-89/88.hs
new file mode 100644
index 0000000..6c1123c
--- /dev/null
+++ b/80-89/88.hs
@@ -0,0 +1,22 @@
+import Data.List (partition, foldl')
+
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
+
+connComp :: Eq a => Graph a -> [[a]]
+
+connComp (Graph v e) = fst $ foldl' 
+                        (\(comps, vis) u -> if u `elem` vis then (comps, vis)
+                                            else let (s, vis') = dfs u vis in 
+                                                     (s:comps, vis'))
+                        ([], []) v
+    where adjust u (a, b)
+              | a == u = [b]
+              | b == u = [a]
+              | otherwise = []
+          dfs u vis
+              | u `elem` vis = ([], vis)
+              | otherwise = let vs = (e >>= (adjust u)) in
+                                foldl' (\(s, vis') v ->
+                                        let (s', vis'') = dfs v vis' in
+                                            (s ++ s', vis''))
+                                       ([u], u:vis) vs
diff --git a/80-89/89.hs b/80-89/89.hs
new file mode 100644
index 0000000..175dcb4
--- /dev/null
+++ b/80-89/89.hs
@@ -0,0 +1,22 @@
+import Data.List (foldr)
+
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
+
+bipartite :: Eq a => Graph a -> Bool
+
+bipartite (Graph v e) =
+    let t = takeWhile id $
+                scanl (\acc x -> acc && (fst $ dfs x [] 0)) True v in
+                    length t == 1 + length v
+    where adjust u (a, b)
+              | a == u = [b]
+              | b == u = [a]
+              | otherwise = []
+          dfs u c cur
+              | color /= [] = (if snd (head color) == cur then True else False, c)
+              | otherwise = let vs = (e >>= (adjust u))
+                                t = takeWhile fst $
+                                        scanl (\(_, c) v -> dfs v c (1 - cur))
+                                                (True, (u, cur):c) vs in
+                                    (length t == 1 + length vs, snd $ last t)
+                where color = filter ((== u) . fst) c