diff --git a/ninety-nine-haskell.cabal b/ninety-nine-haskell.cabal index 89dee03..faef771 100644 --- a/ninety-nine-haskell.cabal +++ b/ninety-nine-haskell.cabal @@ -54,6 +54,7 @@ library , psqueues , random , split + , transformers , vector default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index d1ac887..61ec264 100644 --- a/package.yaml +++ b/package.yaml @@ -53,6 +53,7 @@ library: - random - array - mtl + - transformers - psqueues - hashable - vector diff --git a/src/Graphs.hs b/src/Graphs.hs index 3b63e81..182fb0e 100644 --- a/src/Graphs.hs +++ b/src/Graphs.hs @@ -180,7 +180,7 @@ prim edges = S.evalState go initialState (u0, _, _) = head edges -- Start with all edges incident to u0 on the heap. initialState = (Set.singleton u0, relax Q.empty (outE u0)) - -- Sorts the given edge so that u appears first. + -- Sorts the given edge so that vertex u appears first. sortE u (x, y, cost) = if x == u then (x, y, cost) else (y, x, cost) -- Determines if the given edge is incident to u. isIncidentTo u (x, y, _) = x == u || y == u @@ -273,21 +273,23 @@ iso v1 e1 v2 e2 = m == n && go 0 0 (map (,0) v1) (map (,0) v2) 1 m = length v1 n = length v2 - -- Find old label. + -- Finds old label. + -- RankNTypes needs to be enabled to use forall. label :: forall a. (Eq a) => [(a, Int)] -> a -> Int label cl = Mb.fromJust . flip L.lookup cl -- Given the neighbors and their compressed labels, - -- compute new uncompressed label for this vertex. + -- computes new uncompressed label for this vertex. uncompress cl = L.sort . map (label cl) - -- Group uncompressed labels, and assign a compressed label to each group. - group xxs labelId = + -- Groups uncompressed labels, and + -- assigns a label to each group. + group ucl labelId = zipWith (\xs k -> (head xs, (length xs, k))) - (L.group $ L.sort xxs) + (L.group $ L.sort ucl) [labelId + 1 ..] - -- Assign compressed label to each group. - compress xs xxs = map (snd . Mb.fromJust . flip L.lookup xxs) xs - -- Reduce the graph into canonical form. + -- Assigns a compressed label to each uncompressed group. + compress ucl groups = map (snd . Mb.fromJust . flip L.lookup groups) ucl + -- Reduces the graph into canonical form. canonical = L.sortOn fst . map (\(_, (x, y)) -> (y, x)) go i labelId cl1 cl2 numLabels @@ -353,7 +355,10 @@ kColor vs es = go vs' Map.empty 1 go [] clrMap clr | Map.size clrMap == n = Map.toList clrMap + -- Try another color for the remaining vertices. | otherwise = go (filter (`Map.notMember` clrMap) vs') clrMap (clr + 1) + -- Try to assign color clr to each vertex, making sure + -- no two adjacent vertices end up with the same color. go (v : xs) clrMap clr | canClr = go xs (Map.insert v clr clrMap) clr | otherwise = go xs clrMap clr diff --git a/src/Monads.hs b/src/Monads.hs index c25e231..3c0797b 100644 --- a/src/Monads.hs +++ b/src/Monads.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} module Monads ( Operator (..), @@ -11,11 +10,12 @@ module Monads where import qualified Control.Monad as M -import Control.Monad.State (StateT) +import Control.Monad.State (State) import qualified Control.Monad.State as S -import Control.Monad.Writer (Writer) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Trans.Maybe as Mb +import Control.Monad.Writer (Writer, WriterT) import qualified Control.Monad.Writer as W -import qualified Data.Maybe as Mb import Data.Monoid (Sum (..)) import qualified Data.Monoid as Md @@ -151,24 +151,38 @@ data Element = Operator Operator | Operand Integer deriving stock (Show, Eq) type Stack = [Integer] -type Logger = Writer [(Stack, Maybe Operator)] +type Logs = [(Stack, Maybe Operator)] type Result = Maybe Integer -calculatePostfix :: [Element] -> (Result, [(Stack, Maybe Operator)]) -calculatePostfix xs = (res, logs) +{- +Stack order matters. The output is in the reverse order, +i.e. the innermost monad result wraps the others. +((a, w), s), where a is Result, w is Logs, and s is Stack. +-} +type Calculation = MaybeT (WriterT Logs (State Stack)) Integer + +calculatePostfix :: [Element] -> (Result, Logs) +calculatePostfix = fst . chain . calc where - ((res, _), logs) = W.runWriter $ S.runStateT (calc xs) [] + chain = flip S.runState [] . W.runWriterT . Mb.runMaybeT -calc :: [Element] -> StateT Stack Logger Result -calc [] = S.gets result -calc (Operand n : xs) = S.get >>= loop xs Nothing . (n :) -calc (Operator op : xs) = - S.get >>= Mb.maybe (return Nothing) (loop xs (Just op)) . runOp op +calc :: [Element] -> Calculation +calc elems = + S.get >>= case elems of + [] -> result + (Operand n : xs) -> loop xs Nothing . (n :) + (Operator op : xs) -> runOp op M.>=> loop xs (Just op) -loop :: [Element] -> Maybe Operator -> Stack -> StateT Stack Logger Result +loop :: [Element] -> Maybe Operator -> Stack -> Calculation loop xs op s = W.tell [(s, op)] >> S.put s >> calc xs +{- +The 'fail' invocations are using the MonadFail instance for Maybe, +(which is the monad 'm' in the function signatures below). +The error message is ignored by the instance, so, we don't +bother passing one. +-} result :: (MonadFail m) => Stack -> m Integer result [x] = return x result _ = fail "" diff --git a/test/MonadsSpec.hs b/test/MonadsSpec.hs index 18e70b1..c54f33b 100644 --- a/test/MonadsSpec.hs +++ b/test/MonadsSpec.hs @@ -43,9 +43,22 @@ spec = do describe "calculatePostfix" $ do it "evaluates an expression in postfix notation" $ do + let xs = + [ ("8 5 4 10 + - 3 * negate +", Just 35), + ("8 5 -", Just 3), + ("8 6", Nothing), + ("8 negate", Just (-8)), + ("8 +", Nothing) + ] + M.forM_ xs $ \(ex, res) -> do + let expr = parsePostfix ex + let result = calculatePostfix expr + fst result `shouldBe` res + + it "logs each step of a computation" $ do let expr = parsePostfix "8 5 4 10 + - 3 * negate +" let result = calculatePostfix expr - fst result `shouldBe` Just 35 + snd result `shouldBe` [ ([8], Nothing), ([5, 8], Nothing), @@ -59,17 +72,11 @@ spec = do ([35], Just Add) ] - let xs = [("8 5 -", Just 3), ("8 6", Nothing), ("8 negate", Just (-8)), ("8 +", Nothing)] - - M.forM_ xs $ \(ex, res) -> do - let expr' = parsePostfix ex - let result' = calculatePostfix expr' - fst result' `shouldBe` res + it "logs each step of a failed computation" $ do + let expr = parsePostfix "1 2 * +" + let result = calculatePostfix expr - let expr2 = parsePostfix "1 2 * +" - let result2 = calculatePostfix expr2 - fst result2 `shouldBe` Nothing - snd result2 + snd result `shouldBe` [ ([1], Nothing), ([2, 1], Nothing), ([2], Just Multiply)