hstzaar-0.9: src/GUI.hs
{-
GTK GUI interface for HsTZAAR board game
Pedro Vasconcelos, 2011
-}
module GUI (gui) where
import Data.Version
import Paths_hstzaar(version)
import Graphics.UI.Gtk hiding (eventSent,on)
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk.Glade
import Graphics.Rendering.Cairo hiding (version)
import Data.Function (on)
import qualified Data.Map as Map
import Data.Map (Map, (!))
import Data.List (minimumBy, sortBy)
import Control.Concurrent
import Control.Monad (when, filterM, liftM, mplus, msum)
import System.IO
import System.FilePath
import System.Random hiding (next)
import Board
import AI
import AI.Tree
import AI.Eval
-- import History (History)
-- import qualified History as History
import Serialize -- convert to/from XML
import Text.XML.Light
-- | Selection state
data State = Wait0 -- wait for human (1st position)
| Wait1 Position -- wait for human (2nd position)
| WaitAI (MVar Move) -- wait for AI
| Finish -- game ended
-- | are we waiting for AI?
waitingAI :: State -> Bool
waitingAI (WaitAI _) = True
waitingAI _ = False
-- | initial game & state, given a starting board and color
initGameState :: GUI -> Board -> Board.Color -> IO (Game,State)
initGameState gui b White = return (initGame b White, Wait0)
initGameState gui b Black = do ai <- getAI gui
mvar <- newEmptyMVar
forkOS $ runAI ai b mvar
return (initGame b Black, WaitAI mvar)
-- | record to hold references to the GUI widgets
data GUI = GUI {
mainwin :: Window,
canvas :: DrawingArea,
aboutdialog :: AboutDialog,
startdialog :: Dialog,
fixed_position :: CheckButton,
play_white :: RadioButton,
play_black :: RadioButton,
statusbar:: Statusbar,
progressbar:: ProgressBar,
menu_item_new :: MenuItem,
menu_item_open :: MenuItem,
menu_item_save :: MenuItem,
-- menu_item_save_as :: MenuItem,
menu_item_quit :: MenuItem,
menu_item_undo :: MenuItem,
menu_item_redo :: MenuItem,
menu_item_pass :: MenuItem,
menu_item_draw_stacks :: CheckMenuItem,
menu_item_show_heights :: CheckMenuItem,
menu_item_show_moves :: CheckMenuItem,
-- menu_item_random_start :: CheckMenuItem,
-- menu_item_human :: CheckMenuItem,
menu_item_ai_players :: [(RadioMenuItem, AI)],
menu_item_about :: MenuItem,
open_file_chooser :: FileChooserDialog,
save_file_chooser :: FileChooserDialog,
contextid :: ContextId
}
-- | load GUI elements from XML glade file
loadGlade :: FilePath -> IO GUI
loadGlade path =
do out <- xmlNew path
case out of
Nothing -> error ("unable to open glade file " ++ show path)
Just xml ->
do mw <- xmlGetWidget xml castToWindow "mainwindow"
abd <- xmlGetWidget xml castToAboutDialog "aboutdialog"
std <- xmlGetWidget xml castToDialog "startdialog"
fr <- xmlGetWidget xml castToFrame "frame1"
sb <- xmlGetWidget xml castToStatusbar "statusbar"
pb <- xmlGetWidget xml castToProgressBar "progressbar"
mn <- xmlGetWidget xml castToMenuItem "menu_item_new"
mo <- xmlGetWidget xml castToMenuItem "menu_item_open"
ms <- xmlGetWidget xml castToMenuItem "menu_item_save"
mq <- xmlGetWidget xml castToMenuItem "menu_item_quit"
mun<- xmlGetWidget xml castToMenuItem "menu_item_undo"
mre<- xmlGetWidget xml castToMenuItem "menu_item_redo"
mpa<- xmlGetWidget xml castToMenuItem "menu_item_pass"
mds<- xmlGetWidget xml castToCheckMenuItem "menu_item_draw_stacks"
msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights"
msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves"
fixp <- xmlGetWidget xml castToCheckButton "fixedposition"
playw <- xmlGetWidget xml castToRadioButton "playwhite"
playb <- xmlGetWidget xml castToRadioButton "playblack"
mab<- xmlGetWidget xml castToMenuItem "menu_item_about"
-- fill in dynamic parts
aboutDialogSetVersion abd (showVersion version)
bd <- drawingAreaNew
containerAdd fr bd
m<- xmlGetWidget xml castToMenu "menu_ai"
r <- radioMenuItemNewWithLabel (name $ snd $ head aiPlayers)
menuAttach m r 0 1 0 1
rs@(r1:_) <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t)
menuAttach m w 0 1 i (i+1)
return w
| (t,i)<-zip (tail aiPlayers) [1..]]
-- select default AI
checkMenuItemSetActive r1 True
-- open/save file dialogs
ff <- fileFilterNew
fileFilterSetName ff "Tzaar saved games (*.tza)"
fileFilterAddPattern ff "*.tza"
opf <- fileChooserDialogNew (Just "Open saved game") Nothing FileChooserActionOpen
[("Cancel",ResponseCancel),("Open",ResponseOk)]
fileChooserAddFilter opf ff
svf <- fileChooserDialogNew (Just "Save game") Nothing FileChooserActionSave
[("Cancel",ResponseCancel),("Save",ResponseOk)]
fileChooserAddFilter svf ff
cid <- statusbarGetContextId sb "status"
widgetShowAll mw
return (GUI mw bd abd std fixp playw playb sb pb mn mo ms mq mun mre mpa mds
msh msm (zip (r:rs) (map snd aiPlayers)) mab opf svf cid)
-- | main GUI entry point
gui :: FilePath -> IO ()
gui path =
do initGUI
gui <- loadGlade path
b <- randomBoardIO
g <- initGameState gui b White -- human plays white by default
gamev <- newMVar g
connect_events gui gamev
-- timer event for updating the gui
timeoutAdd (updateGUI gui gamev >> return True) 100
-- start GTK event loop
mainGUI
-- | connect event handlers for GUI elements
connect_events gui gamev
= do onExpose (canvas gui) $ \x ->
do drawCanvas gui gamev
return (eventSent x)
onButtonPress (canvas gui) $ \x ->
do mp<-getPosition (canvas gui) (eventX x) (eventY x)
case mp of
Nothing -> return (eventSent x)
Just p -> do clickBoard gui gamev p
return (eventSent x)
onDestroy (mainwin gui) mainQuit
onActivateLeaf (menu_item_about gui) $
do { dialogRun (aboutdialog gui)
; widgetHide (aboutdialog gui)
}
onActivateLeaf (menu_item_quit gui) mainQuit
onActivateLeaf (menu_item_new gui) (newGame gui gamev)
onActivateLeaf (menu_item_open gui) $
do { answer<-fileDialogRun (open_file_chooser gui)
; case answer of
Just path -> do openGame gamev path
redrawCanvas (canvas gui)
Nothing -> return ()
}
onActivateLeaf (menu_item_save gui) $
do { answer<-fileDialogRun (save_file_chooser gui)
; case answer of
Just path -> saveGame gamev (replaceExtension path ".tza")
Nothing -> return ()
}
onActivateLeaf (menu_item_undo gui) (undoMove gui gamev)
onActivateLeaf (menu_item_redo gui) (redoMove gui gamev)
onActivateLeaf (menu_item_pass gui) (passMove gui gamev)
onActivateLeaf (menu_item_draw_stacks gui) $ redrawCanvas (canvas gui)
onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui)
onActivateLeaf (menu_item_show_moves gui) $ redrawCanvas (canvas gui)
-- | start a new game
newGame :: GUI -> MVar (Game,State) -> IO ()
newGame gui gamev
= do answer <- dialogRun (startdialog gui)
widgetHide (startdialog gui)
case answer of
ResponseUser 1 -> startgame
_ -> return ()
where startgame = do
r <- toggleButtonGetActive (fixed_position gui)
b <- if r then return startingBoard else randomBoardIO
r <- toggleButtonGetActive (play_white gui)
let c = if r then White else Black
modifyMVar_ gamev (\_ -> initGameState gui b c)
redrawCanvas (canvas gui)
-- | open a saved game
openGame :: MVar (Game,State) -> FilePath -> IO ()
openGame gamev filepath
= withFile filepath ReadMode $ \handle ->
do txt <- hGetContents handle
case readXML txt of
Nothing -> putStrLn ("ERROR: couldn't parse game file " ++ show filepath)
Just g -> modifyMVar_ gamev $ \_ -> return (g,Wait0)
-- | write a game file
saveGame :: MVar (Game,State) -> FilePath -> IO ()
saveGame gamev filepath
= do (g,_) <- readMVar gamev
withFile filepath WriteMode $
\handle -> hPutStr handle (showXML g)
fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath)
fileDialogRun w = do { r<-dialogRun w
; widgetHide w
; case r of
ResponseOk -> fileChooserGetFilename w
_ -> return Nothing
}
-- | get the selected AI player
getAI :: GUI -> IO AI
getAI gui
= do rs<-filterM (checkMenuItemGetActive . fst) (menu_item_ai_players gui)
return $ snd (head (rs ++ error "getAI: no AI selected"))
-- | periodically update the GUI elements when waiting for AI
updateGUI :: GUI -> MVar (Game,State) -> IO ()
updateGUI gui gamev
= modifyMVar_ gamev $ \(g,s) ->
let m = nthMove (move (board g)) -- 1st or 2nd move of turn?
in do { widgetSetSensitive (menu_item_undo gui) $
not (waitingAI s) && not (null (trail g))
; widgetSetSensitive (menu_item_redo gui) $
not (waitingAI s) && not (null (remain g))
; widgetSetSensitive (menu_item_pass gui) $
not (waitingAI s) && m==2
; updateStatus gui (statusText g s)
; case s of
WaitAI mvar ->
do { reply <- tryTakeMVar mvar
; case reply of
Nothing -> do { progressBarPulse (progressbar gui)
; return (g,s) }
Just m -> do { redrawCanvas (canvas gui)
; ai <- getAI gui
; makeMove ai m g }
}
_ -> do { progressBarSetFraction (progressbar gui) 0
; return (g,s) }
}
statusText :: Game -> State -> String
statusText g s
= let b = board g
n = move b
msg = "Turn " ++ show (nthTurn n) ++ ", move " ++ show (nthMove n) ++ ": "
in case s of
Finish -> show (winner b) ++ " wins."
WaitAI _ -> msg ++ show (active b) ++ " thinking..."
_ -> msg ++ show (active b) ++ " to play."
-- | replace the status message
updateStatus :: GUI -> String -> IO ()
updateStatus gui txt
= statusbarPop w id >> statusbarPush w id txt >> return ()
where w = statusbar gui
id = contextid gui
-- | pass the 2nd move of a turn
passMove :: GUI -> MVar (Game,State) -> IO ()
passMove gui gamev
= modifyMVar_ gamev $
\(g,s) ->
if human g == active (board g) then -- human to play?
let moves = nextMoves (board g)
in case s of
Wait0 | Pass`elem`moves ->
do ai <- getAI gui
redrawCanvas (canvas gui)
makeMove ai Pass g
_ -> return (g,s)
else return (g,s)
-- | undo/redo move history navigation
undoMove :: GUI -> MVar (Game,State) -> IO ()
undoMove gui gamev
= modifyMVar_ gamev $ \(g,s) ->
let ms = trail g
in case ms of
[] -> return (g,s)
(m:ms') ->
let b'= foldr applyMoveSkip (initial g) ms'
s'= if endGame b' then Finish else Wait0
in do redrawCanvas (canvas gui)
return (g {board=b', trail=ms', remain=m:remain g},s')
redoMove :: GUI -> MVar (Game,State) -> IO ()
redoMove gui gamev
= modifyMVar_ gamev $ \(g,s) ->
let ms = remain g
in case ms of
[] -> return (g,s)
(m:ms') ->
let b' = applyMoveSkip m (board g)
s' = if endGame b' then Finish else Wait0
in do redrawCanvas (canvas gui)
return (g {board=b', trail=m:trail g, remain=ms'},s')
-- | handle a button click on a board position
clickBoard :: GUI -> MVar (Game,State) -> Position -> IO ()
clickBoard gui gamev p
= do { ai <- getAI gui
; modifyMVar_ gamev $ \(g,s) ->
if active (board g) == human g -- user's turn to play?
then
let moves = nextMoves (board g)
in case s of
Wait0 | p`prefix`moves -> return (g, Wait1 p)
Wait1 p' | p'==p -> return (g, Wait0)
Wait1 p' | (Capture p' p)`elem`moves ->
makeMove ai (Capture p' p) g
Wait1 p' | (Stack p' p)`elem`moves ->
makeMove ai (Stack p' p) g
_ -> return (g,s)
else return (g,s)
; redrawCanvas (canvas gui)
}
-- | check if we can start a move from a position
prefix :: Position -> [Move] -> Bool
prefix p moves
= notNull [p' | Capture p' _<-moves, p'==p] ||
notNull [p' | Stack p' _<-moves, p'==p]
notNull :: [a] -> Bool
notNull = not . null
-- | update game state with a move
-- forks a separate thread for the AI player
makeMove :: AI -> Move -> Game -> IO (Game,State)
makeMove ai m g
| endGame b' = return (g',Finish)
| active b' == human g = return (g',Wait0)
| otherwise =
do { mvar <- newEmptyMVar
; forkOS $ runAI ai b' mvar
; return (g',WaitAI mvar)
}
where b' = applyMoveSkip m (board g)
g' = g {board=b', trail=m:trail g, remain=[]}
-- | separate thread for the AI opponent
runAI :: AI -> Board -> MVar Move -> IO ()
runAI ai b mvar
= do { threadDelay (200*1000) -- short delay to allow GUI redraw
; rnd <- getStdGen
; let (score, m, rnd') = strategy ai (boardTree b) rnd
; setStdGen rnd'
-- ; putStrLn ("AI move: "++show m ++ " score: " ++ show score)
; m `seq` putMVar mvar m
}
---------------------------------------------------------------------------------
-- | drawing methods
---------------------------------------------------------------------------------
redrawCanvas :: DrawingArea -> IO ()
redrawCanvas canvas
= do (w,h)<-widgetGetSize canvas
drawin <- widgetGetDrawWindow canvas
drawWindowInvalidateRect drawin (Rectangle 0 0 w h) False
-- redraw the canvas using double-buffering
drawCanvas :: GUI -> MVar (Game,State) -> IO ()
drawCanvas gui gamev
= do b1 <- checkMenuItemGetActive (menu_item_show_heights gui)
b2 <- checkMenuItemGetActive (menu_item_show_moves gui)
b3 <- checkMenuItemGetActive (menu_item_draw_stacks gui)
(w,h)<-widgetGetSize (canvas gui)
drawin <- widgetGetDrawWindow (canvas gui)
(g,s) <- readMVar gamev
renderWithDrawable drawin $
renderWithSimilarSurface ContentColor w h $
\tmp ->
do renderWith tmp (setTransform w h >> renderBoard b1 b2 b3 g s)
setSourceSurface tmp 0 0
paint
-- | render the board and pieces
renderBoard :: Bool -> Bool -> Bool -> Game -> State -> Render ()
renderBoard showHeights showMoves showStacks g s
= do boardBg >> paint -- paint the background
-- paint the playing area light gray
gray 0.9 >> polyLine [A1, A5, E8, I5, I1, E1] >> closePath >> fill
-- repaint the center with background color
boardBg >> polyLine [D4, D5, E5, F5, F4, E4] >> closePath >> fill
-- draw the grid and coordinates
renderGrid
-- draw the pieces & highlight selection
case s of
Wait0 -> do renderPieces showHeights showStacks b
when showMoves $ mapM_ renderMove previous
Wait1 p -> do highlight p
renderPieces showHeights showStacks b
when showMoves $
do mapM_ renderMove (targets p)
mapM_ renderMove previous
WaitAI _ -> do renderPieces showHeights showStacks b
when showMoves $ mapM_ renderMove previous
Finish -> do renderPieces showHeights showStacks b
when showMoves $ mapM_ renderMove previous
where b = board g
moves = nextMoves b -- next available moves
previous = take 2 (trail g) -- opponent's previous moves
-- move targets from a position
targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++
[m | m@(Stack p1 p2)<-moves, p1==p]
renderMove :: Move -> Render ()
renderMove (Capture p1 p2)
= do { setSourceRGBA 1 0 0 0.7; arrowFromTo p1 p2 }
renderMove (Stack p1 p2)
= do { setSourceRGBA 0 0 1 0.7; arrowFromTo p1 p2 }
renderMove Pass = return ()
renderMove Skip = return ()
arrowFromTo :: Position -> Position -> Render ()
arrowFromTo p1 p2 = do setLineWidth 10
moveTo xstart ystart
lineTo x0 y0
stroke
setLineWidth 1
moveTo xend yend
lineTo x1 y1
lineTo x2 y2
fill
where (xstart,ystart) = screenCoordinate p1
(xend,yend) = screenCoordinate p2
angle = pi + atan2 (yend-ystart) (xend-xstart)
arrow_deg = pi/6
arrow_len = 30
x0 = xend + arrow_len * cos arrow_deg * cos angle
y0 = yend + arrow_len * cos arrow_deg * sin angle
x1 = xend + arrow_len * cos (angle-arrow_deg)
y1 = yend + arrow_len * sin (angle-arrow_deg)
x2 = xend + arrow_len * cos (angle+arrow_deg)
y2 = yend + arrow_len * sin (angle+arrow_deg)
-- draw the hexagonal grid and edge coordinates
renderGrid :: Render ()
renderGrid = do gray 0
setLineWidth 1
sequence_ [lineFromTo p1 p2 | (p1,p2)<-lines]
setFontSize 22
sequence_ [do uncurry moveTo $ tr (-10,60) $ screenCoordinate p
showText (show p)
| p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]]
sequence_ [do uncurry moveTo $ tr (-10,-50) $ screenCoordinate p
showText (show p)
| p<-[A5, B6,C7,D8,E8,F8,G7,H6,I5]]
where tr (dx,dy) (x,y) = (x+dx,y+dy)
lineFromTo p1 p2 = do uncurry moveTo $ screenCoordinate p1
uncurry lineTo $ screenCoordinate p2
stroke
lines = [(A1,A5), (B1,B6), (C1,C7), (D1,D8), (E1,E4),
(E5,E8), (F1,F8), (G1,G7), (H1,H6), (I1,I5),
(A1,E1), (A2,F1),(A3,G1), (A4,H1),
(A5, D5), (F4,I1), (B6,I2), (C7,I3), (D8,I4), (E8,I5),
(E1,I1), (D1,I2), (C1,I3), (B1,I4), (A1,D4), (F5,I5),
(A5,E8), (A4,F8), (A3,G7), (A2,H6)]
-- setup coordinate transform for the board
setTransform :: Int -> Int -> Render ()
setTransform w h
= do translate (fromIntegral w/2) (fromIntegral h/2)
scale (fromIntegral side/1000) (fromIntegral side/1000)
where side = min w h -- constraint to square aspect ratio
-- board background (pale yellow)
boardBg :: Render ()
boardBg = setSourceRGB 1 0.95 0.6
-- shades of gray from 0 (black) to 1 (white)
gray :: Double -> Render ()
gray x = setSourceRGB x x x
-- draw a polygonal line
polyLine :: [Position] -> Render ()
polyLine (p:ps) = do uncurry moveTo $ screenCoordinate p
sequence_ [uncurry lineTo $ screenCoordinate p'|p'<-ps]
-- highlight a position
highlight :: Position -> Render ()
highlight p =
do setSourceRGBA 0.5 0.5 0.5 0.5
setLineWidth 4
newPath
uncurry (disc 1.5) (screenCoordinate p)
-- render all pieces in the board
renderPieces :: Bool -> Bool -> Board -> Render ()
renderPieces showheights showstacks board
= do setLineWidth 2
-- board pieces
sequence_ [ renderStack showheights showstacks x y piece |
(pos,piece) <- assocs, let (x,y)= screenCoordinate pos]
-- sort pieces by reverse position to draw from back to front
where assocs = sortBy cmp $ Map.assocs (pieces board)
cmp (x,_) (y,_) = compare y x
-- captures = capturedPieces board
-- whiteCaptures = [(White,k,n) | (White,k,n)<-captures]
-- blackCaptures = [(Black,k,n) | (Black,k,n)<-captures]
-- whitePos = [ (x,y) | x<-[-500, -450..], let y = -200]
-- blackPos = [ (x,y) | x<-[-500, -450..], let y = 200]
-- | render a stack of pieces
renderStack :: Bool -> Bool -> Double -> Double -> Piece -> Render ()
renderStack showheight showstacks xc yc (c,t,size)
= do stack size' yc
when (showheight && size>1) $ -- show the height?
do selectFontFace "sans-serif" FontSlantNormal FontWeightBold
setFontSize 50
setSourceRGB 1 1 1
showCenteredText (xc+2) (yt+2) label
setSourceRGB 1 0 0
showCenteredText xc yt label
where label = show size
size' = if showstacks then size else 1
-- (xc,yc)= screenCoordinate p
yt = yc - 10*fromIntegral (size'-1)
stack n y
| n>1 = do renderPiece xc y c Tott
stack (n-1) (y-10)
| otherwise = renderPiece xc y c t
-- | render a single piece
renderPiece :: Double -> Double -> Board.Color -> Kind -> Render ()
renderPiece x y c k
= do { chipColor; disc 1 x y;
lineColor; ring 1 x y;
case k of
Tzaar -> do {crownColor; disc 0.8 x y;
chipColor; disc 0.6 x y;
crownColor; disc 0.4 x y}
Tzarra -> do { crownColor; disc 0.4 x y }
Tott -> return ()
}
where (chipColor, lineColor, crownColor) = renderColors c
showCenteredText :: Double -> Double -> String -> Render ()
showCenteredText x y txt
= do exts <- textExtents txt
let dx = textExtentsWidth exts/2
let dy = textExtentsHeight exts/2
moveTo (x-dx) (y+dy)
showText txt
disc :: Double -> Double -> Double -> Render ()
disc r x y = arc x y (r*33) 0 (2*pi) >> fill
ring :: Double -> Double -> Double -> Render ()
ring r x y = arc x y (r*33) 0 (2*pi) >> stroke
-- (chip color, line color, crown color)
renderColors :: Board.Color -> (Render (), Render (), Render ())
renderColors Black = (setSourceRGB 0 0 0,
setSourceRGB 1 1 1,
setSourceRGB 0.75 0.75 0.75)
renderColors White = (setSourceRGB 1 1 1,
setSourceRGB 0 0 0,
setSourceRGB 0.35 0.25 0)
-- | convert a canvas coordinate to a board position
getPosition :: DrawingArea -> Double -> Double -> IO (Maybe Position)
getPosition canvas x y
= do (w,h)<-widgetGetSize canvas
drawin<- widgetGetDrawWindow canvas
(xu, yu)<- renderWithDrawable drawin
(setTransform w h >> deviceToUser x y)
let (p, d) = minimumBy (compare `on` snd)
[(p, (xu - x')^2 + (yu - y')^2)
| (p, (x', y')) <- Map.assocs screenCoordinates ]
return (if d<900 then Just p else Nothing)
-- | screen coordinate of a board position
screenCoordinate :: Position -> (Double,Double)
screenCoordinate p = screenCoordinates!p
screenCoordinates :: Map Position (Double,Double)
screenCoordinates
= Map.fromList $
[ (A1, p (-4) (-2))
, (A2, p (-4) (-1))
, (A3, p (-4) ( 0))
, (A4, p (-4) ( 1))
, (A5, p (-4) ( 2))
, (B1, p (-3) (-3))
, (B2, p (-3) (-2))
, (B3, p (-3) (-1))
, (B4, p (-3) ( 1))
, (B5, p (-3) ( 2))
, (B6, p (-3) ( 3))
, (C1, p (-2) (-3))
, (C2, p (-2) (-2))
, (C3, p (-2) (-1))
, (C4, p (-2) ( 0))
, (C5, p (-2) ( 1))
, (C6, p (-2) ( 2))
, (C7, p (-2) ( 3))
, (D1, p (-1) (-4))
, (D2, p (-1) (-3))
, (D3, p (-1) (-2))
, (D4, p (-1) (-1))
, (D5, p (-1) ( 1))
, (D6, p (-1) ( 2))
, (D7, p (-1) ( 3))
, (D8, p (-1) ( 4))
, (E1, p ( 0) (-4))
, (E2, p ( 0) (-3))
, (E3, p ( 0) (-2))
, (E4, p ( 0) (-1))
, (E5, p ( 0) ( 1))
, (E6, p ( 0) ( 2))
, (E7, p ( 0) ( 3))
, (E8, p ( 0) ( 4))
, (F1, p ( 1) (-4))
, (F2, p ( 1) (-3))
, (F3, p ( 1) (-2))
, (F4, p ( 1) (-1))
, (F5, p ( 1) ( 1))
, (F6, p ( 1) ( 2))
, (F7, p ( 1) ( 3))
, (F8, p ( 1) ( 4))
, (G1, p ( 2) (-3))
, (G2, p ( 2) (-2))
, (G3, p ( 2) (-1))
, (G4, p ( 2) ( 0))
, (G5, p ( 2) ( 1))
, (G6, p ( 2) ( 2))
, (G7, p ( 2) ( 3))
, (H1, p ( 3) (-3))
, (H2, p ( 3) (-2))
, (H3, p ( 3) (-1))
, (H4, p ( 3) ( 1))
, (H5, p ( 3) ( 2))
, (H6, p ( 3) ( 3))
, (I1, p ( 4) (-2))
, (I2, p ( 4) (-1))
, (I3, p ( 4) ( 0))
, (I4, p ( 4) ( 1))
, (I5, p ( 4) ( 2))
]
where
p :: Int -> Int -> (Double, Double)
p x y = (100*x',-100*y')
where
x' = fromIntegral x * sin (pi / 3)
y' | even x = fromIntegral y
| otherwise = fromIntegral y - (fromIntegral (signum y) * 0.5)