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.Map as Map import Data.Map (Map) import Data.List (minimumBy, sortBy) import Data.IORef import Control.Concurrent import Control.Monad (when) import System.Random import Board import AI -- record to hold the game state data State = State { bt :: BoardTree , history :: [State] , future :: [State] , stdGen :: StdGen , ai :: AI , stage :: 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 start) emptyState :: StdGen -> State emptyState rnd = State { bt = boardTree emptyboard, history = [], future = [], stdGen = rnd, ai = undefined, stage = Finish } where emptyboard = (Map.empty, Map.empty) -- initial state (at game start) initState :: Bool -> StdGen -> AI -> State initState randomstart g ai = State { bt = boardTree board , history = [] , future = [] , stdGen = g' , ai = ai , stage = Start0 } where (board, g') | randomstart = randomBoard g | otherwise = (startingBoard, g) -- 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 undoHistory redrawCanvas (canvas gui) onActivateLeaf (menu_item_redo gui) $ do modifyIORef stateRef redoHistory 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 $ initState random (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 undoHistory :: State -> State undoHistory s = case history s of [] -> s (s':ss) -> s' {history=ss, future=r:future s} where r = recState s redoHistory :: State -> State redoHistory s = case future s of [] -> s (s':ss) -> s' {history=r:history s, future=ss} where r = recState s -- "recordable state" projection recState :: State -> State recState s = s { stage = stage' } where stage' = case stage s of Start1 _ -> Start0 Wait1 _ -> Wait0 Wait3 m _ -> Wait2 m _ -> stage s -- 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 [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 stage state of Start0 -> pieces board >>= renderHeights heights Start1 p -> pieces board >>= renderHeights heights >> highlight p Wait0 -> pieces board >>= renderHeights heights Wait1 p -> pieces board >>= renderHeights heights >> highlight p Wait2 m -> pieces (applyMove board m) >>= renderHeights heights Wait3 m p -> pieces (applyMove board m) >>= renderHeights heights >> highlight p Wait4 t -> pieces (applyTurn board t) >>= renderHeights heights Finish -> pieces board >>= renderHeights heights where GameTree (_,board) _ = bt state -- 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) $ boardPosition p showText (show p) | p<-[A1,B1,C1,D1,E1,F1,G1,H1,I1]] sequence_ [do uncurry moveTo $ tr (-10,-50) $ boardPosition 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 $ boardPosition p1 uncurry lineTo $ boardPosition 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 $ boardPosition p sequence_ [uncurry lineTo $ boardPosition p'|p'<-ps] -- highlight a position highlight :: Position -> Render () highlight p = do setSourceRGBA 1 0 0 0.5 setLineWidth 4 newPath uncurry (ring 1.5) $ boardPosition p data PieceColor = White | Black deriving (Eq,Show) -- render all pieces in the board -- returns the original board for futher use pieces :: Board -> Render Board pieces board@(whites,blacks) = 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) (Map.assocs whites) ++ zip (repeat Black) (Map.assocs blacks) cmp (_, (x,_)) (_, (y,_)) = compare y x piece :: (PieceColor,(Position,(Type,Int))) -> Render () piece (c,(p,(t,size))) = stack size yc where (xc,yc)= boardPosition p (chipColor, lineColor, crownColor) = case c of White-> (setSourceRGB 1 1 1, setSourceRGB 0 0 0, setSourceRGB 0.25 0.25 0) Black-> (setSourceRGB 0 0 0, setSourceRGB 1 1 1, setSourceRGB 1 0.8 0) 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-8 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 -- label each position with the stack height -- ignore single piece stacks renderHeights :: Bool -> Board -> Render () renderHeights b (whites,blacks) = when b $ do setSourceRGB 1 0 0 setFontSize 32 mapM_ renderHeight (Map.assocs whites) mapM_ renderHeight (Map.assocs blacks) where renderHeight (p, (_, h)) | h>1 = do moveTo (x-10) y showText (show h) | otherwise = return () where (x,y) = boardPosition p -- 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 boardPositions ] 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 let GameTree _ branches = bt s let turns = fst $ unzip branches case stage s of Start0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> let s'= s { history = s : history s, future = [], stage = Start1 p } in do writeIORef stateRef s' redrawCanvas cv Start1 p0 | p0==p -> do writeIORef stateRef $ s {stage=Start0} redrawCanvas cv Start1 p0 | notNull [m | (m, _)<- turns, m==(p0,p)] -> dispatchTurn gui stateRef s ((p0,p),Nothing) --- Wait0 | notNull [p0 | ((p0, _), _)<-turns, p0==p] -> let s'= s { history = s : history s, future = [], stage=Wait1 p } in do writeIORef stateRef s' redrawCanvas cv Wait1 p0 | p0==p -> do writeIORef stateRef $ s {stage=Wait0} redrawCanvas cv Wait1 p0 | notNull [m | (m, _)<- turns, m==(p0,p)] -> do writeIORef stateRef $ s {stage=Wait2 (p0,p)} redrawCanvas cv Wait2 m | notNull [p0 | (m', Just (p0, _))<-turns, m==m', p0==p] -> let s'=s { history = s : history s, future = [], stage = Wait3 m p } in do writeIORef stateRef s' redrawCanvas cv Wait3 m p0 | p0==p -> do writeIORef stateRef $ s {stage=Wait2 m} redrawCanvas cv Wait3 m p0 | t`elem`turns -> 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 | null branches' -- white wins = let s' = s { stage = Finish, bt = swapBoardTree bt', stdGen = g } in do gui `pushMsg` "White wins" writeIORef stateRef s' redrawCanvas (canvas gui) | otherwise = do { writeIORef stateRef $ s {stage = Wait4 t} ; redrawCanvas (canvas gui) ; gui `pushMsg` "Thinking..." ; forkIO child ; return () } where child = if null branches'' then let s'= s { stage = Finish, bt = bt'', stdGen = g } in do writeIORef stateRef s' redrawCanvas (canvas gui) gui `pushMsg` "Black wins" else let s' = s { stage = Wait0, bt = bt'', stdGen = g } in do writeIORef stateRef s' redrawCanvas (canvas gui) gui `pushMsg` (name (ai s) ++ ": " ++ showTurn t') 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 Turn: " ++ show t' Just a -> a boardPosition :: Position -> (Double,Double) boardPosition p = Map.findWithDefault undefined p boardPositions boardPositions :: Map Position (Double,Double) boardPositions = 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)