{- 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 Data.Maybe (fromJust) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap, (!)) import Data.List (minimumBy, sortBy) import Control.Concurrent import Control.Monad (when) import System.Random import StateVar (StateVar) import qualified StateVar as StateVar import Board import AI -- | Piece colors data PieceColor = White | Black deriving (Eq,Show) -- | Record to hold the game state data State = State { board :: Board -- current board , moves :: [Move] -- available moves , trail :: [Move] -- trail from previous turn , history :: [State] -- undo/redo history , future :: [State] , stdGen :: !StdGen -- random number generator , ai :: AI -- ai player , stage :: Stage -- selection stage } data Stage = Start0 -- wait for 1st turn | Start1 Position -- wait for 1st turn (2nd position) | Wait0 -- wait for move (1st position) | Wait1 Position -- wait for move (2nd position) | Wait2 -- end of turn, waiting for AI | Finish -- game end deriving Eq -- | A reference to mutable state type StateRef = StateVar State -- | A state with an empty board (before game starts) emptyState :: StdGen -> State emptyState rnd = State { board = emptyBoard, moves = [], trail = [], history = [], future = [], stdGen = rnd, ai = undefined, stage = Finish } -- | Initial game state state -- | standard non-random board initState :: StdGen -> AI -> State initState rnd ai = State { board = startingBoard , history = [] , moves = nextMoves startingBoard , trail = [] , future = [] , stdGen = rnd , ai = ai , stage = Start0 } -- random board initRandomState :: StdGen -> AI -> State initRandomState rnd ai = State { board = b , moves = nextMoves b , trail = [] , history = [] , future = [] , stdGen = rnd' , ai = ai , stage = Start0 } where (b, rnd') = randomBoard rnd -- a record to hold GUI elements data GUI = GUI { mainwin :: Window, canvas :: DrawingArea, statusbar:: Statusbar, progressbar:: ProgressBar, menu_item_new :: 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], contextid :: ContextId } gui :: String -> IO () gui gladepath = do initGUI gui <- loadGlade gladepath rnd <- getStdGen stateRef <- StateVar.new (emptyState rnd) connect_events gui stateRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar timeoutAdd (updateProgress gui stateRef >> 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") 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" 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 $ head aiPlayers) menuAttach m r 0 1 0 1 rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name t) menuAttach m w 0 1 i (i+1) return w | (t,i)<-zip (tail aiPlayers) [1..]] cid <- statusbarGetContextId sb "status" widgetShowAll mw return $ GUI mw bd sb pb mn mq mun mre mpa msh msm mrs (r:rs) cid connect_events gui stateRef = do onExpose (canvas gui) $ \x -> do drawCanvas gui stateRef 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 stateRef p return (eventSent x) sequence_ [ onActivateLeaf item (set_ai player) | (player,item) <- zip aiPlayers (menu_item_ai_players gui) ] onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit onActivateLeaf (menu_item_new gui) $ newGame gui stateRef onActivateLeaf (menu_item_undo gui) $ StateVar.modify stateRef prevHistory onActivateLeaf (menu_item_redo gui) $ StateVar.modify stateRef nextHistory onActivateLeaf (menu_item_pass gui) (movePass gui stateRef) 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 StateVar.watch stateRef $ \s -> do {updateWidgets gui s; redrawCanvas (canvas gui)} where set_ai player = StateVar.modify stateRef $ \s->s{ai=player} newGame :: GUI -> StateRef -> IO () newGame gui stateRef = do s <- StateVar.get stateRef ai <- getAI gui random <- checkMenuItemGetActive (menu_item_random_start gui) StateVar.set stateRef $ if random then initRandomState (stdGen s) ai else initState (stdGen s) ai gui `pushMsg` "Ready" -- get the selected AI player getAI :: GUI -> IO AI getAI gui = do bs <- sequence [checkMenuItemGetActive item | item<-menu_item_ai_players gui] return $ head [ai | (True,ai)<-zip bs aiPlayers] -- methods to update the status bar pushMsg :: GUI -> String -> IO () pushMsg gui txt = statusbarPush (statusbar gui) (contextid gui) txt >> return () popMsg :: GUI -> IO () popMsg gui = statusbarPop (statusbar gui) (contextid gui) >> return () -- update progress bar if we are waiting for AI updateProgress :: GUI -> StateRef -> IO () updateProgress gui stateRef = do s <- StateVar.get stateRef case stage s of Wait2 -> progressBarPulse (progressbar gui) _ -> progressBarSetFraction (progressbar gui) 0 -- update widgets sensitivity updateWidgets :: GUI -> State -> IO () updateWidgets gui s = do { widgetSetSensitive (menu_item_undo gui) (stage s/=Wait2 && notNull (history s)) ; widgetSetSensitive (menu_item_redo gui) (stage s/=Wait2 && notNull (future s)) ; widgetSetSensitive (menu_item_pass gui) (stage s==Wait0 && move (board s)==2) } notNull :: [a] -> Bool notNull = not . null -- handle undo and redo buttons -- add to history addHistory :: State -> State addHistory s = s { history = s:history s, future = [] } -- should we record this state ? recState :: State -> [State] -> [State] recState s ss = case stage s of Start0 -> s:ss Wait0 -> s:ss Wait1 _ -> s:ss Finish -> s:ss _ -> ss -- move backwards/foward in history prevHistory :: State -> State prevHistory s = case history s of [] -> s (s':ss) -> s' {history = ss, future = recState s (future s), trail=[]} nextHistory :: State -> State nextHistory s = case future s of [] -> s (s':ss) -> s' {history = recState s (history s), future = ss, trail=[]} -- pass the 2nd move of a turn movePass :: GUI -> StateRef -> IO () movePass gui stateRef = do s <- StateVar.get stateRef let b = board s case stage s of Wait0 | move b==2 -> dispatch gui stateRef (applyMove b Pass) _ -> return () 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 -> StateRef -> IO () drawCanvas gui stateRef = do b1 <- checkMenuItemGetActive (menu_item_show_heights gui) b2 <- checkMenuItemGetActive (menu_item_show_moves gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui) s <- StateVar.get stateRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> do renderWith tmp (setTransform w h >> renderBoard b1 b2 s) setSourceSurface tmp 0 0 paint -- render the board and pieces renderBoard :: Bool -> Bool -> State -> Render () renderBoard showheights showmoves state = 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 stage state 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 state) Wait1 p -> do highlight p pieces showheights b when showmoves $ mapM_ renderMove (targets p) Wait2 -> do pieces showheights b when showmoves $ mapM_ renderMove (trail state) Finish -> do pieces showheights b when showmoves $ mapM_ renderMove (trail state) where b = board state targets p = [m | m@(Capture p1 p2)<-moves state, p1==p] ++ [m | m@(Stack p1 p2)<-moves state, 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) -- dispatch a button click on a board position -- check move is valid from this position clickPosition :: GUI -> StateRef -> Position -> IO () clickPosition gui stateRef p = do s <- StateVar.get stateRef case stage s of Start0 | notNull [p0 | (Capture p0 _)<-moves s, p0==p] -> let s'= addHistory s in StateVar.set stateRef $ s' {stage=Start1 p} Start1 p0 | p0==p -> StateVar.modify stateRef prevHistory Start1 p0 | Capture p0 p `elem` moves s -> do StateVar.modify stateRef $ \s -> s{trail=Capture p0 p:trail s} dispatch gui stateRef (applyTurn (board s) (Capture p0 p,Pass)) Wait0 | notNull [p0 | Capture p0 _<-moves s, p0==p] || notNull [p0 | Stack p0 _<-moves s, p0==p] -> let s'= addHistory s in StateVar.set stateRef $ s' {stage=Wait1 p, trail=[]} Wait1 p0 | p0==p -> StateVar.modify stateRef prevHistory Wait1 p0 | Capture p0 p`elem`moves s -> do StateVar.modify stateRef $ \s -> s {trail = Capture p0 p : trail s} dispatch gui stateRef (applyMove (board s) (Capture p0 p)) Wait1 p0 | Stack p0 p`elem`moves s -> do StateVar.modify stateRef $ \s -> s {trail = Stack p0 p : trail s} dispatch gui stateRef (applyMove (board s) (Stack p0 p)) _ -> return () dispatch :: GUI -> StateRef -> Board -> IO () dispatch gui stateRef b | endGame b = do { gui `pushMsg` (if player b then "Black wins" else "White wins") ; StateVar.modify stateRef $ \s -> s {stage=Finish, board=b, moves=[]} } | player b -- White to move = StateVar.modify stateRef $ \s -> s {stage=Wait0, board=b, moves=nextMoves b} | otherwise -- Black to move = do { gui `pushMsg` "Thinking..." ; StateVar.modify stateRef $ \s -> s{stage=Wait2, moves=[], board=b} ; forkIO async ; return () } where -- asynchronous action for the AI player async = do { s <- StateVar.get stateRef ; let b = board s ; let bt = boardTree b ; let (t@(m1,m2), rnd') = strategy (ai s) bt (stdGen s) ; gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t) ; StateVar.modify stateRef $ \s -> s { stdGen = rnd' , trail = [m1,m2] } ; dispatch gui stateRef (applyTurn b t) } -- 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)