keywordsalad/haskell-homework
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Logan McGrath 2021-10-08 14:27:33 -07:00
parent 3dd86d3c38
commit 31dfe55826
6 changed files with 115 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
homework.cabal
View File

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

127
lib/Homework/Ch01/Hanoi.hs
View File

@ -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 pegLabelA pegLabelB pegLabelC numDiscs = do
let -- CONSTRUCT a set of pegs given the provided arguments
pegsStart = initPegs pegLabelA pegLabelB pegLabelC numDiscs
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
@ -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
topDiscC <- getTopDisc <$> getPegC
topDiscA <- getTopDisc <$> getPeg 0
topDiscC <- getTopDisc <$> getPeg 2
if topDiscA >= topDiscC
then return Nothing
else do
pushPegC =<< popPegA
Just <$> makeMove "a" "c"
else do Just <$> makeMove 0 2
{------------------------------------------------------------------------------}
{- PEGS -----------------------------------------------------------------------}
@ -34,22 +32,22 @@ move = do
-- A set of pegs ordered from start to finish.
data Pegs = Pegs
{ pegsPegA :: Peg,
pegsPegB :: Peg,
pegsPegC :: Peg,
{ 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 :: String -> String -> String -> Int -> Pegs
initPegs pegLabelA pegLabelB pegLabelC numDiscs =
initPegs :: (MonadFail m) => [String] -> Int -> m Pegs
initPegs (firstLabel : restLabels) numDiscs
| numDiscs > 0 =
return
Pegs
{ pegsPegA = fillPeg pegLabelA numDiscs,
pegsPegB = emptyPeg pegLabelB,
pegsPegC = emptyPeg pegLabelC,
{ 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 -------------------------------------------------------------------}
@ -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 f = f =<< getPegs
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 PEGS GETTERS -------------------------------------------------------
-- EMBEDDED PEG ACCESSORS ------------------------------------------------------
getPegA :: (Monad m) => PegStep m Peg
getPegA = askPegs (return . pegsPegA)
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"
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}
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 :: (Monad m) => String -> String -> PegStep m Move
makeMove :: (MonadFail m) => Int -> Int -> PegStep m Move
makeMove from to = do
let move' = Move from to
pegs <- getPegs
putPegs pegs {pegsMoves = move' : pegsMoves pegs}
pushPeg to =<< popPeg from
fromLabel <- pegLabel <$> getPeg from
toLabel <- pegLabel <$> getPeg to
let move' = Move fromLabel toLabel
pushMove move'
return move'
popPegA :: (Monad m) => PegStep m Disc
popPegA = do
peg <- getPegA
let disc = last $ pegDiscs peg
rest = init $ pegDiscs peg
putPegA $ peg {pegDiscs = rest}
return disc
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
pushPegC :: (Monad m) => Disc -> PegStep m ()
pushPegC disc = do
peg <- getPegC
putPegC $ peg {pegDiscs = pegDiscs peg <> [disc]}
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 ---------------------------------------------------------}
@ -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
[x] -> Just x
_ : xs' -> lastOption xs'
[] -> Nothing
headOption (x : _) = Just x
headOption [] = 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 -----------------------------------------------------------------------}

1
package.yaml
View File

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

3
stack.yaml
View File

@ -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.

9
stack.yaml.lock
View File

@ -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: []

59
test/Homework/Ch01/HanoiSpec.hs
View File

@ -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 "a" "c", -- a@[] b@[2, 1] c@[3]
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@[3, 2]
Move "a" "c" -- a@[] b@[] c@[3, 2, 1]
Move "b" "c", -- a@[1] b@[] c@[2, 3]
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
pegs =
emptyPegs
{ pegsPegA = (emptyPeg "a") {pegDiscs = [Disc 3, Disc 1]},
pegsPegC = (emptyPeg "c") {pegDiscs = [Disc 2]}
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
@ -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
`shouldBe` pegs
{ pegsPegA = (pegsPegA pegs) {pegDiscs = [Disc 3]},
pegsPegC = (pegsPegC pegs) {pegDiscs = [Disc 2, Disc 1]},
pegsMoves = [Move {moveFrom = "a", moveTo = "c"}]
}
pegsList pegsAfterMove
`shouldBe` [ Peg {pegLabel = "a", pegDiscs = [Disc 3]},
Peg {pegLabel = "b", pegDiscs = []},
Peg {pegLabel = "c", pegDiscs = [Disc 1, Disc 2]}
]
{----------------------------------------------------------------------------}
{- 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]},
pegsPegB = Peg {pegLabel = "b", pegDiscs = []},
pegsPegC = Peg {pegLabel = "c", pegDiscs = []},
{ pegsList =
[ Peg {pegLabel = "a", pegDiscs = [Disc 1, Disc 2, Disc 3]},
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
stackDiscs 3 `shouldBe` [Disc 3, Disc 2, Disc 1]
it "should create a stack of discs from smallest to largest" $ do
stackDiscs 3 `shouldBe` [Disc 1, Disc 2, Disc 3]