CS 421 Spring 2018 - Tower of Hanoi practice problem example solution

hanoi_solution_erichuber_commented_Lib.hs

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