{- 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) 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) -- | reference to a game type GameRef = Var Game -- | reference to the history type HistRef = Var (History Game) -- | 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 :: String -> IO () gui gladepath = do initGUI gui <- loadGlade gladepath gameRef <- Var.new (initGame startingBoard) histRef <- Var.new $ History.init (initGame startingBoard) connect_events gui gameRef histRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar timeoutAdd (Var.get gameRef >>= updateProgress gui >> return True) 100 -- start event loop mainGUI -- | load GUI elements from XML glade file loadGlade gladepath = do out <- xmlNew gladepath when (out==Nothing) (error $ "failed to load glade file " ++ show gladepath) let Just xml = out 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" -- msa<- xmlGetWidget xml castToMenuItem "menu_item_save_as" 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" -- statusbarPush sb cid "Ready" 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 histRef = 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 histRef p return (eventSent x) onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit onActivateLeaf (menu_item_new gui) $ newGame gui gameRef histRef onActivateLeaf (menu_item_open gui) $ do { answer<-fileDialogRun (open_file_chooser gui) ; case answer of Just path -> openGame gameRef histRef path Nothing -> return () } onActivateLeaf (menu_item_save gui) $ do { answer<-fileDialogRun (save_file_chooser gui) ; case answer of Just path -> saveGame gameRef histRef (replaceExtension path ".tza") Nothing -> return () } onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef histRef onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef histRef onActivateLeaf (menu_item_pass gui) (movePass gui gameRef histRef) 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 $ \g -> do { h<-Var.get histRef ; updateWidgets gui g h ; redrawCanvas (canvas gui) } Var.watch histRef $ \h -> do { g<-Var.get gameRef ; updateWidgets gui g h } -- | start a new game newGame :: GUI -> GameRef -> HistRef -> IO () newGame gui gameRef histRef = do r <- checkMenuItemGetActive (menu_item_random_start gui) b <- if r then randomBoardIO else return startingBoard Var.set gameRef (initGame b) Var.set histRef (History.init $ initGame b) -- | open a saved game openGame :: GameRef -> HistRef -> FilePath -> IO () openGame gameRef histRef filepath = withFile filepath ReadMode $ \handle -> do txt <- hGetContents handle case reads txt of (((g,h), _): _) -> Var.set gameRef g >> Var.set histRef h _ -> putStrLn ("WARNING: couldn't parse file " ++ show filepath) -- | write a game file saveGame :: GameRef -> HistRef -> FilePath -> IO () saveGame gameRef histRef filepath = withFile filepath WriteMode $ \handle -> do g<-Var.get gameRef h<-Var.get histRef hPrint handle (g,h) fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath) fileDialogRun w = do {dialogRun w ; widgetHide w; fileChooserGetFilename w} -- | 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 -> Game -> History Game -> 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 -> HistRef -> IO () movePass gui gameRef histRef = do g <- Var.get gameRef let b = board g case state g of Wait0 | move b==2 -> dispatch gui gameRef histRef (makeMove Pass g) _ -> return () moveUndo :: GameRef -> HistRef -> IO () moveUndo gameRef histRef = do h <- Var.get histRef when (not $ History.atStart h) $ do Var.set histRef (History.previous h) Var.set gameRef (History.get $ History.previous h) moveRedo :: GameRef -> HistRef -> IO () moveRedo gameRef histRef = do h <- Var.get histRef when (not $ History.atEnd h) $ do Var.set histRef (History.next h) Var.set gameRef (History.get $ History.next h) -- | handle a button click on a board position clickPosition :: GUI -> GameRef -> HistRef -> Position -> IO () clickPosition gui gameRef histRef p = do g <- Var.get gameRef let moves = nextMoves (board g) case state g of Start0 | p`startMove`moves -> Var.set gameRef $ g {state=Start1 p} Start1 p' | p'==p -> Var.set gameRef $ g {state=Start0} Start1 p' | (Capture p' p)`elem`moves -> dispatch gui gameRef histRef $ makeMove Pass (makeMove (Capture p' p) g) Wait0 | p`startMove`moves -> Var.set gameRef $ g {state=Wait1 p, trail=[]} Wait1 p' | p'==p -> Var.set gameRef $ g {state=Wait0} Wait1 p' | (Capture p' p)`elem`moves -> dispatch gui gameRef histRef $ makeMove (Capture p' p) g Wait1 p' | (Stack p' p)`elem`moves -> dispatch gui gameRef histRef $ makeMove (Stack p' p) g _ -> 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 -> HistRef -> Game -> IO () dispatch gui gameRef histRef g = case state g of Wait0 -> Var.modify histRef (History.record g') >> Var.set gameRef g Finish -> Var.modify histRef (History.record g') >> Var.set gameRef g Wait2 -> Var.set gameRef g >> forkIO runAI >> return () _ -> Var.set gameRef g 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.modify histRef (History.record g') ; Var.set gameRef g' } 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)