But luckily, I made one earlier!

lib/Homework/Ch01/Hanoi.hs

@@ -5,67 +5,42 @@ import Data.Maybe
 -- | Move pegs from the first peg to the last peg.
 -- The moves that were made are returned, but an error is returned if a move
 -- can't be made.
-hanoi :: String -> String -> String -> Int -> Either String [Move]
+hanoi :: (Monad m) => String -> String -> String -> Int -> m [Move]
-hanoi pegLabelA pegLabelB pegLabelC numDiscs =
+hanoi pegLabelA pegLabelB pegLabelC numDiscs = do
   let -- CONSTRUCT a set of pegs given the provided arguments
       pegsStart = initPegs pegLabelA pegLabelB pegLabelC numDiscs
-      -- Make a move
+  -- Make a move
-      (movesMade, _) = move pegsStart
+  (moveMade, _) <- runPegs move pegsStart
-   in -- Cheat the return for now, assume that movesMade is present for TDD
+  -- Cheat the return for now, assume that movesMade is present for TDD
-      Right [fromJust movesMade]
+  return [fromJust moveMade]
 
 {------------------------------------------------------------------------------}
-{- MOVE -----------------------------------------------------------------------}
+{- MAKE A MOVE ----------------------------------------------------------------}
 {------------------------------------------------------------------------------}
 
--- | Make a move
+move :: (Monad m) => PegStep m (Maybe Move)
--- Given some pegs, make a move if a move is possible and return the pegs with
+move = do
--- the move that was made.
+  topDiscA <- getTopDisc <$> getPegA
---
+  topDiscC <- getTopDisc <$> getPegC
--- The return of this function is a 2-tuple of ($THE_MOVE, $PEGS_AFTER_MOVE).
+  if topDiscA >= topDiscC
-move :: Pegs -> (Maybe Move, Pegs)
+    then return Nothing
-move pegs =
+    else do
-  let -- pull apart the first peg
+      popPegA
-      pegA@(Peg firstPegLabel firstPegDiscs) = pegsPegA pegs
+      pushPegC $ fromJust topDiscA
-      -- pull apart the last peg
+      Just <$> makeMove "a" "c"
-      pegC@(Peg lastPegLabel lastPegDiscs) = pegsPegC pegs
-      -- get the smallest disc from the first peg
-      firstPegDisc = last firstPegDiscs
-      -- get the smallest disk from the last peg
-      lastPegDisc = last lastPegDiscs
-      -- the disc from the first peg can move to the  last peg if it is smaller
-      -- than the last peg's smallest disc
-      canMove = firstPegDisc < lastPegDisc
-   in -- return a tuple of (move made, pegs after move)
-      if canMove
-        then
-          ( -- return the move made
-            Just $
-              Move
-                { moveFrom = firstPegLabel,
-                  moveTo = lastPegLabel
-                },
-            -- modify the pegs to reflect the move
-            pegs
-              { -- Retain all discs but the last disc in peg A
-                pegsPegA = pegA {pegDiscs = init firstPegDiscs},
-                -- Append peg A's last disk to the end of peg C's discs
-                pegsPegC = pegC {pegDiscs = lastPegDiscs <> [firstPegDisc]}
-              }
-          )
-        else
-          ( -- no move can be made, so no move is returned
-            Nothing,
-            -- return the pegs as they are
-            pegs
-          )
 
 {------------------------------------------------------------------------------}
 {- PEGS -----------------------------------------------------------------------}
 {------------------------------------------------------------------------------}
 
 -- A set of pegs ordered from start to finish.
-data Pegs = Pegs {pegsPegA :: Peg, pegsPegB :: Peg, pegsPegC :: Peg} deriving (Eq, Show)
+data Pegs = Pegs
+  { pegsPegA :: Peg,
+    pegsPegB :: Peg,
+    pegsPegC :: Peg,
+    pegsMoves :: [Move]
+  }
+  deriving (Eq, Show)
 
 -- CONSTRUCT a set of pegs with their labels and number of discs to fill the first peg with
 initPegs :: String -> String -> String -> Int -> Pegs
@@ -73,9 +48,99 @@ initPegs pegLabelA pegLabelB pegLabelC numDiscs =
   Pegs
     { pegsPegA = fillPeg pegLabelA numDiscs,
       pegsPegB = emptyPeg pegLabelB,
-      pegsPegC = emptyPeg pegLabelC
+      pegsPegC = emptyPeg pegLabelC,
+      pegsMoves = []
     }
 
+{------------------------------------------------------------------------------}
+{- PEG STEP -------------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+-- A peg step holds a function that can be run against some pegs
+newtype PegStep m a = PegStep {runPegs :: Pegs -> m (a, Pegs)}
+
+-- CONSTRUCT a new PegStep given a function
+withPegs :: (Pegs -> m (a, Pegs)) -> PegStep m a
+withPegs = PegStep
+
+-- CONSTRUCT a new PegStep which produces the current pegs
+getPegs :: (Monad m) => PegStep m Pegs
+getPegs = withPegs $ \pegs -> return (pegs, pegs)
+
+-- CONSTRUCT a new PegStep which takes a pegs and replaces the current pegs
+putPegs :: (Monad m) => Pegs -> PegStep m ()
+putPegs pegs = withPegs $ return . const ((), pegs)
+
+-- GET or ASK for a value from pegs using a function
+askPegs :: (Monad m) => (Pegs -> PegStep m a) -> PegStep m a
+askPegs f = f =<< getPegs
+
+-- MODIFY pegs using a function
+modifyPegs :: (Monad m) => (Pegs -> PegStep m Pegs) -> PegStep m ()
+modifyPegs f = putPegs =<< f =<< getPegs
+
+-- EMBEDDED PEGS GETTERS -------------------------------------------------------
+
+getPegA :: (Monad m) => PegStep m Peg
+getPegA = askPegs (return . pegsPegA)
+
+putPegA :: (Monad m) => Peg -> PegStep m ()
+putPegA peg = do
+  pegs <- getPegs
+  putPegs $ pegs {pegsPegA = peg}
+
+getPegC :: (Monad m) => PegStep m Peg
+getPegC = askPegs (return . pegsPegC)
+
+putPegC :: (Monad m) => Peg -> PegStep m ()
+putPegC peg = do
+  pegs <- getPegs
+  putPegs $ pegs {pegsPegC = peg}
+
+-- EMBEDDED PEG METHODS --------------------------------------------------------
+
+makeMove :: (Monad m) => String -> String -> PegStep m Move
+makeMove from to = do
+  let move' = Move from to
+  pegs <- getPegs
+  putPegs pegs {pegsMoves = move' : pegsMoves pegs}
+  return move'
+
+popPegA :: (Monad m) => PegStep m ()
+popPegA = do
+  peg <- getPegA
+  putPegA $ peg {pegDiscs = init $ pegDiscs peg}
+
+pushPegC :: (Monad m) => Disc -> PegStep m ()
+pushPegC disc = do
+  peg <- getPegC
+  putPegC $ peg {pegDiscs = pegDiscs peg <> [disc]}
+
+{------------------------------------------------------------------------------}
+{- PEG STEP INSTANCES ---------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+instance (Monad m) => Functor (PegStep m) where
+  fn `fmap` step = withPegs $ \startPegs -> do
+    (result, resultPegs) <- runPegs step startPegs
+    return (fn result, resultPegs)
+
+instance (Monad m) => Applicative (PegStep m) where
+  pure x = withPegs $ \pegs -> return (x, pegs)
+  fn <*> x = withPegs $ \startPegs -> do
+    (fn', middleState) <- runPegs fn startPegs
+    (x', resultState) <- runPegs x middleState
+    return (fn' x', resultState)
+
+instance (Monad m) => Monad (PegStep m) where
+  firstStep >>= secondStepFactory =
+    PegStep $ \startPegs -> do
+      (firstResult, middlePegs) <- runPegs firstStep startPegs
+      runPegs (secondStepFactory firstResult) middlePegs
+
+instance (MonadFail m) => MonadFail (PegStep m) where
+  fail message = withPegs $ \_ -> fail message
+
 {------------------------------------------------------------------------------}
 {- PEG ------------------------------------------------------------------------}
 {------------------------------------------------------------------------------}
@@ -95,6 +160,15 @@ fillPeg label numDiscs =
 emptyPeg :: String -> Peg
 emptyPeg label = Peg {pegLabel = label, pegDiscs = []}
 
+-- GET the top disc from the peg, if it exists
+getTopDisc :: Peg -> Maybe Disc
+getTopDisc = lastOption . pegDiscs
+  where
+    lastOption xs = case xs of
+      [x] -> Just x
+      _ : xs' -> lastOption xs'
+      [] -> Nothing
+
 {------------------------------------------------------------------------------}
 {- DISC -----------------------------------------------------------------------}
 {------------------------------------------------------------------------------}

test/Homework/Ch01/HanoiSpec.hs

@@ -11,32 +11,32 @@ spec = describe "Hanoi" $ do
     let hanoiOf = hanoi "a" "b" "c"
 
     it "can solve for a stack of 1 disc" $ do
-      hanoiOf 1 --          a@[1] b@[] c@[]
+      moves <- hanoiOf 1 --          a@[1] b@[] c@[]
-        `shouldBe` Right
+      moves
-          [ Move "a" "c" -- a@[]  b@[] c@[1]
+        `shouldBe` [ Move "a" "c" -- a@[]  b@[] c@[1]
-          ]
+                   ]
 
     it "can solve for a stack of 2 discs" $ do
-      hanoiOf 2 --           a@[2, 1] b@[]  c@[]
+      moves <- hanoiOf 2 --           a@[2, 1] b@[]  c@[]
-        `shouldBe` Right
+      moves
-          [ Move "a" "c", -- a@[2]    b@[]  c@[1]
+        `shouldBe` [ Move "a" "c", -- a@[2]    b@[]  c@[1]
-            Move "a" "b", -- a@[]     b@[2] c@[1]
+                     Move "a" "b", -- a@[]     b@[2] c@[1]
-            Move "c" "a", -- a@[1]    b@[2] c@[]
+                     Move "c" "a", -- a@[1]    b@[2] c@[]
-            Move "a" "c", -- a@[1]    b@[]  c@[2]
+                     Move "a" "c", -- a@[1]    b@[]  c@[2]
-            Move "a" "c" --  a@[]     b@[]  c@[2, 1]
+                     Move "a" "c" --  a@[]     b@[]  c@[2, 1]
-          ]
+                   ]
 
     it "can solve for a stack of 3 discs" $ do
-      hanoiOf 3 --           a@[3, 2, 1] b@[]     c@[]
+      moves <- hanoiOf 3 --           a@[3, 2, 1] b@[]     c@[]
-        `shouldBe` Right
+      moves
-          [ Move "a" "c", -- a@[3, 2]    b@[]     c@[1]
+        `shouldBe` [ Move "a" "c", -- a@[3, 2]    b@[]     c@[1]
-            Move "a" "b", -- a@[3]       b@[2]    c@[1]
+                     Move "a" "b", -- a@[3]       b@[2]    c@[1]
-            Move "c" "b", -- a@[3]       b@[2, 1] c@[]
+                     Move "c" "b", -- a@[3]       b@[2, 1] c@[]
-            Move "a" "c", -- a@[]        b@[2, 1] c@[3]
+                     Move "a" "c", -- a@[]        b@[2, 1] c@[3]
-            Move "b" "a", -- a@[1]       b@[2]    c@[3]
+                     Move "b" "a", -- a@[1]       b@[2]    c@[3]
-            Move "b" "c", -- a@[1]       b@[]     c@[3, 2]
+                     Move "b" "c", -- a@[1]       b@[]     c@[3, 2]
-            Move "a" "c" --  a@[]        b@[]     c@[3, 2, 1]
+                     Move "a" "c" --  a@[]        b@[]     c@[3, 2, 1]
-          ]
+                   ]
 
   {----------------------------------------------------------------------------}
   {- MOVE ---------------------------------------------------------------------}
@@ -51,8 +51,9 @@ spec = describe "Hanoi" $ do
               { pegsPegA = (emptyPeg "a") {pegDiscs = [Disc 3, Disc 1]},
                 pegsPegC = (emptyPeg "c") {pegDiscs = [Disc 2]}
               }
-          -- run the function
+
-          (moveMade, pegsAfterMove) = move pegs
+      -- run the function
+      (moveMade, pegsAfterMove) <- runPegs move pegs
 
       -- a move should have been made
       moveMade `shouldBe` Just (Move "a" "c")
@@ -60,7 +61,8 @@ spec = describe "Hanoi" $ do
       pegsAfterMove
         `shouldBe` pegs
           { pegsPegA = (pegsPegA pegs) {pegDiscs = [Disc 3]},
-            pegsPegC = (pegsPegC pegs) {pegDiscs = [Disc 2, Disc 1]}
+            pegsPegC = (pegsPegC pegs) {pegDiscs = [Disc 2, Disc 1]},
+            pegsMoves = [Move {moveFrom = "a", moveTo = "c"}]
           }
 
   {----------------------------------------------------------------------------}
@@ -74,7 +76,8 @@ spec = describe "Hanoi" $ do
         `shouldBe` Pegs
           { pegsPegA = Peg {pegLabel = "a", pegDiscs = [Disc 3, Disc 2, Disc 1]},
             pegsPegB = Peg {pegLabel = "b", pegDiscs = []},
-            pegsPegC = Peg {pegLabel = "c", pegDiscs = []}
+            pegsPegC = Peg {pegLabel = "c", pegDiscs = []},
+            pegsMoves = []
           }
 
   {----------------------------------------------------------------------------}