Using small-to-large list for discs, allowing for arbitrary number of pegs

homework.cabal

@@ -31,7 +31,7 @@ library
       Paths_homework
   hs-source-dirs:
       lib
-  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns
+  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -optP-Wno-nonportable-include-path
   build-depends:
       base >=4.14 && <5
   default-language: Haskell2010
@@ -42,7 +42,7 @@ executable homework
       Paths_homework
   hs-source-dirs:
       app
-  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.14 && <5
     , homework
@@ -57,7 +57,7 @@ test-suite test
       Paths_homework
   hs-source-dirs:
       test
-  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N
+  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.14 && <5
     , homework

lib/Homework/Ch01/Hanoi.hs

@@ -5,10 +5,10 @@ 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 :: (Monad m) => String -> String -> String -> Int -> m [Move]
+hanoi :: (MonadFail m) => [String] -> Int -> m [Move]
-hanoi pegLabelA pegLabelB pegLabelC numDiscs = do
+hanoi labels numDiscs = do
-  let -- CONSTRUCT a set of pegs given the provided arguments
+  -- CONSTRUCT a set of pegs given the provided arguments
-      pegsStart = initPegs pegLabelA pegLabelB pegLabelC numDiscs
+  pegsStart <- initPegs labels numDiscs
   -- Make a move
   (moveMade, _) <- runPegs move pegsStart
   -- Cheat the return for now, assume that movesMade is present for TDD
@@ -18,15 +18,13 @@ hanoi pegLabelA pegLabelB pegLabelC numDiscs = do
 {- MAKE A MOVE ----------------------------------------------------------------}
 {------------------------------------------------------------------------------}
 
-move :: (Monad m) => PegStep m (Maybe Move)
+move :: (MonadFail m) => PegStep m (Maybe Move)
 move = do
-  topDiscA <- getTopDisc <$> getPegA
+  topDiscA <- getTopDisc <$> getPeg 0
-  topDiscC <- getTopDisc <$> getPegC
+  topDiscC <- getTopDisc <$> getPeg 2
   if topDiscA >= topDiscC
     then return Nothing
-    else do
+    else do Just <$> makeMove 0 2
-      pushPegC =<< popPegA
-      Just <$> makeMove "a" "c"
 
 {------------------------------------------------------------------------------}
 {- PEGS -----------------------------------------------------------------------}
@@ -34,22 +32,22 @@ move = do
 
 -- A set of pegs ordered from start to finish.
 data Pegs = Pegs
-  { pegsPegA :: Peg,
+  { pegsList :: [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
+initPegs :: (MonadFail m) => [String] -> Int -> m Pegs
-initPegs pegLabelA pegLabelB pegLabelC numDiscs =
+initPegs (firstLabel : restLabels) numDiscs
+  | numDiscs > 0 =
+    return
       Pegs
-    { pegsPegA = fillPeg pegLabelA numDiscs,
+        { pegsList = fillPeg firstLabel numDiscs : (emptyPeg <$> restLabels),
-      pegsPegB = emptyPeg pegLabelB,
-      pegsPegC = emptyPeg pegLabelC,
           pegsMoves = []
         }
+  | otherwise = fail "Can't create pegs with no discs"
+initPegs [] _ = fail "Can't create pegs without peg labels"
 
 {------------------------------------------------------------------------------}
 {- PEG STEP -------------------------------------------------------------------}
@@ -71,52 +69,71 @@ 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 :: (Monad m) => (Pegs -> a) -> PegStep m a
-askPegs f = f =<< getPegs
+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 -------------------------------------------------------
+-- EMBEDDED PEG ACCESSORS ------------------------------------------------------
 
-getPegA :: (Monad m) => PegStep m Peg
+getPeg :: (MonadFail m) => Int -> PegStep m Peg
-getPegA = askPegs (return . pegsPegA)
+getPeg n = do
+  list <- askPegs pegsList
+  go n (length list) list
+  where
+    go n' limit (x : xs)
+      | n' == 0 = return x
+      | otherwise = go (n' - 1) limit xs
+    go _ limit [] = fail $ "Peg out of bounds: queried for index " ++ show n ++ " out of " ++ show limit ++ " pegs"
 
-putPegA :: (Monad m) => Peg -> PegStep m ()
+putPeg :: (MonadFail m) => Peg -> PegStep m ()
-putPegA peg = do
+putPeg peg@Peg {pegLabel = label} = do
-  pegs <- getPegs
+  list <- askPegs pegsList
-  putPegs $ pegs {pegsPegA = peg}
+  modifyPegs $ \pegs' -> do
-
+    newList <- go [] list
-getPegC :: (Monad m) => PegStep m Peg
+    return $ pegs' {pegsList = newList}
-getPegC = askPegs (return . pegsPegC)
+  where
-
+    go previous (current : next)
-putPegC :: (Monad m) => Peg -> PegStep m ()
+      | pegLabel current == label = return $ reverse previous ++ peg : next
-putPegC peg = do
+      | otherwise = go (current : previous) next
-  pegs <- getPegs
+    go _ [] = fail $ "Could not replace peg with label " ++ show label ++ ": peg does not exist"
-  putPegs $ pegs {pegsPegC = peg}
 
 -- EMBEDDED PEG METHODS --------------------------------------------------------
 
-makeMove :: (Monad m) => String -> String -> PegStep m Move
+makeMove :: (MonadFail m) => Int -> Int -> PegStep m Move
 makeMove from to = do
-  let move' = Move from to
+  pushPeg to =<< popPeg from
-  pegs <- getPegs
+  fromLabel <- pegLabel <$> getPeg from
-  putPegs pegs {pegsMoves = move' : pegsMoves pegs}
+  toLabel <- pegLabel <$> getPeg to
+  let move' = Move fromLabel toLabel
+  pushMove move'
   return move'
 
-popPegA :: (Monad m) => PegStep m Disc
+popPeg :: (MonadFail m) => Int -> PegStep m Disc
-popPegA = do
+popPeg n = do
-  peg <- getPegA
+  peg@Peg {pegLabel = label, pegDiscs = discs} <- getPeg n
-  let disc = last $ pegDiscs peg
+  case discs of
-      rest = init $ pegDiscs peg
+    topDisc : rest -> do
-  putPegA $ peg {pegDiscs = rest}
+      putPeg peg {pegDiscs = rest}
-  return disc
+      return topDisc
+    _ -> fail $ "Could not pop empty peg " ++ show label
 
-pushPegC :: (Monad m) => Disc -> PegStep m ()
+pushPeg :: (MonadFail m) => Int -> Disc -> PegStep m ()
-pushPegC disc = do
+pushPeg n disc = do
-  peg <- getPegC
+  peg <- getPeg n
-  putPegC $ peg {pegDiscs = pegDiscs peg <> [disc]}
+  case pegDiscs peg of
+    discs@(topDisc : _)
+      | disc < topDisc -> putPeg peg {pegDiscs = disc : discs}
+      | otherwise -> fail $ "Tried to put bigger disc " ++ show disc ++ " on top of peg " ++ show (pegLabel peg) ++ "'s top disc " ++ show topDisc
+    _ -> putPeg peg {pegDiscs = [disc]}
+
+pushMove :: (Monad m) => Move -> PegStep m ()
+pushMove move' = do
+  pegs <- getPegs
+  let moves = pegsMoves pegs
+  putPegs pegs {pegsMoves = move' : moves}
 
 {------------------------------------------------------------------------------}
 {- PEG STEP INSTANCES ---------------------------------------------------------}
@@ -164,12 +181,10 @@ emptyPeg label = Peg {pegLabel = label, pegDiscs = []}
 
 -- GET the top disc from the peg, if it exists
 getTopDisc :: Peg -> Maybe Disc
-getTopDisc = lastOption . pegDiscs
+getTopDisc = headOption . pegDiscs
   where
-    lastOption xs = case xs of
+    headOption (x : _) = Just x
-      [x] -> Just x
+    headOption [] = Nothing
-      _ : xs' -> lastOption xs'
-      [] -> Nothing
 
 {------------------------------------------------------------------------------}
 {- DISC -----------------------------------------------------------------------}
@@ -180,7 +195,7 @@ data Disc = Disc {discSize :: Int} deriving (Eq, Ord, Show)
 
 -- CONSTRUCT a stack of discs
 stackDiscs :: Int -> [Disc]
-stackDiscs numDiscs = Disc <$> reverse [1 .. numDiscs]
+stackDiscs numDiscs = Disc <$> [1 .. numDiscs]
 
 {------------------------------------------------------------------------------}
 {- MOVE -----------------------------------------------------------------------}

package.yaml

@@ -57,3 +57,4 @@ ghc-options:
   - -Wredundant-constraints
   - -Wunused-packages
   - -Wunused-type-patterns
+  - -optP-Wno-nonportable-include-path

stack.yaml

@@ -17,8 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver:
+resolver: lts-18.13
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

stack.yaml.lock

@@ -4,10 +4,9 @@
 #   https://docs.haskellstack.org/en/stable/lock_files
 
 snapshots:
-- original:
+- original: lts-18.13
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
   completed:
-    sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887
+    sha256: d9e658a22cfe8d87a64fdf219885f942fef5fe2bcb156a9800174911c5da2443
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
-    size: 585817
+    size: 586268
 packages: []

test/Homework/Ch01/HanoiSpec.hs

@@ -8,7 +8,7 @@ spec = describe "Hanoi" $ do
   -- Testing the solver function
   describe "hanoi" $ do
     -- helper to construct a hanoi function with preconfigured labels
-    let hanoiOf = hanoi "a" "b" "c"
+    let hanoiOf = hanoi ["a", "b", "c"]
 
     it "can solve for a stack of 1 disc" $ do
       moves <- hanoiOf 1 --          a@[1] b@[] c@[]
@@ -17,25 +17,25 @@ spec = describe "Hanoi" $ do
                    ]
 
     it "can solve for a stack of 2 discs" $ do
-      moves <- hanoiOf 2 --           a@[2, 1] b@[]  c@[]
+      moves <- hanoiOf 2 --           a@[1, 2] b@[]  c@[]
       moves
         `shouldBe` [ Move "a" "c", -- a@[2]    b@[]  c@[1]
                      Move "a" "b", -- a@[]     b@[2] c@[1]
                      Move "c" "a", -- a@[1]    b@[2] c@[]
                      Move "a" "c", -- a@[1]    b@[]  c@[2]
-                     Move "a" "c" --  a@[]     b@[]  c@[2, 1]
+                     Move "a" "c" --  a@[]     b@[]  c@[1, 2]
                    ]
 
     it "can solve for a stack of 3 discs" $ do
-      moves <- hanoiOf 3 --           a@[3, 2, 1] b@[]     c@[]
+      moves <- hanoiOf 3 --           a@[1, 2, 3] b@[]     c@[]
       moves
-        `shouldBe` [ Move "a" "c", -- a@[3, 2]    b@[]     c@[1]
+        `shouldBe` [ Move "a" "c", -- a@[2, 3]    b@[]     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@[1, 2] c@[]
-                     Move "a" "c", -- a@[]        b@[2, 1] c@[3]
+                     Move "a" "c", -- a@[]        b@[1, 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@[2, 3]
-                     Move "a" "c" --  a@[]        b@[]     c@[3, 2, 1]
+                     Move "a" "c" --  a@[]        b@[]     c@[1, 2, 3]
                    ]
 
   {----------------------------------------------------------------------------}
@@ -45,11 +45,14 @@ spec = describe "Hanoi" $ do
   -- Testing individual moves
   describe "move" $ do
     it "moves the smallest peg from peg A to peg C if peg C's disc is bigger" $ do
-      let emptyPegs = initPegs "a" "b" "c" 0
+      let pegs =
-          pegs =
+            Pegs
-            emptyPegs
+              { pegsList =
-              { pegsPegA = (emptyPeg "a") {pegDiscs = [Disc 3, Disc 1]},
+                  [ Peg {pegLabel = "a", pegDiscs = [Disc 1, Disc 3]},
-                pegsPegC = (emptyPeg "c") {pegDiscs = [Disc 2]}
+                    Peg {pegLabel = "b", pegDiscs = []},
+                    Peg {pegLabel = "c", pegDiscs = [Disc 2]}
+                  ],
+                pegsMoves = []
               }
 
       -- run the function
@@ -58,12 +61,11 @@ spec = describe "Hanoi" $ do
       -- a move should have been made
       moveMade `shouldBe` Just (Move "a" "c")
       -- the pegs should have changed
-      pegsAfterMove
+      pegsList pegsAfterMove
-        `shouldBe` pegs
+        `shouldBe` [ Peg {pegLabel = "a", pegDiscs = [Disc 3]},
-          { pegsPegA = (pegsPegA pegs) {pegDiscs = [Disc 3]},
+                     Peg {pegLabel = "b", pegDiscs = []},
-            pegsPegC = (pegsPegC pegs) {pegDiscs = [Disc 2, Disc 1]},
+                     Peg {pegLabel = "c", pegDiscs = [Disc 1, Disc 2]}
-            pegsMoves = [Move {moveFrom = "a", moveTo = "c"}]
+                   ]
-          }
 
   {----------------------------------------------------------------------------}
   {- PEGS ---------------------------------------------------------------------}
@@ -72,11 +74,14 @@ spec = describe "Hanoi" $ do
   -- Testing constructor for a set of pegs
   describe "initPegs" $ do
     it "creates pegs with labels and fills the first peg with discs" $ do
-      initPegs "a" "b" "c" 3
+      pegs <- initPegs ["a", "b", "c"] 3
+      pegs
         `shouldBe` Pegs
-          { pegsPegA = Peg {pegLabel = "a", pegDiscs = [Disc 3, Disc 2, Disc 1]},
+          { pegsList =
-            pegsPegB = Peg {pegLabel = "b", pegDiscs = []},
+              [ Peg {pegLabel = "a", pegDiscs = [Disc 1, Disc 2, Disc 3]},
-            pegsPegC = Peg {pegLabel = "c", pegDiscs = []},
+                Peg {pegLabel = "b", pegDiscs = []},
+                Peg {pegLabel = "c", pegDiscs = []}
+              ],
             pegsMoves = []
           }
 
@@ -90,7 +95,7 @@ spec = describe "Hanoi" $ do
       fillPeg "a" 3
         `shouldBe` Peg
           { pegLabel = "a",
-            pegDiscs = [Disc 3, Disc 2, Disc 1]
+            pegDiscs = [Disc 1, Disc 2, Disc 3]
           }
 
   -- Testing constructor for a peg without discs
@@ -104,5 +109,5 @@ spec = describe "Hanoi" $ do
 
   -- Testing constructor for a stack of discs
   describe "stackDiscs" $ do
-    it "should create a stack of discs from largest to smallest" $ do
+    it "should create a stack of discs from smallest to largest" $ do
-      stackDiscs 3 `shouldBe` [Disc 3, Disc 2, Disc 1]
+      stackDiscs 3 `shouldBe` [Disc 1, Disc 2, Disc 3]