hstzaar-0.7: 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 qualified Data.IntMap as IntMap
import Data.IntMap (IntMap, (!))
import Data.List (minimumBy, sortBy)
import Control.Concurrent
import Control.Monad (when, filterM)
import System.IO
import System.FilePath
import System.Random hiding (next)
import Var (Var)
import qualified Var as Var
import History (History)
import qualified History as History
import Board
import AI
-- | Piece colors
data PieceColor = White | Black
deriving (Eq,Show,Read)
-- | Record to hold the current game state
data Game = Game
{ board :: Board -- current board
, trail :: [Move] -- previous opponent moves
, state :: State -- selection stage
} deriving (Show, Read)
-- | Selection state
data State
= Start0 -- 1st turn
| Start1 Position -- 1st turn (2nd position)
| Wait0 -- Nth turn (1st position)
| Wait1 Position -- Nth turn (2nd position)
| Wait2 -- wait for AI opponent
| Finish -- game ended
deriving (Eq, Show, Read)
-- | reference to a game
type GameRef = Var Game
-- | reference to the history
type HistRef = Var (History Game)
-- | initialize a game, given a starting board
initGame :: Board -> Game
initGame b
= Game { board = b
, trail = []
, state = Start0
}
-- | record to hold the GUI state
data GUI = GUI {
mainwin :: Window,
canvas :: DrawingArea,
statusbar:: Statusbar,
progressbar:: ProgressBar,
menu_item_new :: MenuItem,
menu_item_open :: MenuItem,
menu_item_save :: MenuItem,
-- menu_item_save_as :: 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, AI)],
open_file_chooser :: FileChooserDialog,
save_file_chooser :: FileChooserDialog,
contextid :: ContextId
}
-- | main GUI entry point
gui :: String -> IO ()
gui gladepath =
do initGUI
gui <- loadGlade gladepath
gameRef <- Var.new (initGame startingBoard)
histRef <- Var.new $ History.init (initGame startingBoard)
connect_events gui gameRef histRef
-- timer event for running other threads
timeoutAdd (yield >> return True) 50
-- timer event for updating the progress bar
timeoutAdd (Var.get gameRef >>=
updateProgress gui >>
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 " ++ show gladepath)
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"
mo <- xmlGetWidget xml castToMenuItem "menu_item_open"
ms <- xmlGetWidget xml castToMenuItem "menu_item_save"
-- msa<- xmlGetWidget xml castToMenuItem "menu_item_save_as"
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 $ snd $ head aiPlayers)
menuAttach m r 0 1 0 1
rs <- sequence [do w<-radioMenuItemNewWithLabelFromWidget r (name $ snd t)
menuAttach m w 0 1 i (i+1)
return w
| (t,i)<-zip (tail aiPlayers) [1..]]
-- open/save file dialogs
ff <- fileFilterNew
fileFilterSetName ff "Tzaar saved games (*.tza)"
fileFilterAddPattern ff "*.tza"
opf <- fileChooserDialogNew (Just "Open saved game") Nothing FileChooserActionOpen
[("Cancel",ResponseCancel),("Open",ResponseOk)]
fileChooserAddFilter opf ff
svf <- fileChooserDialogNew (Just "Save game") Nothing FileChooserActionSave
[("Cancel",ResponseCancel),("Save",ResponseOk)]
fileChooserAddFilter svf ff
cid <- statusbarGetContextId sb "status"
-- statusbarPush sb cid "Ready"
widgetShowAll mw
return (GUI mw bd sb pb mn mo ms mq mun mre mpa
msh msm mrs (zip (r:rs) (map snd aiPlayers)) opf svf cid)
-- | connect event handlers for GUI elements
connect_events gui gameRef histRef
= do onExpose (canvas gui) $ \x ->
do drawCanvas gui gameRef
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 gameRef histRef p
return (eventSent x)
onDestroy (mainwin gui) mainQuit
onActivateLeaf (menu_item_quit gui) mainQuit
onActivateLeaf (menu_item_new gui) $ newGame gui gameRef histRef
onActivateLeaf (menu_item_open gui) $
do { answer<-fileDialogRun (open_file_chooser gui)
; case answer of
Just path -> openGame gameRef histRef path
Nothing -> return ()
}
onActivateLeaf (menu_item_save gui) $
do { answer<-fileDialogRun (save_file_chooser gui)
; case answer of
Just path -> saveGame gameRef histRef
(replaceExtension path ".tza")
Nothing -> return ()
}
onActivateLeaf (menu_item_undo gui) $ moveUndo gameRef histRef
onActivateLeaf (menu_item_redo gui) $ moveRedo gameRef histRef
onActivateLeaf (menu_item_pass gui) (movePass gui gameRef histRef)
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
Var.watch gameRef $
\g -> do { h<-Var.get histRef
; updateWidgets gui g h
; redrawCanvas (canvas gui)
}
Var.watch histRef $
\h -> do { g<-Var.get gameRef
; updateWidgets gui g h }
-- | start a new game
newGame :: GUI -> GameRef -> HistRef -> IO ()
newGame gui gameRef histRef
= do r <- checkMenuItemGetActive (menu_item_random_start gui)
b <- if r then randomBoardIO else return startingBoard
Var.set gameRef (initGame b)
Var.set histRef (History.init $ initGame b)
-- | open a saved game
openGame :: GameRef -> HistRef -> FilePath -> IO ()
openGame gameRef histRef filepath
= withFile filepath ReadMode $ \handle ->
do txt <- hGetContents handle
case reads txt of
(((g,h), _): _) -> Var.set gameRef g >>
Var.set histRef h
_ -> putStrLn ("WARNING: couldn't parse file " ++ show filepath)
-- | write a game file
saveGame :: GameRef -> HistRef -> FilePath -> IO ()
saveGame gameRef histRef filepath
= withFile filepath WriteMode $ \handle ->
do g<-Var.get gameRef
h<-Var.get histRef
hPrint handle (g,h)
fileDialogRun :: FileChooserDialog -> IO (Maybe FilePath)
fileDialogRun w = do {dialogRun w ; widgetHide w; fileChooserGetFilename w}
-- | get the selected AI player
getAI :: GUI -> IO AI
getAI gui
= do rs<-filterM (checkMenuItemGetActive . fst) (menu_item_ai_players gui)
return $ snd (head (rs ++ error "getAI: no AI selected"))
-- | update progress bar if we are waiting for AI
updateProgress :: GUI -> Game -> IO ()
updateProgress gui g
= case state g of
Wait2 -> progressBarPulse w
_ -> progressBarSetFraction w 0
where w = progressbar gui
-- | update widgets sensitivity
updateWidgets :: GUI -> Game -> History Game -> IO ()
updateWidgets gui g h
= do { widgetSetSensitive (menu_item_undo gui) $
s/=Wait2 && not (History.atStart h)
; widgetSetSensitive (menu_item_redo gui) $
s/=Wait2 && not (History.atEnd h)
; widgetSetSensitive (menu_item_pass gui) $
s==Wait0 && move b==2
; updateStatus gui msg
}
where b = board g
s = state g
color = if player b then "White" else "Black"
msg = case s of
Finish -> if whiteWins b then "White wins" else "Black wins"
Wait2 -> "Thinking..."
-- 2 moves per turn after the 1st move
_ -> concat [color, " (turn ", show (1+History.position h`div`2),
", move ", show (move b), ")"]
-- | replace the status message
updateStatus :: GUI -> String -> IO ()
updateStatus gui txt
= statusbarPop w id >> statusbarPush w id txt >> return ()
where w = statusbar gui
id = contextid gui
notNull :: [a] -> Bool
notNull = not . null
-- | pass the 2nd move of a turn
movePass :: GUI -> GameRef -> HistRef -> IO ()
movePass gui gameRef histRef
= do g <- Var.get gameRef
let b = board g
case state g of
Wait0 | move b==2 ->
dispatch gui gameRef histRef (makeMove Pass g)
_ -> return ()
moveUndo :: GameRef -> HistRef -> IO ()
moveUndo gameRef histRef
= do h <- Var.get histRef
when (not $ History.atStart h) $
do Var.set histRef (History.previous h)
Var.set gameRef (History.get $ History.previous h)
moveRedo :: GameRef -> HistRef -> IO ()
moveRedo gameRef histRef
= do h <- Var.get histRef
when (not $ History.atEnd h) $
do Var.set histRef (History.next h)
Var.set gameRef (History.get $ History.next h)
-- | handle a button click on a board position
clickPosition :: GUI -> GameRef -> HistRef -> Position -> IO ()
clickPosition gui gameRef histRef p
= do g <- Var.get gameRef
let moves = nextMoves (board g)
case state g of
Start0 | p`startMove`moves ->
Var.set gameRef $ g {state=Start1 p}
Start1 p' | p'==p ->
Var.set gameRef $ g {state=Start0}
Start1 p' | (Capture p' p)`elem`moves ->
dispatch gui gameRef histRef $
makeMove Pass (makeMove (Capture p' p) g)
Wait0 | p`startMove`moves ->
Var.set gameRef $ g {state=Wait1 p, trail=[]}
Wait1 p' | p'==p ->
Var.set gameRef $ g {state=Wait0}
Wait1 p' | (Capture p' p)`elem`moves ->
dispatch gui gameRef histRef $
makeMove (Capture p' p) g
Wait1 p' | (Stack p' p)`elem`moves ->
dispatch gui gameRef histRef $
makeMove (Stack p' p) g
_ -> return ()
-- | check if we can start a move from a position
startMove :: Position -> [Move] -> Bool
startMove p moves
= notNull [p' | Capture p' _<-moves, p'==p] ||
notNull [p' | Stack p' _<-moves, p'==p]
-- | dispatch a move
dispatch :: GUI -> GameRef -> HistRef -> Game -> IO ()
dispatch gui gameRef histRef g
= case state g of
Wait0 -> Var.modify histRef (History.record g') >>
Var.set gameRef g
Finish -> Var.modify histRef (History.record g') >>
Var.set gameRef g
Wait2 -> Var.set gameRef g >>
forkIO runAI >> return ()
_ -> Var.set gameRef g
where
g' = g { trail=[] }
-- run the AI player asynchronously
runAI = do { rnd <- getStdGen
; ai <- getAI gui
; let b = board g
; let ((m1,m2), rnd') = strategy ai (boardTree b) rnd
; setStdGen rnd'
; let g' = makeMove m2 $ makeMove m1 $ g { trail=[] }
-- force evaluation in this thread
; m1 `seq` m2 `seq`
Var.modify histRef (History.record g')
; Var.set gameRef g'
}
makeMove :: Move -> Game -> Game
makeMove m g = Game { board=b', trail=m:trail g, state=state' }
where
b' = applyMove (board g) m
state' | endGame b' = Finish -- game ended
| player b' = Wait0 -- human to play
| otherwise = Wait2 -- opponent to play
---------------------------------------------------------------------------------
-- | drawing methods
---------------------------------------------------------------------------------
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 -> GameRef -> IO ()
drawCanvas gui gameRef
= do b1 <- checkMenuItemGetActive (menu_item_show_heights gui)
b2 <- checkMenuItemGetActive (menu_item_show_moves gui)
(w,h)<-widgetGetSize (canvas gui)
drawin <- widgetGetDrawWindow (canvas gui)
g <- Var.get gameRef
renderWithDrawable drawin $
renderWithSimilarSurface ContentColor w h $
\tmp ->
do renderWith tmp (setTransform w h >> renderBoard b1 b2 g)
setSourceSurface tmp 0 0
paint
-- render the board and pieces
renderBoard :: Bool -> Bool -> Game -> Render ()
renderBoard showheights showmoves g
= 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 state g 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 g)
Wait1 p -> do highlight p
pieces showheights b
when showmoves $ mapM_ renderMove (targets p)
Wait2 -> do pieces showheights b
when showmoves $ mapM_ renderMove (trail g)
Finish -> do pieces showheights b
when showmoves $ mapM_ renderMove (trail g)
where b = board g
moves = nextMoves b
targets p = [m | m@(Capture p1 p2)<-moves, p1==p] ++
[m | m@(Stack p1 p2)<-moves, 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)
-- 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)