diff options
| -rw-r--r-- | 80-89/80.hs | 51 | ||||
| -rw-r--r-- | 80-89/81.hs | 12 | ||||
| -rw-r--r-- | 80-89/82.hs | 12 | ||||
| -rw-r--r-- | 80-89/83.hs | 52 |
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) |