Towers of Hanoi in Haskell, part II

hanoi-2.hs

import Control.Monad.State

type Disc = Int
type Tower = [Disc]
data Towers = Towers
            { towerA :: Tower
            , towerB :: Tower
            , towerC :: Tower
            } deriving (Show)

data TowerName = A | B | C
                 deriving (Show)

type Move = (TowerName, TowerName)

type TowersState = State Towers

data Pointer = Pointer
             { name :: TowerName
             , pop  :: TowersState Disc
             , push :: Disc -> TowersState ()
             }

ptrA = Pointer
     { name = A
     , pop  =       modset $ \(Towers (d:as) bs cs) -> ( d, Towers    as  bs cs)
     , push = \d -> modset $ \(Towers as bs cs)     -> ((), Towers (d:as) bs cs)
     }

ptrB = Pointer
     { name = B
     , pop  =       modset $ \(Towers as (d:bs) cs) -> ( d, Towers as    bs  cs)
     , push = \d -> modset $ \(Towers as bs cs)     -> ((), Towers as (d:bs) cs)
     }

ptrC = Pointer
     { name = C
     , pop  =       modset $ \(Towers as bs (d:cs)) -> ( d, Towers as bs    cs )
     , push = \d -> modset $ \(Towers as bs cs)     -> ((), Towers as bs (d:cs))
     }

modset :: (Towers -> (a, Towers)) -> TowersState a
modset f = do
    s <- get
    let (r, s') = f s
    put s'
    return r

moveOne :: Pointer -> Pointer -> TowersState [Move]
moveOne src dst = do
    d <- pop src
    push dst d
    return [(name src, name dst)]

moveMany :: Int -> Pointer -> Pointer -> Pointer -> TowersState [Move]
moveMany 1 src dst aux = moveOne src dst
moveMany n src dst aux = do
    m1 <- moveMany (n-1) src aux dst
    m2 <- moveMany    1  src dst aux
    m3 <- moveMany (n-1) aux dst src
    return (m1++m2++m3)

solve :: Towers -> ([Move], Towers)
solve towers =
    let count = length $ towerA towers
    in runState (moveMany count ptrA ptrB ptrC) towers

towers = Towers [1, 2, 3, 4] [] []

main = putStrLn $ show $ solve towers