...

4 files changed, 127 insertions, 0 deletions

diff --git a/80-89/80.hs b/80-89/80.hs
new file mode 100644
index 0000000..4dc2956
--- /dev/null
+++ b/80-89/80.hs
@@ -0,0 +1,51 @@
+import Data.List (sort)
+
+data Graph a = Graph [a] [(a, a)]
+               deriving (Show, Eq)
+                
+data Adjacency a = Adj [(a, [a])]
+           deriving (Show, Eq)
+            
+data Friendly a = Edge [(a, a)]
+          deriving (Show, Eq)
+
+graphToAdj :: Eq a => Graph a -> Adjacency a
+
+graphToAdj (Graph [] _) = Adj []
+graphToAdj (Graph (v:vs) e) = Adj ((v, e >>= pick):l)
+    where pick (a, b)
+            | a == v = [b]
+            | b == v = [a]
+            | otherwise = []
+          Adj l = graphToAdj $ Graph vs e
+
+adjToGraph :: Eq a => Adjacency a -> Graph a
+
+adjToGraph (Adj []) = Graph [] []
+adjToGraph (Adj ((u, e):ps)) = Graph (u:us)
+                                     ((map (\v -> (u, v)) e) ++
+                                      (filter (\(a, b) -> a /= u && b /= u) es))
+    where (Graph us es) = adjToGraph $ Adj ps
+
+graphToFri :: Eq a => Graph a -> Friendly a
+
+graphToFri (Graph vs e) =
+    Edge (e ++ let g = filter (\v -> all (\(a, b) -> v /= a && v /= b) e) vs in
+                   zip g g)
+
+friToGraph :: Ord a => Friendly a -> Graph a
+
+friToGraph (Edge es) = Graph vs' (filter (\(a, b) -> a /= b) es')
+    where unique [] = []
+          unique [x] = [x]
+          unique (x:l@(y:xs))
+            | x == y = unique l
+            | otherwise = x:unique l
+          es' = unique . sort $ map (\(a, b) -> if a < b then (a, b) else (b, a)) es
+          vs' = unique . sort $ es' >>= (\(a, b) -> [a, b])
+
+adjToFri :: Eq a => Adjacency a -> Friendly a
+friToAdj :: Ord a => Friendly a -> Adjacency a
+
+adjToFri = graphToFri . adjToGraph
+friToAdj = graphToAdj . friToGraph
diff --git a/80-89/81.hs b/80-89/81.hs
new file mode 100644
index 0000000..9bf42d8
--- /dev/null
+++ b/80-89/81.hs
@@ -0,0 +1,12 @@
+import Data.List (partition)
+
+paths :: Eq a => a -> a -> [(a, a)] -> [[a]]
+
+paths s t edges = map reverse $ paths' s edges [s]
+    where
+        paths' u edges path
+            | u == t = [path]
+            | otherwise =
+                do  let (vs, edges') = partition ((== u) . fst) edges
+                    (_, v) <- vs
+                    paths' v edges' (v:path)
diff --git a/80-89/82.hs b/80-89/82.hs
new file mode 100644
index 0000000..3e8fe2e
--- /dev/null
+++ b/80-89/82.hs
@@ -0,0 +1,12 @@
+import Data.List (partition)
+
+cycle' :: Eq a => a -> [(a, a)] -> [[a]]
+
+cycle' s edges = map reverse $ cycle'' s edges [s] False
+    where
+        cycle'' u edges path f
+          | f && u == s = [path]
+          | otherwise =
+                do  let (vs, edges') = partition ((== u) . fst) edges
+                    (_, v) <- vs
+                    cycle'' v edges' (v:path) True
diff --git a/80-89/83.hs b/80-89/83.hs
new file mode 100644
index 0000000..f9d9038
--- /dev/null
+++ b/80-89/83.hs
@@ -0,0 +1,52 @@
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List (foldl')
+import Data.Maybe (fromJust)
+import Control.Monad (foldM, mapM)
+
+data Graph a = Graph [a] [(a, a)]
+               deriving (Show, Eq)
+                
+k4 = Graph ['a', 'b', 'c', 'd']
+     [('a', 'b'), ('b', 'c'), ('c', 'd'),
+     ('d', 'a'), ('a', 'c'), ('b', 'd')]
+
+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
+
+spantree :: Ord a => Graph a -> Maybe Int
+
+spantree (Graph v e) = span e $ foldM (\acc u -> newElem acc u) Map.empty v
+    where span [] comp0 = do comp <- comp0
+                             lu <- mapM (\u -> do (_, l) <- findLead comp u
+                                                  return l) v
+                             return (if all (== head lu) lu then 1 else 0)
+          span ((u, v):es) comp0 = do comp <- comp0
+                                      (comp', lu) <- findLead comp u
+                                      (comp'', lv) <- findLead comp' v
+                                      l <- span es $ return comp
+                                      if lu == lv then return l else do
+                                         comp''' <- unionSet comp'' u v
+                                         r <- span es $ return comp'''
+                                         return (l + r)