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 Data.IORef import Control.Concurrent import Control.Monad (when) import System.Random import Board import AI import AI.Eval -- | Piece colors data PieceColor = White | Black deriving (Eq,Show) -- | Record to hold the game state data State = State { board :: Board -- current board , turns :: [Turn] -- valid turns , history :: [State] -- undo/redo history , future :: [State] , stdGen :: StdGen -- random number generator , ai :: AI -- ai player , stage :: Stage -- selection stage } data Stage = Start0 -- first turn, single move | Start1 Position | Wait0 -- subsequent turns, two moves | Wait1 Position -- 1st position | Wait2 Move -- 1st move | Wait3 Move Position -- 1st move, 2nd position | Wait4 Turn -- end of turn, waiting for AI | Finish -- game end deriving Eq -- | A reference to mutable state type StateRef = IORef State -- | A state with an empty board (before game starts) emptyState :: StdGen -> State emptyState rnd = State { board = emptyBoard, turns = [], 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 = [] -- first turn must be a single capture , turns = zip (nextCaptureMoves startingBoard) (repeat Nothing) , future = [] , stdGen = rnd , ai = ai , stage = Start0 } -- random board initRandomState :: StdGen -> AI -> State initRandomState rnd ai = State { board = b -- first turn must be a single capture , turns = zip (nextCaptureMoves b) (repeat Nothing) , 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_random_start :: CheckMenuItem, menu_item_ai_players :: [RadioMenuItem], contextid :: ContextId } gui :: String -> IO () gui gladepath = do initGUI gui <- loadGlade gladepath rnd <- getStdGen stateRef <- newIORef (emptyState rnd) connect_events gui stateRef -- timer event for running other threads timeoutAdd (yield >> return True) 50 -- timer event for updating the progress bar & gui widgets timeoutAdd (updateProgress gui stateRef >> return True) 100 timeoutAdd (updateWidgets gui stateRef >> return True) 500 -- 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" 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 ai_players) 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 ai_players) [1..]] cid <- statusbarGetContextId sb "status" widgetShowAll mw return $ GUI mw bd sb pb mn mq mun mre mpa msh 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 selectPosition gui stateRef p return (eventSent x) sequence_ [ onActivateLeaf item (set_ai player) | (player,item) <- zip ai_players (menu_item_ai_players gui) ] onDestroy (mainwin gui) mainQuit onActivateLeaf (menu_item_quit gui) mainQuit onActivateLeaf (menu_item_new gui) $ do newGame gui stateRef redrawCanvas (canvas gui) onActivateLeaf (menu_item_undo gui) $ do modifyIORef stateRef prevHistory redrawCanvas (canvas gui) onActivateLeaf (menu_item_redo gui) $ do modifyIORef stateRef nextHistory redrawCanvas (canvas gui) onActivateLeaf (menu_item_pass gui) (movePass gui stateRef) onActivateLeaf (menu_item_show_heights gui) $ redrawCanvas (canvas gui) where set_ai player = modifyIORef stateRef $ \s->s{ai=player} newGame :: GUI -> StateRef -> IO () newGame gui stateRef = do s <- readIORef stateRef ai <- getAI gui random <- checkMenuItemGetActive (menu_item_random_start gui) writeIORef stateRef $ if random then initRandomState (stdGen s) ai else initState (stdGen s) ai updateWidgets gui stateRef 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 ai_players] -- 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 <- readIORef stateRef case stage s of Wait4 _ -> progressBarPulse (progressbar gui) _ -> progressBarSetFraction (progressbar gui) 0 -- update widgets sensitivity updateWidgets :: GUI -> StateRef -> IO () updateWidgets gui stateRef = do s<-readIORef stateRef -- move undo/redo case stage s of Wait4 _ -> do widgetSetSensitive (menu_item_undo gui) False widgetSetSensitive (menu_item_redo gui) False _ -> do widgetSetSensitive (menu_item_undo gui) (notNull $ history s) widgetSetSensitive (menu_item_redo gui) (notNull $ future s) -- move pass case stage s of Wait2 _ -> widgetSetSensitive (menu_item_pass gui) True _ -> widgetSetSensitive (menu_item_pass gui) False 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 -> Bool recState s = case stage s of Start0 -> True Wait0 -> True Wait2 m -> True Finish -> True _ -> False -- move backwards/foward in history prevHistory :: State -> State prevHistory s = case history s of [] -> s (s':ss) -> s' {history=ss, future=if recState s then s:future s else future s} nextHistory :: State -> State nextHistory s = case future s of [] -> s (s':ss) -> s' {history=if recState s then s:history s else history s, future=ss} -- pass the 2nd move of a turn movePass :: GUI -> StateRef -> IO () movePass gui stateRef = do s <- readIORef stateRef case stage s of Wait2 m -> dispatchTurn gui stateRef s (m,Nothing) _ -> 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 b <- checkMenuItemGetActive (menu_item_show_heights gui) (w,h)<-widgetGetSize (canvas gui) drawin <- widgetGetDrawWindow (canvas gui) state <- readIORef stateRef renderWithDrawable drawin $ renderWithSimilarSurface ContentColor w h $ \tmp -> do renderWith tmp (setTransform w h >> renderBoard b state) setSourceSurface tmp 0 0 paint -- render the board and pieces renderBoard :: Bool -> State -> Render () renderBoard heights 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 b >>= renderHeights heights Start1 p -> highlight p >> pieces b >>= renderHeights heights Wait0 -> pieces b >>= renderHeights heights Wait1 p -> highlight p >> pieces b >>= renderHeights heights Wait2 m -> pieces (applyMove b m) >>= renderHeights heights Wait3 m p -> highlight p >> pieces (applyMove b m) >>= renderHeights heights Wait4 t -> pieces (applyTurn b t) >>= renderHeights heights Finish -> pieces b >>= renderHeights heights where b = board state -- 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 1 0 0 0.5 setLineWidth 4 newPath uncurry (disc 1.5) (screenCoordinate p) -- render all pieces in the board -- returns the original board for futher use pieces :: Board -> Render Board pieces board = do setLineWidth 2 mapM_ piece ps return board -- 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 :: (PieceColor,(Position,Piece))-> Render () piece (c,(p,(t,size))) = stack size yc where (xc,yc)= screenCoordinate p (chipColor, lineColor, crownColor) = pieceColors c stack 0 y = case t of Tott -> return () Tzarra -> crownColor >> disc 0.4 xc y Tzaar -> crownColor >> disc 0.8 xc y >> chipColor >> disc 0.6 xc y >> crownColor >> disc 0.4 xc 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 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) -- label each position with the stack height -- ignore single piece stacks renderHeights :: Bool -> Board -> Render () renderHeights flag board = when flag $ do selectFontFace "monospace" FontSlantNormal FontWeightBold setFontSize 50 setSourceRGB 1 0 0 mapM_ renderHeight (IntMap.assocs (whites board)) mapM_ renderHeight (IntMap.assocs (blacks board)) where renderHeight (p, (_, h)) | h>1 = do moveTo (x-15) (y+12-8*dy) showText txt | otherwise = return () where (x,y) = screenCoordinate p dy = fromIntegral h - 1 txt = show h -- 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 selectPosition :: GUI -> StateRef -> Position -> IO () selectPosition gui stateRef p = do s <- readIORef stateRef -- valid turns from this position case stage s of Start0 | notNull [p0 | ((p0, _), _)<-turns s, p0==p] -> let s'= addHistory s in do writeIORef stateRef $ s' {stage=Start1 p} redrawCanvas cv Start1 p0 | p0==p -> do modifyIORef stateRef prevHistory redrawCanvas cv Start1 p0 | notNull [m | (m, _)<- turns s, m==(p0,p)] -> dispatchTurn gui stateRef s ((p0,p),Nothing) --- Wait0 | notNull [p0 | ((p0, _), _)<-turns s, p0==p] -> let s'= addHistory s in do writeIORef stateRef $ s' {stage=Wait1 p} redrawCanvas cv Wait1 p0 | p0==p -> do modifyIORef stateRef prevHistory redrawCanvas cv Wait1 p0 | notNull [m | (m, _)<- turns s, m==(p0,p)] -> do writeIORef stateRef $ s {stage=Wait2 (p0,p)} redrawCanvas cv Wait2 m | notNull [p0 | (m', Just (p0, _))<-turns s, m==m', p0==p] -> let s'= addHistory s in do writeIORef stateRef $ s' {stage=Wait3 m p} redrawCanvas cv Wait3 m p0 | p0==p -> do modifyIORef stateRef prevHistory redrawCanvas cv Wait3 m p0 | t`elem`turns s -> dispatchTurn gui stateRef s t where t = (m, Just (p0, p)) _ -> return () where cv = canvas gui dispatchTurn :: GUI -> StateRef -> State -> Turn -> IO () dispatchTurn gui stateRef s t | isEndGame bt -- human player wins = let s' = s { stage = Finish, turns = [], board = b } in do gui `pushMsg` "White wins" writeIORef stateRef s' redrawCanvas (canvas gui) | otherwise = do { writeIORef stateRef $ s {stage = Wait4 t, turns = []} ; redrawCanvas (canvas gui) ; gui `pushMsg` "Thinking..." ; forkIO child ; return () } where b = swapBoard (applyTurn (board s) t) -- apply turn and swap active player bt = boardTree b (t', rnd') = strategy (ai s) bt (stdGen s) b' = swapBoard (applyTurn b t') turns' = nextTurns b' child = if null turns' then -- computer wins let s'= s { stage = Finish, board = b', turns = [], stdGen = rnd' } in do writeIORef stateRef s' redrawCanvas (canvas gui) gui `pushMsg` "Black wins" else let s' = s { stage = Wait0, board = b', turns = turns', stdGen = rnd' } in do writeIORef stateRef s' redrawCanvas (canvas gui) gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t') putStrLn ("White value: " ++ show (static_eval $ board s') ++ "\tBlack value: " ++ show (static_eval $ swapBoard $ board s')) {- GameTree _ branches = bt s bt'@(GameTree _ branches') = swapBoardTree $ fromJust $ lookup t branches (t', g) = strategy (ai s) bt' (stdGen s) bt''@(GameTree _ branches'') = swapBoardTree $ case lookup t' branches' of Nothing -> error ("Invalid AI move: " ++ show t') Just a -> a -} -- 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)