babylon 0.1 → 0.2
raw patch · 6 files changed
+415/−285 lines, 6 filesdep +array
Dependencies added: array
Files
- Babylon.hs +26/−28
- GUI.hs +324/−0
- Main.hs +1/−252
- Minimax.hs +2/−2
- Utils.hs +58/−0
- babylon.cabal +4/−3
Babylon.hs view
@@ -1,6 +1,6 @@ {- Game playing module for Babylon - Pedro Vasconcelos, 2009+ Pedro Vasconcelos, 2009-2010 -} module Babylon where @@ -14,9 +14,8 @@ data Color = White | Black | Green | Brown deriving (Eq,Ord,Show,Enum) --- a game board is a list of stacks;--- each stack is a list of colors-type Game = [[Color]]+-- the board is represented by list of stacks; each stack is a list of colors+type Board = [[Color]] -- a move is given by a pair of indices -- (i,j) means move stack i on top of stack j@@ -26,18 +25,18 @@ colors :: [Color] colors = [White .. Brown] --- the initial game game: 4 colors x 3 pieces+-- the initial board: 4 colors x 3 pieces -- each piece in a separate stack-initialGame :: Game-initialGame = [[c] | c<-colors, _<-[1..3]]+initialBoard :: Board+initialBoard = [[c] | c<-colors, _<-[1..3]] -- play a move and update the game -- assumes the move is valid-play :: Game -> Move -> Game-play g (i,j) = let from = g!!i- (g', to:g'')= splitAt j g - in deleteIndex i (g' ++ (from++to):g'')+play :: Board -> Move -> Board+play b (i,j) = let from = b!!i+ (b', to:b'')= splitAt j b+ in deleteIndex i (b' ++ (from++to):b'') -- delete element of a list at index i deleteIndex :: Int -> [a] -> [a]@@ -45,24 +44,23 @@ in xs' ++ xs'' -- list all valid moves of a given board-valid :: Game -> [Move]-valid g = [(i,j) | (xs,i)<-zip g [0..], (ys,j)<-zip g [0..],- i/=j && (head xs==head ys || length xs==length ys)- ]+valid :: Board -> [Move]+valid b = [(i,j) | (xs,i)<-zip b [0..], (ys,j)<-zip b [0..],+ i/=j && (head xs==head ys || length xs==length ys)] -- a game position: a board labeled with an optional move -- this is used to identify which move lead to which position-type Position = (Game, Maybe Move)+type Position = (Board, Maybe Move) -- subsequent positions from a given position -- labelled with the first move; subsequent moves are not needed -- optimization: reduces the branching factor -- by removing "equivalent" child positions positions :: Position -> [Position]-positions (g,m) +positions (b,m) = nubBy (\x y->sort (fst x)==sort (fst y)) - [(play g m', mplus m (Just m')) | m'<-valid g]+ [(play b m', m `mplus` Just m') | m'<-valid b] -- build the game tree from a starting position gametree :: Position -> Tree Position@@ -73,23 +71,23 @@ -- yields -1 if the position is a loss (no available moves); -- yields 0 in other positions (unknown) static :: Position -> Eval Position-static p@(g,m) | null (valid g) = Eval (-1) p+static p@(b,m) | null (valid b) = Eval (-1) p | otherwise = Eval 0 p -- dynamic evaluation to choose the best move -- uses alpha-beta prunning minimax with a fixed ply-depth-dynamic :: Int -> Game -> Eval Position-dynamic depth game- = bbminimax (Eval (-1) undefined) (Eval 1 undefined) $+dynamic :: Int -> Board -> Eval Position+dynamic depth b+ = bbminimax (-1) 1 $ fmap static $ prune depth $- gametree (game,Nothing)+ gametree (b,Nothing) -- get the best move from a given board (using the above)-bestmove :: Int -> Game -> Maybe Move-bestmove d g = snd $ fromEval (dynamic d g)+bestmove :: Int -> Board -> Maybe Move+bestmove d b = snd $ fromEval (dynamic d b) -bestmove' :: Int -> Game -> (Int, Maybe Move)-bestmove' d g = case dynamic d g of- Eval x (g,m) -> (x, m)+bestmove' :: Int -> Board -> (Int, Maybe Move)+bestmove' d b = case dynamic d b of+ Eval x (b,m) -> (x, m)
+ GUI.hs view
@@ -0,0 +1,324 @@+{- + 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 Maybe+import 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)+
Main.hs view
@@ -7,258 +7,7 @@ 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]+import GUI 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)----
Minimax.hs view
@@ -8,7 +8,7 @@ --import Data.List -- annotate something with an evaluation estimate -data Eval a = Eval Int a deriving (Show)+data Eval a = Eval !Int a deriving (Show) instance Eq (Eval a) where (Eval x _) == (Eval y _) = x==y@@ -17,7 +17,7 @@ compare (Eval x _) (Eval y _) = compare x y instance (Show a) => Num (Eval a) where- fromInteger = undefined+ fromInteger n = Eval (fromIntegral n) undefined (+) = undefined (-) = undefined (*) = undefined
+ Utils.hs view
@@ -0,0 +1,58 @@+{- + Miscelaneous utility functions + Pedro Vasconcelos, 2009+-}++module Utils where+import Random+import Data.Array.MArray+import Data.Array.IO++--+-- Knuth-Fisher-Yates shuffling algorithm+--+shuffleIO :: [a] -> IO [a]+shuffleIO xs+ = do { arr <- newListArray (0,n) [0..n] :: IO (IOUArray Int Int) + ; sequence_ [do { j<-randomRIO (i,n)+ ; t1<-readArray arr i+ ; t2<-readArray arr j+ ; writeArray arr i t2+ ; writeArray arr j t1 + } | i<-[0..n-1]]+ ; sequence [do j<-readArray arr i+ return (xs!!j) | i<-[0..n]]+ }+ where n = length xs - 1+ +++-- an auxilary function to shuffle a list randomly+shuffleRnd :: RandomGen g => g -> [a] -> ([a], g)+shuffleRnd g xs = shuffle' g xs (length 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)+++-- randomly-generated list of shuffles+nshuffles :: RandomGen g => g -> Int -> [a] -> ([[a]], g)+nshuffles g n cards + | n>0 = let (first,g')= shuffleRnd g cards+ (rest, g'') = nshuffles g' (n-1) cards+ in (first:rest, g'')+ | otherwise = ([], g)++++-- deterministic shuffle+shuffle :: [a] -> [a]+shuffle [] = []+shuffle (x:xs) = x : shuffle (reverse xs)++
babylon.cabal view
@@ -1,9 +1,10 @@ Name: babylon-Version: 0.1+Version: 0.2 Cabal-Version: >= 1.2 License: GPL License-file: LICENSE Author: Pedro Vasconcelos <pbv@dcc.fc.up.pt>+Maintainer: Pedro Vasconcelos <pbv@dcc.fc.up.pt> Copyright: (c) 2009 Pedro Vasconcelos Synopsis: An implementation of a simple 2-player board game Description: The board game was originally designed by Bruno Faidutti (www.faidutti.com).@@ -13,8 +14,8 @@ Category: Game Executable babylon- Build-Depends: base>= 3 && < 4, haskell98, containers, wx >= 0.11, wxcore >= 0.11+ Build-Depends: base>= 3 && < 4, haskell98, containers, wx >= 0.11, wxcore >= 0.11, array Main-Is: Main.hs- Other-modules: Babylon Minimax+ Other-modules: Babylon Minimax GUI Utils