Tower of Hanoi in Haskell, part 3

hanoi-3.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
             , getTower :: Towers -> Tower
             , setTower :: Towers -> Tower -> Towers
             }

ptrA = Pointer
     { name = A
     , getTower = towerA
     , setTower = \t a -> t {towerA=a}
     }

ptrB = Pointer
     { name = B
     , getTower = towerB
     , setTower = \t a -> t {towerB=a}
     }

ptrC = Pointer
     { name = C
     , getTower = towerC
     , setTower = \t a -> t {towerC=a}
     }

modset :: (Tower -> (a, Tower)) -> Pointer -> TowersState a
modset f ptr = do
    s <- get
    let (r, s') = f $ getTower ptr s
    put $ setTower ptr s s'
    return r

pop :: Pointer -> TowersState Disc
pop = modset (\(x:xs) -> (x, xs))

push :: Disc -> Pointer -> TowersState ()
push d = modset (\xs -> ((), (d:xs)))

moveOne :: Pointer -> Pointer -> TowersState [Move]
moveOne src dst = do
    d <- pop src
    push d dst
    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