Update problem 79

ninety-nine-haskell.cabal

@@ -54,6 +54,7 @@ library
     , psqueues
     , random
     , split
+    , transformers
     , vector
   default-language: Haskell2010
 

package.yaml

@@ -53,6 +53,7 @@ library:
   - random
   - array
   - mtl
+  - transformers
   - psqueues
   - hashable
   - vector

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

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 ""

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)