halma/src/Game/Halma/Board/Draw.hs
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Game.Halma.Board.Draw
( defaultTeamColours
, drawBoard', drawBoard
) where
import Game.Halma.Board
import Diagrams.Prelude
import Math.Geometry.Grid
defaultTeamColours :: Team -> Colour Double
defaultTeamColours team =
-- colors from http://clrs.cc/
case team of
North -> sRGB24read "#0074D9" -- blue
Northeast -> sRGB24read "#2ECC40" -- green
Northwest -> sRGB24read "#B10DC9" -- purple
South -> sRGB24read "#FF4136" -- red
Southeast -> sRGB24read "#111111" -- black
Southwest -> sRGB24read "#FF851B" -- orange
-- | Render the board using the helper function for drawing the fields.
-- Supports querying for field positions.
drawBoard'
:: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b)
=> HalmaGrid
-> ((Int, Int) -> Diagram b)
-> QDiagram b V2 Double (Option (Last (Int, Int)))
drawBoard' grid drawField =
targets `atop`
(mconcat
[ pieces # lw ultraThin
, circles 0.15 # fc gray # lw none
, gridLines # lc gray # lw thin
] # value (Option Nothing))
where
dirX = unitX
dirY = rotateBy (1/6) unitX
toCoord (x, y) = p2 $ unr2 $ fromIntegral x *^ dirX ^+^ fromIntegral y *^ dirY
justLast = Option . Just . Last
clickTarget = circle 0.4 # lw none
targets = position $ map (\f -> (toCoord f, clickTarget # value (justLast f))) fields
fields = indices grid
circles r = position $ zip (map toCoord fields) $ repeat $ circle r
gridLines =
mconcat $ map (\(p, q) -> fromVertices [toCoord p, toCoord q]) $
concatMap (\f -> map ((,) f) $ filter (>= f) (neighbours grid f)) fields
pieces = position $ map (\p -> (toCoord p, drawField p)) fields
-- | Render the board using the given team colors. Supports querying for field
-- positions.
drawBoard
:: (V b ~ V2, N b ~ Double, Renderable (Path V2 Double) b)
=> HalmaBoard
-> (Team -> Colour Double)
-> QDiagram b V2 Double (Option (Last (Int, Int)))
drawBoard halmaBoard teamColours = drawBoard' (getGrid halmaBoard) drawField
where
drawPiece piece =
let c = teamColours (pieceTeam piece)
in circle 0.25 # fc c # lc (darken 0.5 c)
drawField = maybe mempty drawPiece . flip lookupHalmaBoard halmaBoard