{- 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 ", "", "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)