{-
Main module and GUI for the Babylon game
Uses wxHaskell bindings to the wxWidgets toolkit
Pedro Vasconcelos, 2009
-}
module Main where
import Graphics.UI.WX hiding (play)
import Graphics.UI.WXCore
import Maybe
import Random
import Babylon
import Paths_babylon -- Cabal locations of image files
data Player = Human | Computer deriving (Eq,Show)
data Level = Easy | Medium | Hard | Hardest deriving (Eq,Show)
levels :: [Level]
levels = [Easy, Medium, Hard, Hardest]
main :: IO ()
main = start gui
-- start the GUI
gui :: IO ()
gui = do f <- frame [text := "Babylon"]
status <- statusField [text:="Welcome to Babylon"]
pan <- panel f []
game <- shuffleIO initialGame
vgame <- varCreate game
vboard <- varCreate []
vsel <- varCreate Nothing
vplayer <- varCreate Human
vlevel <- varCreate Medium
bmps <- loadBitmaps
game <- menuPane [text := "&Game"]
new<-menuItem game [text := "New",
help := "Restart the game"
]
menuLine game
menuQuit game [help := "Quit this program",
on command := delBitmaps bmps >> close f]
opt <- menuPane [text := "Options"]
r0<-menuItem opt [text := "Human plays first",
help := "Choose starting player",
checkable:=True, checked := True]
menuLine opt
-- create radio buttons for AI level
rs<-sequence [menuRadioItem opt
[text := show level,
help := "Choose computer opponent level",
on command := varSet vlevel level]
| level<-levels]
-- default: Medium level checked
set (rs!!1) [checked:=True]
hlp <- menuHelp []
rules<- menuItem hlp [text := "Rules",
help := "About the game rules",
on command := infoRules pan]
about <- menuAbout hlp [help := "About this program",
on command := infoAbout pan]
-- name an action to update the status field & repaint the board
let updt = do updateStatus status vplayer vgame
repaint pan
set pan [on resize := repaint pan,
on paint := drawBoard bmps vgame vboard vsel,
on click := (\pt -> do ix<-getIndex vboard pt
humanPlay vplayer vgame vsel updt ix),
layout := space 700 300
]
-- register a timer event to periodically play the computer
t <- timer f [interval := 2000,
on command := computerPlay vplayer vgame vlevel updt
]
set f [statusBar := [status],
menuBar := [game, opt, hlp],
layout := fill (widget pan)
]
-- set the handler for restarting the game
set new [on command := do game <- shuffleIO initialGame
flag <- get r0 checked
varSet vplayer (if flag then Human
else Computer)
varSet vgame game
varSet vsel Nothing
updt
]
-- 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 for portable file paths
loadBitmaps
= sequence [do { f<-getDataFileName ("images/" ++ show c ++ ".png")
; bitmapCreateLoad f wxBITMAP_TYPE_PNG }
| c<-colors]
-- delete the bitmaps
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 status vplayer vgame
= do player <- varGet vplayer
game <- varGet vgame
let moves = valid game
case moves of
[] -> set status [text := show player ++ " loses (no moves available)"]
_ -> set status [text := show player ++ " to play"]
--
-- main function to redraw the game board
--
drawBoard bmps vgame vboard vsel dc (Rect x y w h)
= do game <- varGet vgame
rs <- drawStacks bmps game dc x' y'
varSet vboard rs
-- highlight the selection (if active)
sel <- varGet vsel
case sel of
Nothing -> return ()
Just i -> 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
-- convert a screen positon into Just a tile index or Nothing
getIndex vboard pt
= do rs <- varGet vboard
return (listToMaybe [i | (i,r)<-zip [0..] rs, rectContains r pt])
--
-- handle a mouse click and perform a human player move
-- `updt' is a continuation to update the board, etc.
--
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
-- `updt' is a continuation to update the board, etc.
--
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 -> Game -> Move -> String
showMove p g (i,j) = show p ++ ": " ++ show (g!!i) ++ " to " ++ show (g!!j)
-- convert the difficulty level in the minimax analysis depth ("ply")
depth :: Level -> Int
depth Easy = 2
depth Medium = 4
depth Hard = 8
depth Hardest = 12 -- optimal play (always wins as 2nd player)
-- an auxilary function to shuffle a list randomly
shuffleIO :: [a] -> IO [a]
shuffleIO xs = do g <- getStdGen
let (xs', g') = shuffle g xs (length xs)
setStdGen g'
return xs'
where
shuffle :: RandomGen g => g -> [a] -> Int -> ([a], g)
shuffle g xs n
| n>0 = let (k, g') = randomR (0,n-1) g
(xs',x:xs'') = splitAt k xs
(ys,g'') = shuffle g' (xs' ++ xs'') (n-1)
in (x:ys, g'')
| otherwise = ([],g)