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