hanoi.hs

{-# LANGUAGE RankNTypes #-}

import Data.Functor.Identity
import Graphics.Gloss

-- * types

type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s

ix :: Int -> Lens [a] a
ix n f xs' =
  let x:xs = xs'
  in  if n == 0
        then (:xs) `fmap` f x
        else (x:) `fmap` ix (n - 1) f xs

data Peg = A | B | C deriving (Eq, Ord, Enum, Show)

type Move = (Peg, Peg)

data Disk = Disk
  { diskWidth :: Float
  , diskColor :: Color
  } deriving Show

type Board = [[Disk]]

-- * functions

hanoi' :: Int -> Peg -> Peg -> Peg -> [Move]
hanoi' 0 _ _ _ = []
hanoi' hgt from to extra =
  hanoi' (hgt - 1) from extra to ++ [(from, to)] ++ hanoi' (hgt - 1) extra to from

diskPicture :: Disk -> Picture
diskPicture (Disk width color) = Color color poly
  where poly = Polygon [(-width, 5.0), (width, 5.0), (width, -5.0), (-width, -5.0)]

pegPicture :: [Disk] -> Picture
pegPicture pegs =
  Pictures $ reverse $ 
    map (\(y, disk) -> Translate 0 y (diskPicture disk)) $ zip [0.0, 20.0..] (reverse pegs)

boardPicture :: Board -> Picture
boardPicture [a, b, c] =
  Pictures $ map (\(x, peg) -> Translate x (-100.0) (pegPicture peg)) $ zip [-300.0, 0.0..] [a, b, c]

colors :: [Color]
colors = map (\(r, g, b) -> makeColor r g b 1.0) triplets
  where
    normalize byte = fromIntegral byte * (1.0 / 255.0)
    f (r, g, b) = (normalize r, normalize g, normalize b)
    triplets = cycle $ map f [(238,64,53), (243,119,54), (253,244,152), (123,192,67), (3,146,207)]

disks :: [Disk]
disks = map (\(width, color) -> Disk width color) $ zip [20.0, 30.0..] colors

newBoard :: Int -> Board
newBoard hgt = [(take hgt disks), [], []]

movesForBoard :: Board -> [Move]
movesForBoard pegs = hanoi' (length $ head pegs) A B C

moveDisk :: Move -> Board -> Board
moveDisk (from, to) b = let (d, b') = takePeg from b
                        in  putPeg to d b'

takePeg :: Peg -> Board -> (Disk, Board)
takePeg p = ix (fromEnum p) $ \(d:ds) -> (d, ds)

putPeg :: Peg -> Disk -> Board -> Board
putPeg p d = runIdentity . ix (fromEnum p) (Identity . (d:))

main = 
  let disp = InWindow "Hanoi" (1000, 400) (200, 200)
      black = makeColor 0 0 0 0
      board = newBoard 10
      step _ _ (b, []) = (b, [])
      step _ _ (b, m:ms) = (moveDisk m b, ms)
  in  simulate disp black 10 (board, movesForBoard board) (boardPicture . fst) step