{- GTK GUI interface for HsTZAAR board game Pedro Vasconcelos, 2011 -} module GUI (gui) where import Graphics.UI.Gtk hiding (eventSent,on) import Graphics.UI.Gtk.Gdk.Events import Graphics.UI.Gtk.Glade import Graphics.Rendering.Cairo import Data.Function (on) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap, (!)) 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 Var (Var) import qualified Var as Var import History (History) import qualified History as History import Board import AI -- | Piece colors data PieceColor = White | Black deriving (Eq,Show,Read) -- | Record to hold the current game state data Game = Game { board :: Board -- current board , trail :: [Move] -- previous opponent moves , state :: State -- selection stage } deriving (Show, Read) -- | Selection state data State = Start0 -- 1st turn | Start1 Position -- 1st turn (2nd position) | Wait0 -- Nth turn (1st position) | Wait1 Position -- Nth turn (2nd position) | Wait2 -- wait for AI opponent | Finish -- game ended deriving (Eq, Show, Read) -- | pair of current game and history type GameHist = (Game,History Game) -- | reference to a game and history type GameRef = Var GameHist -- | initialize a game, given a starting board initGame :: Board -> Game initGame b = Game { board = b , trail = [] , state = Start0 } -- | record to hold the GUI state data GUI = GUI { mainwin :: Window, canvas :: DrawingArea, 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_show_heights :: CheckMenuItem, menu_item_show_moves :: CheckMenuItem, menu_item_random_start :: CheckMenuItem, menu_item_ai_players :: [(RadioMenuItem, AI)], open_file_chooser :: FileChooserDialog, save_file_chooser :: FileChooserDialog, contextid :: ContextId } -- | main GUI entry point gui :: FilePath -> IO () gui path = do initGUI gui <- loadGlade path let g = initGame startingBoard gameRef <- Var.new (g, History.init g) connect_events gui gameRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar timeoutAdd (Var.get gameRef >>= \(g,_) -> updateProgress gui g >> return True) 100 -- start event loop mainGUI -- | 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" 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" msh<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_heights" msm<- xmlGetWidget xml castToCheckMenuItem "menu_item_show_moves" mrs<- xmlGetWidget xml castToCheckMenuItem "menu_item_random_start" -- fill in dynamic parts 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 <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t) menuAttach m w 0 1 i (i+1) return w | (t,i)<-zip (tail aiPlayers) [1..]] -- 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 sb pb mn mo ms mq mun mre mpa msh msm mrs (zip (r:rs) (map snd aiPlayers)) opf svf cid) -- | connect event handlers for GUI elements connect_events gui gameRef = do onExpose (canvas gui) $ \x -> do drawCanvas gui gameRef 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 clickPosition gui gameRef p return (eventSent x) onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit onActivateLeaf (menu_item_new gui) $ newGame gui gameRef onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of Just path -> openGame gameRef path Nothing -> return () } onActivateLeaf (menu_item_save gui) $ do { answer<-fileDialogRun (save_file_chooser gui) ; case answer of Just path -> saveGame gameRef (replaceExtension path ".tza") Nothing -> return () } onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef onActivateLeaf (menu_item_pass gui) (movePass gui gameRef) onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui) onActivateLeaf (menu_item_show_moves gui) $ redrawCanvas (canvas gui) -- set callback to update the widgets and redraw the canvas Var.watch gameRef $ \gh -> do { updateWidgets gui gh ; redrawCanvas (canvas gui) } -- | start a new game newGame :: GUI -> GameRef -> IO () newGame gui gameRef = do r <- checkMenuItemGetActive (menu_item_random_start gui) b <- if r then randomBoardIO else return startingBoard Var.set gameRef (initGame b, History.init $ initGame b) -- | open a saved game openGame :: GameRef -> FilePath -> IO () openGame gameRef filepath = withFile filepath ReadMode $ \handle -> do txt <- hGetContents handle case reads txt of ((gh,_): _) -> Var.set gameRef gh _ -> putStrLn ("WARNING: couldn't parse game file " ++ show filepath) -- | write a game file saveGame :: GameRef -> FilePath -> IO () saveGame gameRef filepath = withFile filepath WriteMode $ \handle -> Var.get gameRef >>= hPrint handle 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")) -- | update progress bar if we are waiting for AI updateProgress :: GUI -> Game -> IO () updateProgress gui g = case state g of Wait2 -> progressBarPulse w _ -> progressBarSetFraction w 0 where w = progressbar gui -- | update widgets sensitivity updateWidgets :: GUI -> GameHist -> IO () updateWidgets gui (g,h) = do { widgetSetSensitive (menu_item_undo gui) $ s/=Wait2 && not (History.atStart h) ; widgetSetSensitive (menu_item_redo gui) $ s/=Wait2 && not (History.atEnd h) ; widgetSetSensitive (menu_item_pass gui) $ s==Wait0 && move b==2 ; updateStatus gui msg } where b = board g s = state g color = if player b then "White" else "Black" msg = case s of Finish -> if whiteWins b then "White wins" else "Black wins" Wait2 -> "Thinking..." -- 2 moves per turn after the 1st move _ -> concat [color, " (turn ", show (1+History.position h`div`2), ", move ", show (move b), ")"] -- | 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 notNull :: [a] -> Bool notNull = not . null -- | pass the 2nd move of a turn movePass :: GUI -> GameRef -> IO () movePass gui gameRef = do (g,h) <- Var.get gameRef let b = board g case state g of Wait0 | move b==2 -> dispatch gui gameRef (makeMove Pass g) h _ -> return () moveUndo :: GameRef -> IO () moveUndo gameRef = do (_,h) <- Var.get gameRef when (not $ History.atStart h) $ let h' = History.previous h in Var.set gameRef (History.get h', h') moveRedo :: GameRef -> IO () moveRedo gameRef = do (_,h) <- Var.get gameRef when (not $ History.atEnd h) $ let h' = History.next h in Var.set gameRef (History.get h', h') -- | handle a button click on a board position clickPosition :: GUI -> GameRef -> Position -> IO () clickPosition gui gameRef p = do (g,h) <- Var.get gameRef let moves = nextMoves (board g) case state g of Start0 | p`startMove`moves -> Var.set gameRef (g {state=Start1 p}, h) Start1 p' | p'==p -> Var.set gameRef (g {state=Start0}, h) Start1 p' | (Capture p' p)`elem`moves -> dispatch gui gameRef (makeMove Pass $ makeMove (Capture p' p) g) h Wait0 | p`startMove`moves -> Var.set gameRef (g {state=Wait1 p, trail=[]}, h) Wait1 p' | p'==p -> Var.set gameRef (g {state=Wait0}, h) Wait1 p' | (Capture p' p)`elem`moves -> dispatch gui gameRef (makeMove (Capture p' p) g) h Wait1 p' | (Stack p' p)`elem`moves -> dispatch gui gameRef (makeMove (Stack p' p) g) h _ -> return () -- | check if we can start a move from a position startMove :: Position -> [Move] -> Bool startMove p moves = notNull [p' | Capture p' _<-moves, p'==p] || notNull [p' | Stack p' _<-moves, p'==p] -- | dispatch a move dispatch :: GUI -> GameRef -> Game -> History Game -> IO () dispatch gui gameRef g h = case state g of Wait0 -> Var.set gameRef (g, History.record g' h) Finish -> Var.set gameRef (g, History.record g' h) Wait2 -> Var.set gameRef (g,h) >> forkIO runAI >> return () _ -> Var.set gameRef (g,h) where g' = g { trail=[] } -- run the AI player asynchronously runAI = do { rnd <- getStdGen ; ai <- getAI gui ; let b = board g ; let ((m1,m2), rnd') = strategy ai (boardTree b) rnd ; setStdGen rnd' ; let g' = makeMove m2 $ makeMove m1 $ g { trail=[] } -- force evaluation in this thread ; m1 `seq` m2 `seq` Var.set gameRef (g', History.record g' h) } makeMove :: Move -> Game -> Game makeMove m g = Game { board=b', trail=m:trail g, state=state' } where b' = applyMove (board g) m state' | endGame b' = Finish -- game ended | player b' = Wait0 -- human to play | otherwise = Wait2 -- opponent to play --------------------------------------------------------------------------------- -- | 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 -> GameRef -> IO () drawCanvas gui gameRef = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) b2 <- checkMenuItemGetActive (menu_item_show_moves gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui) (g,_) <- Var.get gameRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> do renderWith tmp (setTransform w h >> renderBoard b1 b2 g) setSourceSurface tmp 0 0 paint -- render the board and pieces renderBoard :: Bool -> Bool -> Game -> Render () renderBoard showheights showmoves g = do -- paint the background boardBg >> paint -- paint the playing area light gray gray 0.9 >> polyLine (map fromAPos [A1, A5, E8, I5, I1, E1]) >> closePath >> fill -- repaint the center with background color boardBg >> polyLine (map fromAPos [D4, D5, E5, F5, F4, E4]) >> closePath >> fill -- draw the grid and coordinates renderGrid -- draw the pieces & highlight selection case state g of Start0 -> pieces showheights b Start1 p -> do highlight p pieces showheights b when showmoves $ mapM_ renderMove (targets p) Wait0 -> do pieces showheights b when showmoves $ mapM_ renderMove (trail g) Wait1 p -> do highlight p pieces showheights b when showmoves $ mapM_ renderMove (targets p) Wait2 -> do pieces showheights b when showmoves $ mapM_ renderMove (trail g) Finish -> do pieces showheights b when showmoves $ mapM_ renderMove (trail g) where b = board g moves = nextMoves b 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 () 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/4 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 (fromAPos p1) (fromAPos p2) | (p1,p2)<-lines] setFontSize 22 sequence_ [do uncurry moveTo $ tr (-10,60) $ screenCoordinate p showText (show $ toAPos p) | p<-map fromAPos [A1,B1,C1,D1,E1,F1,G1,H1,I1]] sequence_ [do uncurry moveTo $ tr (-10,-50) $ screenCoordinate p showText (show $ toAPos p) | p<-map fromAPos [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 pieces :: Bool -> Board -> Render () pieces showheights board = do setLineWidth 2 mapM_ (piece showheights) ps -- sort pieces by reverse position to draw from back to front where ps = sortBy cmp $ zip (repeat White) (IntMap.assocs (whites board)) ++ zip (repeat Black) (IntMap.assocs (blacks board)) cmp (_,(x,_)) (_,(y,_)) = compare y x piece :: Bool -> (PieceColor,(Position,Piece))-> Render () piece showheight (c,(p,(t,size))) = do y<-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) (y+2) label setSourceRGB 1 0 0 showCenteredText xc y label where label = show size (xc,yc)= screenCoordinate p (chipColor, lineColor, crownColor) = pieceColors c stack 0 y = case t of Tott -> return y Tzarra -> crownColor >> disc 0.4 xc y >> return y Tzaar -> crownColor >> disc 0.8 xc y >> chipColor >> disc 0.6 xc y >> crownColor >> disc 0.4 xc y >> return y stack n y | n>0 = do chipColor >> disc 1 xc y lineColor >> ring 1 xc y stack (n-1) $ if n>1 then y-10 else y 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) pieceColors :: PieceColor -> (Render (), Render (), Render ()) pieceColors White = (setSourceRGB 1 1 1, setSourceRGB 0 0 0, setSourceRGB 0.35 0.25 0) pieceColors Black = (setSourceRGB 0 0 0, setSourceRGB 1 1 1, setSourceRGB 0.75 0.75 0.75) -- 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')) <- IntMap.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 :: IntMap (Double,Double) screenCoordinates = IntMap.fromList $ map (\(p,q) -> (fromAPos p, q)) [ (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)