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

But luckily, I made one earlier!

Browse Source
This commit is contained in:
Logan McGrath 2021-10-07 07:06:19 -07:00
parent 73a9c01e0b
commit 6854b850fe
2 changed files with 153 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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 pegLabelA pegLabelB pegLabelC numDiscs =
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
-- Make a move
(movesMade, _) = move pegsStart
in -- Cheat the return for now, assume that movesMade is present for TDD
Right [fromJust movesMade]
-- Make a move
(moveMade, _) <- runPegs move pegsStart
-- Cheat the return for now, assume that movesMade is present for TDD
return [fromJust moveMade]
{------------------------------------------------------------------------------}
{- MOVE -----------------------------------------------------------------------}
{- MAKE A MOVE ----------------------------------------------------------------}
{------------------------------------------------------------------------------}
-- | Make a move
-- Given some pegs, make a move if a move is possible and return the pegs with
-- the move that was made.
--
-- The return of this function is a 2-tuple of ($THE_MOVE, $PEGS_AFTER_MOVE).
move :: Pegs -> (Maybe Move, Pegs)
move pegs =
let -- pull apart the first peg
pegA@(Peg firstPegLabel firstPegDiscs) = pegsPegA pegs
-- pull apart the last peg
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
)
move :: (Monad m) => PegStep m (Maybe Move)
move = do
topDiscA <- getTopDisc <$> getPegA
topDiscC <- getTopDisc <$> getPegC
if topDiscA >= topDiscC
then return Nothing
else do
popPegA
pushPegC $ fromJust topDiscA
Just <$> makeMove "a" "c"
{------------------------------------------------------------------------------}
{- 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 -----------------------------------------------------------------------}
{------------------------------------------------------------------------------}

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

@ -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@[]
`shouldBe` Right
[ Move "a" "c" -- a@[] b@[] c@[1]
]
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
hanoiOf 2 -- a@[2, 1] b@[] c@[]
`shouldBe` Right
[ 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]
]
moves <- hanoiOf 2 -- a@[2, 1] 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]
]
it "can solve for a stack of 3 discs" $ do
hanoiOf 3 -- a@[3, 2, 1] b@[] c@[]
`shouldBe` Right
[ Move "a" "c", -- a@[3, 2] 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 "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]
]
moves <- hanoiOf 3 -- a@[3, 2, 1] b@[] c@[]
moves
`shouldBe` [ Move "a" "c", -- a@[3, 2] 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 "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 ---------------------------------------------------------------------}
@ -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 = []
}
{----------------------------------------------------------------------------}