hstzaar-0.5: 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.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)