{-
GUI for the Babylon game
Uses wxHaskell bindings to the wxWidgets toolkit
Pedro Vasconcelos, 2009-2010
-}
module GUI where
import Graphics.UI.WX hiding (play)
import Graphics.UI.WXCore
import Data.Maybe
import System.Random
import Utils (shuffleIO)
import Babylon
import Paths_babylon -- Cabal locations of image files
data Player = Human | Computer deriving (Eq,Show)
-- list of gamplay levels
-- "hardest" plays optimally (always wins as 2nd player)
levels :: [(String,Int)]
levels = [("Easy",2), ("Medium",4), ("Hard",8), ("Hardest",12)]
defaultLevel :: Int
defaultLevel = 2
data Game = Game { gameWindow :: Panel ()
, gameBitmaps :: [Bitmap ()]
, gameBoard :: Var Board
, gamePlayer :: Var (Maybe Player)
, gameLevel :: Var Int
, gameSel :: Var Int
, drawnRects :: Var [Rect]
}
instance Widget Game where
widget g = widget (gameWindow g)
instance Visible Game where
refresh g = do set w [layout := space 720 200]
refresh w
where w = gameWindow g
instance Paint Game where
repaint g = repaint (gameWindow g)
paint = error "paint not defined for Game instance"
paintRaw = error "paintRaw not defined for Game instance"
instance Selection Game where
selection = newAttr "selection" getter setter
where getter g = varGet (gameSel g)
setter g n = do varSet (gameSel g) n
repaint g
board :: Attr Game Board
board = newAttr "board" getter setter
where getter = varGet . gameBoard
setter g b = do varSet (gameBoard g) b
varSet (gameSel g) (-1)
repaint g
player :: Attr Game (Maybe Player)
player = newAttr "player" getter setter
where getter = varGet . gamePlayer
setter = varSet . gamePlayer
level :: Attr Game Int
level = newAttr "level" getter setter
where getter = varGet . gameLevel
setter = varSet . gameLevel
newGame :: Frame a -> StatusField -> IO Game
newGame f sf
= do bmps <- loadBitmaps
w <- panel f []
b <- shuffleIO initialBoard
vb <- varCreate b
vrects <- varCreate []
vplayer <- varCreate (Just Human)
vlevel <- varCreate defaultLevel
vsel<- varCreate (-1)
let g = Game { gameWindow=w
, gameBoard=vb
, gameBitmaps=bmps
, gamePlayer=vplayer
, gameLevel=vlevel
, gameSel=vsel
, drawnRects=vrects
}
set w [on resize := repaint w,
on paint := drawBoard g,
on click := humanPlay g sf]
refresh g
repaint w
return g
-- start the GUI
gui :: IO ()
gui = do f <- frame [text := "Babylon"]
status <- statusField [text := "Welcome to Babylon"]
game <- newGame f status
menu<-menuPane [text := "&Game"]
new<-menuItem menu [text := "New",
help := "Restart the game"
]
menuLine menu
menuQuit menu [help := "Quit this program",
on command := close f]
opt <- menuPane [text := "Options"]
r0<-menuItem opt [text := "Human plays first",
help := "Choose starting player",
checkable:=True, checked := True]
menuLine opt
-- radio buttons for chosing play level
rs<-sequence [menuRadioItem opt
[text := txt,
help := "Choose computer opponent level",
on command := set game [level:=l]]
| (txt,l)<-levels]
sequence_ [set r [checked:=True]
| (r,l)<-zip rs (map snd levels), l==defaultLevel]
hlp <- menuHelp []
rules<- menuItem hlp [text := "Rules",
help := "About the game rules",
on command := infoRules f]
about <- menuAbout hlp [help := "About this program",
on command := infoAbout f]
-- timer event to periodically play the computer AI
t <- timer f [interval := 2000,
on command := computerPlay game status]
set f [statusBar := [status],
menuBar := [menu, opt, hlp],
layout := alignCenter (widget game)
]
-- menu handler for restarting a game
set new [on command := do b <- shuffleIO initialBoard
c <- get r0 checked
let p = if c then Human else Computer
set game [board := b, player := Just p]
updateStatus status game
]
-- display an info dialog
infoAbout w
= infoDialog w "About Babylon" $
init $
unlines ["Written in Haskell using the wxWidgets toolkit",
"by Pedro Vasconcelos <pbv@dcc.fc.up.pt>",
"",
"Based on the board game by Bruno Faidutti",
"Published by FoxMind Games."
]
-- display the game rules
infoRules w
= infoDialog w "Rules of Babylon" $
init $
unlines ["Two players take turns moving stacks of colored tiles.",
"A move is valid provided that:",
"1) the stacks have same height; or",
"2) the stacks have the same top color.",
"The first player who cannot make a move loses the game!"]
-- load bitmaps for the colored tiles
-- uses Cabal to get portable file paths
loadBitmaps :: IO [Bitmap ()]
loadBitmaps
= sequence [do { f<-getDataFileName ("images/" ++ show c ++ ".png")
; bitmapCreateLoad f wxBITMAP_TYPE_PNG }
| c<-colors]
{-
-- delete the bitmaps
delBitmaps :: [Bitmap ()] -> IO ()
delBitmaps bmps = sequence_ [bitmapDelete b | b<-bmps]
-}
-- update the status field
-- shows current player and checks for no available moves, i.e. game end
updateStatus sf g
= do mp <- get g player
case mp of
Nothing -> return ()
Just p -> do b <- get g board
let moves = valid b
case moves of
[] -> do set sf [text := show p ++ " loses (no moves available)"]
set g [player := Nothing]
_ -> set sf [text := show p ++ " to play"]
-- redraw the game board
drawBoard g dc (Rect x y w h)
= do b <- varGet (gameBoard g)
rs<- drawStacks (gameBitmaps g) b dc x' y'
varSet (drawnRects g) rs
-- highlight the selection if active
i <- varGet (gameSel g)
when (i>=0) $ drawRect dc (rs!!i) [pen:=penColored red 2,
brush:=brushTransparent]
where x'= x + 10
y' = y + h`div`2
-- draw a list of tile stacks
-- returns the list of bounding boxes (rectangles)
drawStacks bmps [] dc x y
= return []
drawStacks bmps (s:ss) dc x y
= do r<-drawStack bmps s dc x y
rs<-drawStacks bmps ss dc (x+rectWidth r+dx) y
return (r:rs)
where dx = 8
-- draw a single stack of tiles
drawStack bmps tiles dc x y
= do rs<-sequence [ do { drawBitmap dc b (pt x' y') False []
; sz <- bitmapGetSize b
; return (rect (pt x' y') sz)
}
| (c,x',y')<-zip3 (reverse tiles)
[x,x+dx..] [y,y+dy..],
let b = bmps!!fromEnum c
]
return (rectUnions rs)
where n = length tiles
dx = 4
dy = -8
-- handle a mouse click and perform a human player move
humanPlay g sf pt
= do mp <- get g player
when (mp==Just Human) $
do b <- get g board
i <- get g selection
rs <- varGet (drawnRects g)
let j = rectIndex rs pt
if i>=0 && j>=0 && (i,j)`elem`valid b then
do set g [board := play b (i,j),
player := Just Computer,
selection := (-1)]
updateStatus sf g
else if i==j then
set g [selection := (-1)]
else
set g [selection := j]
repaint g
-- convert a screen position into an index or -1
rectIndex rs pt
= head ([i | (i,r)<-zip [0..] rs, rectContains r pt] ++ [-1])
{-
humanPlay vplayer vgame vsel updt Nothing
= return ()
humanPlay vplayer vgame vsel updt (Just j)
= do player <- varGet vplayer
game <- varGet vgame
sel <- varGet vsel
case (player,sel) of
(Human, Nothing) -> do {varSet vsel (Just j); updt}
(Human, Just i) -> do varSet vsel Nothing
when ((i,j) `elem` valid game) $
do varSet vgame (play game (i,j))
varSet vplayer Computer
updt
_ -> return ()
-}
-- perform a computer opponent move
computerPlay g sf
= do p <- get g player
when (p==Just Computer) $
do b <- get g board
d <- get g level
case bestmove d b of
Nothing -> return ()
Just m -> do set g [board:= play b m, player:= Just Human]
updateStatus sf g
{-
-- perform a computer opponent move
computerPlay vplayer vgame vlevel updt
= do player <- varGet vplayer
game <- varGet vgame
level <- varGet vlevel
case player of
Human -> return ()
Computer -> case bestmove' (depth level) game of
(_, Nothing) -> return ()
(e, Just m) ->
do varSet vgame (play game m)
varSet vplayer Human
updt
-}
-- show a move as a string
showMove :: Player -> Board -> Move -> String
showMove p b (i,j) = show p ++ ": " ++ show (b!!i) ++ " to " ++ show (b!!j)