Marbles Solver using Gloss in Haskell

Marbles.hs

#!/usr/bin/env cabal
{- cabal:
    build-depends: base, gloss
-}
{-# LANGUAGE BinaryLiterals #-}
import Prelude hiding (Either(..))
import Data.Word (Word64)
import Data.List (nub)
import Data.Maybe (catMaybes)
import Data.Bits (testBit,setBit,clearBit,shiftR,popCount)
import qualified Data.Set as Set
import Graphics.Gloss.Interface.Pure.Animate

main :: IO ()
main = -- print solveMarbles
     animate (InWindow "Marbles" (600,600) (0, 0) ) white renderFrame

--------------------------------------------------------------------------------
--  Board Abstraction

-- | We represent the board as a 64 bit word.
-- If a marble is in a location then the bit is 1.  If not... not.
--
-- A board is a plus-shape with each line 3 slots large, like so:
--
-- @
--   6      O O O
--   5      O O O
--   4  O O O O O O O
--   3  O O O O O O O
--   2  O O O O O O O
--   1      O O O
--   0      O O O
--      0 1 2 3 4 5 6  (x-coord)
-- @
newtype MarbleBoard = MB Word64 deriving (Eq,Ord,Show)

(!) :: MarbleBoard -> (Int,Int) -> Bool
(!) (MB b) p = testBit b (pointToBitIndex p)

pointToBitIndex :: (Int,Int) -> Int
pointToBitIndex (x,y) = y*7 + x

-- | The board is "plus" shaped so not every bit in the Word64 is a valid location.
validPoint :: (Int,Int) -> Bool
validPoint p@(x,y) = validPointBoard ! p && x < 7 && y < 7 && x >= 0 && y >= 0
 where validPointBoard = MB 0b0011100001110011111111111111111111100111000011100

-- | Initially all spots in the board have a marble except the direct center.
initialBoard :: MarbleBoard
initialBoard = MB 0b0011100001110011111111110111111111100111000011100

peg,noPeg :: MarbleBoard -> (Int,Int) -> Bool
peg     = (!)
noPeg b = not . (b !)

-- | Jump a marble from one location in a direction, thus producing a new board (if it was a legal
-- move).
jumpMb :: MarbleBoard -> (Int,Int) -> Direction -> Maybe MarbleBoard
jumpMb mb@(MB b) src@(x,y) dir
    | peg mb src && good = Just $ MB (setBit (clearBit (clearBit b srcIx) midIx) dstIx)
    | otherwise          = Nothing
 where
  srcIx     = pointToBitIndex src
  dstIx     = pointToBitIndex dst
  midIx     = pointToBitIndex mid
  (mid,dst,good) =
        let (m,d) = case dir of
                        Up    -> ((x,y-1), (x,y-2))
                        Down  -> ((x,y+1), (x,y+2))
                        Left  -> ((x-1,y), (x-2,y))
                        Right -> ((x+1,y), (x+2,y))
        in (m,d, peg mb m && noPeg mb d && validPoint d)

data Direction = Up | Down | Left | Right deriving (Eq,Ord,Show,Enum,Bounded,Read)

jumps :: MarbleBoard -> (Int,Int) -> [MarbleBoard]
jumps mb pnt = catMaybes $ map (jumpMb mb pnt) [Up .. Right]

-- | All legal moves from a given board setup.
allJumps :: MarbleBoard -> [MarbleBoard]
allJumps mb = concatMap (jumps mb) [(x,y) | (x,y) <- allPos]

allPos :: [(Int,Int)]
allPos = [(x,y) | x <- [0..6], y <- [0..6], validPoint (x,y)]

-- | The game is won if only one marble remains.
won :: MarbleBoard -> Bool
won (MB b) = popCount b == 1

--------------------------------------------------------------------------------
--  Solver Logic

-- | Search of possible moves from the 'initialBoard' to a winning board.
solveMarbles :: [MarbleBoard]
solveMarbles = go Set.empty [j : [initialBoard] | j <-  allJumps initialBoard]
 where
  go observedBoards [] = []
  go observedBoards (thisMoveSequence@(b:_):rest)
    | won b     = thisMoveSequence
    | otherwise =
        let pruneDuplicateBoards =  filter (`Set.notMember` observedBoards)
            possibleNextBoards = [j : thisMoveSequence | j <- allJumps b]
            nexts = pruneDuplicateBoards possibleNextBoards
        in go (Set.union (Set.fromList nexts) observedBoards) (nexts ++ rest)

--------------------------------------------------------------------------------
--  Rendering

renderFrame :: Float -> Picture
renderFrame time = render board
 where
  board = reverse solveMarbles !! idx
  idx   = min (length solveMarbles - 1) (floor (time / timePerFrame))

timePerFrame :: Float
timePerFrame = 1.5

render :: MarbleBoard -> Picture
render b = pictures pieces
 where
 pieces = [renderPiece (x,y) | (x,y) <- allPos ]
 renderPiece pos
    | noPeg b pos = moveToSpot pos emptySpot
    | otherwise   = moveToSpot pos fullSpot

moveToSpot :: (Int,Int) -> Picture -> Picture
moveToSpot (x,y) = translate (fromIntegral x * spacing) (fromIntegral y * spacing)
 where spacing = 40

emptySpot, fullSpot, boardSpot :: Picture
emptySpot = color yellow boardSpot
fullSpot = color black boardSpot
boardSpot = thickCircle 1 30