diff --git a/Babylon.hs b/Babylon.hs --- a/Babylon.hs +++ b/Babylon.hs @@ -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) diff --git a/GUI.hs b/GUI.hs new file mode 100644 --- /dev/null +++ b/GUI.hs @@ -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 ", + "", + "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) + diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 ", - "", - "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) - - - - diff --git a/Minimax.hs b/Minimax.hs --- a/Minimax.hs +++ b/Minimax.hs @@ -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 diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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) + + diff --git a/babylon.cabal b/babylon.cabal --- a/babylon.cabal +++ b/babylon.cabal @@ -1,9 +1,10 @@ Name: babylon -Version: 0.1 +Version: 0.2 Cabal-Version: >= 1.2 License: GPL License-file: LICENSE Author: Pedro Vasconcelos +Maintainer: Pedro Vasconcelos 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