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

files/ch02/sample.log

@@ -0,0 +1,11 @@
+I 6 Completed armadillo processing
+I 1 Nothing to report
+I 4 Everything normal
+I 11 Initiating self-destruct sequence
+E 70 3 Way too many pickles
+E 65 8 Bad pickle-flange interaction detected
+W 5 Flange is due for a check-up
+I 7 Out for lunch, back in two time steps
+E 20 2 Too many pickles
+I 9 Back from lunch
+E 99 10 Flange failed!

homework.cabal

@@ -23,12 +23,15 @@ source-repository head
 library
   exposed-modules:
       Homework
-      Homework.Ch01
+      Homework.Ch01.CreditCards
+      Homework.Ch01.Hanoi
+      Homework.Ch02.Log
+      Homework.Ch02.LogAnalysis
   other-modules:
       Paths_homework
   hs-source-dirs:
       lib
-  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -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
@@ -39,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-deriving-strategies -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
@@ -49,11 +52,12 @@ test-suite test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-      Homework.Ch01Spec
+      Homework.Ch01.CreditCardsSpec
+      Homework.Ch01.HanoiSpec
       Paths_homework
   hs-source-dirs:
       test
-  ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -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/CreditCards.hs

@@ -1,4 +1,4 @@
-module Homework.Ch01 where
+module Homework.Ch01.CreditCards where
 
 toDigits :: Integer -> [Integer]
 toDigits = go []

lib/Homework/Ch01/Hanoi.hs

@@ -0,0 +1,205 @@
+module Homework.Ch01.Hanoi where
+
+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 :: (MonadFail m) => [String] -> Int -> m [Move]
+hanoi labels numDiscs = do
+  -- CONSTRUCT a set of pegs given the provided arguments
+  pegsStart <- initPegs labels numDiscs
+  -- Make a move
+  (moveMade, _) <- runPegs move pegsStart
+  -- Cheat the return for now, assume that movesMade is present for TDD
+  return [fromJust moveMade]
+
+{------------------------------------------------------------------------------}
+{- MAKE A MOVE ----------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+move :: (MonadFail m) => PegStep m (Maybe Move)
+move = do
+  topDiscA <- getTopDisc <$> getPeg 0
+  topDiscC <- getTopDisc <$> getPeg 2
+  if topDiscA >= topDiscC
+    then return Nothing
+    else do Just <$> makeMove 0 2
+
+{------------------------------------------------------------------------------}
+{- PEGS -----------------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+-- A set of pegs ordered from start to finish.
+data Pegs = Pegs
+  { pegsList :: [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 :: (MonadFail m) => [String] -> Int -> m Pegs
+initPegs (firstLabel : restLabels) numDiscs
+  | numDiscs > 0 =
+    return
+      Pegs
+        { pegsList = fillPeg firstLabel numDiscs : (emptyPeg <$> restLabels),
+          pegsMoves = []
+        }
+  | otherwise = fail "Can't create pegs with no discs"
+initPegs [] _ = fail "Can't create pegs without peg labels"
+
+{------------------------------------------------------------------------------}
+{- 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 -> 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 PEG ACCESSORS ------------------------------------------------------
+
+getPeg :: (MonadFail m) => Int -> PegStep m Peg
+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"
+
+putPeg :: (MonadFail m) => Peg -> PegStep m ()
+putPeg peg@Peg {pegLabel = label} = do
+  list <- askPegs pegsList
+  modifyPegs $ \pegs' -> do
+    newList <- go [] list
+    return $ pegs' {pegsList = newList}
+  where
+    go previous (current : next)
+      | pegLabel current == label = return $ reverse previous ++ peg : next
+      | otherwise = go (current : previous) next
+    go _ [] = fail $ "Could not replace peg with label " ++ show label ++ ": peg does not exist"
+
+-- EMBEDDED PEG METHODS --------------------------------------------------------
+
+makeMove :: (MonadFail m) => Int -> Int -> PegStep m Move
+makeMove from to = do
+  pushPeg to =<< popPeg from
+  fromLabel <- pegLabel <$> getPeg from
+  toLabel <- pegLabel <$> getPeg to
+  let move' = Move fromLabel toLabel
+  pushMove move'
+  return move'
+
+popPeg :: (MonadFail m) => Int -> PegStep m Disc
+popPeg n = do
+  peg@Peg {pegLabel = label, pegDiscs = discs} <- getPeg n
+  case discs of
+    topDisc : rest -> do
+      putPeg peg {pegDiscs = rest}
+      return topDisc
+    _ -> fail $ "Could not pop empty peg " ++ show label
+
+pushPeg :: (MonadFail m) => Int -> Disc -> PegStep m ()
+pushPeg n disc = do
+  peg <- getPeg n
+  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 ---------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+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 ------------------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+-- A peg is labeled and contains a stack of discs
+data Peg = Peg {pegLabel :: String, pegDiscs :: [Disc]} deriving (Eq, Show)
+
+-- CONSTRUCT a new peg with a label and number of disks to fill it with
+fillPeg :: String -> Int -> Peg
+fillPeg label numDiscs =
+  Peg
+    { pegLabel = label,
+      pegDiscs = stackDiscs numDiscs
+    }
+
+-- CONSTRUCT an empty peg with a label
+emptyPeg :: String -> Peg
+emptyPeg label = Peg {pegLabel = label, pegDiscs = []}
+
+-- GET the top disc from the peg, if it exists
+getTopDisc :: Peg -> Maybe Disc
+getTopDisc = headOption . pegDiscs
+  where
+    headOption (x : _) = Just x
+    headOption [] = Nothing
+
+{------------------------------------------------------------------------------}
+{- DISC -----------------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+-- A Disc has a size.
+data Disc = Disc {discSize :: Int} deriving (Eq, Ord, Show)
+
+-- CONSTRUCT a stack of discs
+stackDiscs :: Int -> [Disc]
+stackDiscs numDiscs = Disc <$> [1 .. numDiscs]
+
+{------------------------------------------------------------------------------}
+{- MOVE -----------------------------------------------------------------------}
+{------------------------------------------------------------------------------}
+
+-- A move has the peg that the disc was moved from and the peg it was moved to
+data Move = Move {moveFrom :: String, moveTo :: String} deriving (Eq, Show)

lib/Homework/Ch02/Log.hs

@@ -0,0 +1,39 @@
+module Homework.Ch02.Log where
+
+data MessageType
+  = Info
+  | Warning
+  | Error Int
+  deriving (Show, Eq)
+
+type TimeStamp = Int
+
+data LogMessage
+  = LogMessage MessageType TimeStamp String
+  | Unknown String
+  deriving (Show, Eq)
+
+data MessageTree
+  = Leaf
+  | Node MessageTree LogMessage MessageTree
+  deriving (Show, Eq)
+
+-- | @testParse p n f@ tests the log file parser @p@ by running it
+--   on the first @n@ lines of file @f@.
+testParse ::
+  (String -> [LogMessage]) ->
+  Int ->
+  FilePath ->
+  IO [LogMessage]
+testParse parse n file = take n . parse <$> readFile file
+
+-- | @testWhatWentWrong p w f@ tests the log file parser @p@ and
+--   warning message extractor @w@ by running them on the log file
+--   @f@.
+testWhatWentWrong ::
+  (String -> [LogMessage]) ->
+  ([LogMessage] -> [String]) ->
+  FilePath ->
+  IO [String]
+testWhatWentWrong parse whatWentWrong file =
+  whatWentWrong . parse <$> readFile file

lib/Homework/Ch02/LogAnalysis.hs

@@ -0,0 +1,9 @@
+module Homework.Ch02.LogAnalysis where
+
+import Homework.Ch02.Log
+
+parse :: String -> [LogMessage]
+parse = fmap parseMessage . lines
+
+parseMessage :: String -> LogMessage
+parseMessage = undefined

package.yaml

@@ -16,7 +16,8 @@ dependencies:
 
 library:
   source-dirs: lib
-  dependencies: []
+  # dependencies:
+  # - unordered-containers
 
 executables:
   homework:
@@ -50,10 +51,10 @@ ghc-options:
   - -Wincomplete-patterns
   - -Wincomplete-record-updates
   - -Wincomplete-uni-patterns
-  - -Wmissing-deriving-strategies
   - -Wmissing-home-modules
   - -Wname-shadowing
   - -Wpartial-fields
   - -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:
-  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+resolver: lts-18.13
 
 # 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:
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
+- original: lts-18.13
   completed:
-    sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml
-    size: 585817
+    sha256: d9e658a22cfe8d87a64fdf219885f942fef5fe2bcb156a9800174911c5da2443
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/13.yaml
+    size: 586268
 packages: []

test/Homework/Ch01/CreditCardsSpec.hs

@@ -1,6 +1,6 @@
-module Homework.Ch01Spec where
+module Homework.Ch01.CreditCardsSpec where
 
-import Homework.Ch01
+import Homework.Ch01.CreditCards
 import Test.Hspec
 
 spec :: Spec

test/Homework/Ch01/HanoiSpec.hs

@@ -0,0 +1,113 @@
+module Homework.Ch01.HanoiSpec where
+
+import Homework.Ch01.Hanoi
+import Test.Hspec
+
+spec :: Spec
+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"]
+
+    it "can solve for a stack of 1 disc" $ do
+      moves <- hanoiOf 1 --          a@[1] b@[] c@[]
+      moves
+        `shouldBe` [ Move "a" "c" -- a@[]  b@[] c@[1]
+                   ]
+
+    it "can solve for a stack of 2 discs" $ do
+      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@[1, 2]
+                   ]
+
+    it "can solve for a stack of 3 discs" $ do
+      moves <- hanoiOf 3 --           a@[1, 2, 3] b@[]     c@[]
+      moves
+        `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@[1, 2] c@[]
+                     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@[2, 3]
+                     Move "a" "c" --  a@[]        b@[]     c@[1, 2, 3]
+                   ]
+
+  {----------------------------------------------------------------------------}
+  {- MOVE ---------------------------------------------------------------------}
+  {----------------------------------------------------------------------------}
+
+  -- 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 pegs =
+            Pegs
+              { pegsList =
+                  [ Peg {pegLabel = "a", pegDiscs = [Disc 1, Disc 3]},
+                    Peg {pegLabel = "b", pegDiscs = []},
+                    Peg {pegLabel = "c", pegDiscs = [Disc 2]}
+                  ],
+                pegsMoves = []
+              }
+
+      -- run the function
+      (moveMade, pegsAfterMove) <- runPegs move pegs
+
+      -- a move should have been made
+      moveMade `shouldBe` Just (Move "a" "c")
+      -- the pegs should have changed
+      pegsList pegsAfterMove
+        `shouldBe` [ Peg {pegLabel = "a", pegDiscs = [Disc 3]},
+                     Peg {pegLabel = "b", pegDiscs = []},
+                     Peg {pegLabel = "c", pegDiscs = [Disc 1, Disc 2]}
+                   ]
+
+  {----------------------------------------------------------------------------}
+  {- PEGS ---------------------------------------------------------------------}
+  {----------------------------------------------------------------------------}
+
+  -- Testing constructor for a set of pegs
+  describe "initPegs" $ do
+    it "creates pegs with labels and fills the first peg with discs" $ do
+      pegs <- initPegs ["a", "b", "c"] 3
+      pegs
+        `shouldBe` Pegs
+          { pegsList =
+              [ Peg {pegLabel = "a", pegDiscs = [Disc 1, Disc 2, Disc 3]},
+                Peg {pegLabel = "b", pegDiscs = []},
+                Peg {pegLabel = "c", pegDiscs = []}
+              ],
+            pegsMoves = []
+          }
+
+  {----------------------------------------------------------------------------}
+  {- PEG ----------------------------------------------------------------------}
+  {----------------------------------------------------------------------------}
+
+  -- Testing constructor for a peg with discs
+  describe "fillPeg" $ do
+    it "creates a list of disks from biggest to smallest" $ do
+      fillPeg "a" 3
+        `shouldBe` Peg
+          { pegLabel = "a",
+            pegDiscs = [Disc 1, Disc 2, Disc 3]
+          }
+
+  -- Testing constructor for a peg without discs
+  describe "emptyPeg" $ do
+    it "creates an empty peg" $ do
+      emptyPeg "a"
+        `shouldBe` Peg
+          { pegLabel = "a",
+            pegDiscs = []
+          }
+
+  -- Testing constructor for a stack of discs
+  describe "stackDiscs" $ do
+    it "should create a stack of discs from smallest to largest" $ do
+      stackDiscs 3 `shouldBe` [Disc 1, Disc 2, Disc 3]