Skip to content

Instantly share code, notes, and snippets.

@mdunsmuir
Last active August 29, 2015 14:18
Show Gist options
  • Save mdunsmuir/22ee392401b996cdd9e0 to your computer and use it in GitHub Desktop.
Save mdunsmuir/22ee392401b996cdd9e0 to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment