summaryrefslogtreecommitdiff
path: root/80-89
diff options
context:
space:
mode:
Diffstat (limited to '80-89')
-rw-r--r--80-89/80.hs9
-rw-r--r--80-89/83.hs3
-rw-r--r--80-89/84.hs48
-rw-r--r--80-89/85.hs27
-rw-r--r--80-89/87.hs18
-rw-r--r--80-89/88.hs22
-rw-r--r--80-89/89.hs22
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
Powered by cgit, Themed by Ted Yin.