hstzaar-0.2: src/GUI.hs
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 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 $ 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
-- 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 [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'= 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, m==(p0,p)] ->
dispatchTurn gui stateRef s ((p0,p),Nothing)
---
Wait0 | notNull [p0 | ((p0, _), _)<-turns, 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, 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'= 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 -> 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' = addHistory $ 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'= addHistory $ 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)