2021-10-01 00:04:16 +00:00
|
|
|
module Homework.Ch01.Hanoi where
|
|
|
|
|
2021-10-06 19:19:22 +00:00
|
|
|
import Data.Maybe
|
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- | 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.
|
2021-10-08 21:27:33 +00:00
|
|
|
hanoi :: (MonadFail m) => [String] -> Int -> m [Move]
|
|
|
|
hanoi labels numDiscs = do
|
|
|
|
-- CONSTRUCT a set of pegs given the provided arguments
|
|
|
|
pegsStart <- initPegs labels numDiscs
|
2021-10-07 14:06:19 +00:00
|
|
|
-- Make a move
|
|
|
|
(moveMade, _) <- runPegs move pegsStart
|
|
|
|
-- Cheat the return for now, assume that movesMade is present for TDD
|
|
|
|
return [fromJust moveMade]
|
2021-10-06 19:12:47 +00:00
|
|
|
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
2021-10-07 14:06:19 +00:00
|
|
|
{- MAKE A MOVE ----------------------------------------------------------------}
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
2021-10-08 21:27:33 +00:00
|
|
|
move :: (MonadFail m) => PegStep m (Maybe Move)
|
2021-10-07 14:06:19 +00:00
|
|
|
move = do
|
2021-10-08 21:27:33 +00:00
|
|
|
topDiscA <- getTopDisc <$> getPeg 0
|
|
|
|
topDiscC <- getTopDisc <$> getPeg 2
|
2021-10-07 14:06:19 +00:00
|
|
|
if topDiscA >= topDiscC
|
|
|
|
then return Nothing
|
2021-10-08 21:27:33 +00:00
|
|
|
else do Just <$> makeMove 0 2
|
2021-10-06 20:39:05 +00:00
|
|
|
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- PEGS -----------------------------------------------------------------------}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- A set of pegs ordered from start to finish.
|
2021-10-07 14:06:19 +00:00
|
|
|
data Pegs = Pegs
|
2021-10-08 21:27:33 +00:00
|
|
|
{ pegsList :: [Peg],
|
2021-10-07 14:06:19 +00:00
|
|
|
pegsMoves :: [Move]
|
|
|
|
}
|
|
|
|
deriving (Eq, Show)
|
2021-10-06 21:49:48 +00:00
|
|
|
|
|
|
|
-- CONSTRUCT a set of pegs with their labels and number of discs to fill the first peg with
|
2021-10-08 21:27:33 +00:00
|
|
|
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"
|
2021-10-06 21:49:48 +00:00
|
|
|
|
2021-10-07 14:06:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- 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
|
2021-10-08 21:27:33 +00:00
|
|
|
askPegs :: (Monad m) => (Pegs -> a) -> PegStep m a
|
|
|
|
askPegs f = f <$> getPegs
|
2021-10-07 14:06:19 +00:00
|
|
|
|
|
|
|
-- MODIFY pegs using a function
|
|
|
|
modifyPegs :: (Monad m) => (Pegs -> PegStep m Pegs) -> PegStep m ()
|
|
|
|
modifyPegs f = putPegs =<< f =<< getPegs
|
|
|
|
|
2021-10-08 21:27:33 +00:00
|
|
|
-- EMBEDDED PEG ACCESSORS ------------------------------------------------------
|
2021-10-07 14:06:19 +00:00
|
|
|
|
2021-10-08 21:27:33 +00:00
|
|
|
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"
|
2021-10-07 14:06:19 +00:00
|
|
|
|
|
|
|
-- EMBEDDED PEG METHODS --------------------------------------------------------
|
|
|
|
|
2021-10-08 21:27:33 +00:00
|
|
|
makeMove :: (MonadFail m) => Int -> Int -> PegStep m Move
|
2021-10-07 14:06:19 +00:00
|
|
|
makeMove from to = do
|
2021-10-08 21:27:33 +00:00
|
|
|
pushPeg to =<< popPeg from
|
|
|
|
fromLabel <- pegLabel <$> getPeg from
|
|
|
|
toLabel <- pegLabel <$> getPeg to
|
|
|
|
let move' = Move fromLabel toLabel
|
|
|
|
pushMove move'
|
2021-10-07 14:06:19 +00:00
|
|
|
return move'
|
|
|
|
|
2021-10-08 21:27:33 +00:00
|
|
|
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}
|
2021-10-07 14:06:19 +00:00
|
|
|
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- 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
|
|
|
|
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- PEG ------------------------------------------------------------------------}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- 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
|
2021-10-06 20:39:05 +00:00
|
|
|
fillPeg :: String -> Int -> Peg
|
2021-10-06 21:49:48 +00:00
|
|
|
fillPeg label numDiscs =
|
2021-10-06 20:39:05 +00:00
|
|
|
Peg
|
|
|
|
{ pegLabel = label,
|
2021-10-06 21:49:48 +00:00
|
|
|
pegDiscs = stackDiscs numDiscs
|
2021-10-06 20:39:05 +00:00
|
|
|
}
|
2021-10-06 19:12:47 +00:00
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- CONSTRUCT an empty peg with a label
|
2021-10-06 20:39:05 +00:00
|
|
|
emptyPeg :: String -> Peg
|
|
|
|
emptyPeg label = Peg {pegLabel = label, pegDiscs = []}
|
2021-10-06 21:49:48 +00:00
|
|
|
|
2021-10-07 14:06:19 +00:00
|
|
|
-- GET the top disc from the peg, if it exists
|
|
|
|
getTopDisc :: Peg -> Maybe Disc
|
2021-10-08 21:27:33 +00:00
|
|
|
getTopDisc = headOption . pegDiscs
|
2021-10-07 14:06:19 +00:00
|
|
|
where
|
2021-10-08 21:27:33 +00:00
|
|
|
headOption (x : _) = Just x
|
|
|
|
headOption [] = Nothing
|
2021-10-07 14:06:19 +00:00
|
|
|
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- DISC -----------------------------------------------------------------------}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- A Disc has a size.
|
|
|
|
data Disc = Disc {discSize :: Int} deriving (Eq, Ord, Show)
|
|
|
|
|
|
|
|
-- CONSTRUCT a stack of discs
|
|
|
|
stackDiscs :: Int -> [Disc]
|
2021-10-08 21:27:33 +00:00
|
|
|
stackDiscs numDiscs = Disc <$> [1 .. numDiscs]
|
2021-10-06 21:49:48 +00:00
|
|
|
|
2021-10-07 13:56:19 +00:00
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
{- MOVE -----------------------------------------------------------------------}
|
|
|
|
{------------------------------------------------------------------------------}
|
|
|
|
|
2021-10-06 21:49:48 +00:00
|
|
|
-- 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)
|