# Peg Solitaire

Half our imports are for the user interface:

import Control.Monad
import Data.Bool
import Data.IORef
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas


Setting up the board and acting on the selection of a row and column is just a handful of lines:

initState :: Map (Int, Int) Bool
initState = let f x = (x - 3)^2 <= 1 in M.fromList
[((r, c), r /= 3 || c /= 3) | r <- [0..6], c <- [0..6], f r || f c]

act :: (Map (Int, Int) Bool, Maybe (Int, Int)) -> (Int, Int)
-> (Map (Int, Int) Bool, Maybe (Int, Int))
act (st, sel) p@(r, c)
| M.notMember p st = (st, Nothing)
| Nothing <- sel   = (st, if st M.! p then Just p else Nothing)
| p' == p          = (st, Nothing)
| st M.! p         = (st, Just p)
| (r' - r)^2 + (c - c')^2 == 4, st M.! m = (M.insert p' False $M.insert p True$ M.insert m False st, Just p)
| otherwise        = (st, Nothing)
where Just p'@(r', c') = sel
m = (div (r + r') 2, div (c + c') 2)


The rest of the program deals with drawing the board and handling user input:

sz :: Int
sz = 40

spot :: (Int, Int) -> Double -> Picture ()
spot (r, c) t = let m = div sz 2 in fill $circle (fromIntegral (sz*c + m), fromIntegral (sz*r + m)) t pegPic :: ((Int, Int), Bool) -> Picture () pegPic (p, b) = color (RGB (bool 0 255 b) 0 0)$ spot p rad

victory :: Canvas -> Map (Int, Int) Bool -> IO ()
victory canvas st = when
(M.filterWithKey (const id) st == M.singleton (3, 3) True) $do let m = div sz 2 [ox, oy] = fromIntegral <$> [sz*3 + m, sz*3 + m]
renderOnTop canvas $color (RGB 255 255 255)$ sequence_ [
fill $circle (ox - rad/4, oy - rad/4) 1.5, fill$ circle (ox + rad/4, oy - rad/4) 1.5,
lineWidth 2 $stroke$ arc (ox, oy) (rad/2) (1/6*pi) (5/6*pi)]

paint :: Canvas -> (Map (Int, Int) Bool, Maybe (Int, Int)) -> IO ()
paint canvas (st, sel) = do
render canvas $case sel of Just p -> color (RGB 127 255 255)$ spot p $rad + 3 Nothing -> pure () void$ renderOnTop canvas $mapM pegPic$ M.assocs st
victory canvas st

main :: IO ()
main = withElems ["canvas"] $\[cElem] -> do Just canvas <- fromElem cElem ref <- newIORef (initState, Nothing) let refresh = readIORef ref >>= paint canvas refresh void$ cElem onEvent MouseDown \$ \(MouseData (x, y) _ _) -> do
modifyIORef ref (act (div y sz, div x sz))
refresh


Ben Lynn blynn@cs.stanford.edu 💡