hstzaar-0.6: src/GUI.hs
{-
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)