Created
April 24, 2018 10:01
-
-
Save echuber2/36fe846c19c97505fcdee62cad404561 to your computer and use it in GitHub Desktop.
CS 421 Spring 2018 - Tower of Hanoi practice problem example solution
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- Tower of Hanoi practice problem by Mattox Beckman | |
-- example solution by Eric Huber (may be inelegant) 20180424 | |
module Lib where | |
import Data.Hashable | |
import qualified Data.HashSet as H | |
type Stack = [Int] | |
type Config = (Stack, Stack, Stack) | |
data Hanoi = Hanoi Config [Config] | |
deriving Show | |
instance Eq Hanoi where | |
(==) (Hanoi c _) (Hanoi c' _) = c == c' | |
instance Hashable Hanoi where | |
hashWithSalt s (Hanoi c _) = s `hashWithSalt` c | |
fix' :: Eq a => (a -> a) -> a -> a | |
fix' f x = if g == x | |
then g | |
else fix' f g | |
where g = f x | |
initConf = ([1,2,3], [], []) | |
initSet = H.singleton (Hanoi initConf []) | |
findPath :: Config -> Maybe [Config] | |
findPath conf | |
= case H.toList $ H.filter (Hanoi conf [] ==) allReachSet of | |
[Hanoi _ path] -> Just $ reverse $ conf:path | |
_ -> Nothing | |
-- Your code here! | |
-- Moves a piece from first stack to second, or else leaves stacks unchanged. | |
movePiece :: Stack -> Stack -> (Stack,Stack) | |
movePiece [] ys = ([], ys) | |
movePiece (x:xs) [] = (xs, [x]) | |
movePiece xstack@(x:xs) ystack@(y:_) | |
| x <= y = (xs, x:ystack) | |
| otherwise = (xstack,ystack) | |
-- Changes type signature of movePiece to take a pair instead of using currying. | |
movePiecePair = uncurry movePiece | |
-- Reverses a pair. | |
flipPair (a,b) = (b,a) | |
-- Pattern matching helpers. | |
leftGet (a,b,_) = (a,b) | |
leftPut (_,_,c) (a,b) = (a,b,c) | |
rightGet (_,b,c) = (b,c) | |
rightPut (a,_,_) (b,c) = (a,b,c) | |
outerGet (a,_,c) = (a,c) | |
outerPut (_,b,_) (a,c) = (a,b,c) | |
-- Pair up the corresponding putter and getter functions. | |
putterGetters = zip [leftPut,rightPut,outerPut] [leftGet,rightGet,outerGet] | |
-- Get sets of the putters and getters both with and without a desired extra flip operation. | |
putterGetterFlippers = [(p,g,f) | (p,g) <- putterGetters, f <- [id,flipPair]] | |
-- Returns true if the new conf is different from the old one. | |
isChangedConf oldConf newHanoi@(Hanoi newConf newHistory) = oldConf /= newConf | |
-- Filters a list of Hanois to only keep the ones where the state changed with the latest move | |
-- (eliminates no-ops from the tree of possibility) | |
getChangedHanois oldConf hanoiList = filter (isChangedConf oldConf) hanoiList | |
-- Given current Hanoi, get set of all immediately adjacent future Hanois. | |
-- The flipper is used to reverse the direction on movePiece sometimes. | |
-- (When it's id, nothing extra happens.) | |
move :: Hanoi -> H.HashSet Hanoi | |
move oldHanoi@(Hanoi conf@(aStack, bStack, cStack) history) = H.fromList changedHanois where | |
changedHanois = getChangedHanois conf initialHanois where | |
initialHanois = [Hanoi (putter conf $ flipper . movePiecePair . flipper . getter $ conf) (conf:history) | (putter,getter,flipper) <- putterGetterFlippers] | |
-- Readability note: The above usage of composition (.) and the dollar sign operator ($) | |
-- makes it the same as this: | |
-- initialHanois = [Hanoi (putter conf ((flipper . movePiecePair . flipper . getter) conf)) (conf:history) | (putter,getter,flipper) <- putterGetterFlippers] | |
-- Which seems easier to read to you? | |
-- Given a set of reachable Hanois, find the set of future Hanois immediately adjacent | |
moveSet :: H.HashSet Hanoi -> H.HashSet Hanoi | |
moveSet s = H.unions . H.toList $ H.map move s | |
-- Add the current state to a set of immediately adjacent future states | |
oneMoveReachSet :: H.HashSet Hanoi -> H.HashSet Hanoi | |
oneMoveReachSet s = H.union s (moveSet s) | |
-- Repeatedly explore the tree of possibility until all configuration states are enumerated | |
allReachSet :: H.HashSet Hanoi | |
allReachSet = fix' oneMoveReachSet initSet | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment