From 741e26dabbccb5821c79736590ad03286fe04f84 Mon Sep 17 00:00:00 2001 From: Determinant Date: Wed, 31 May 2017 21:23:39 -0400 Subject: one prob left for v9 --- 80-89/80.hs | 9 +++------ 80-89/83.hs | 3 +-- 80-89/84.hs | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 80-89/85.hs | 27 +++++++++++++++++++++++++++ 80-89/87.hs | 18 ++++++++++++++++++ 80-89/88.hs | 22 ++++++++++++++++++++++ 80-89/89.hs | 22 ++++++++++++++++++++++ 7 files changed, 141 insertions(+), 8 deletions(-) create mode 100644 80-89/84.hs create mode 100644 80-89/85.hs create mode 100644 80-89/87.hs create mode 100644 80-89/88.hs create mode 100644 80-89/89.hs (limited to '80-89') 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 -- cgit v1.2.3