{- 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)