babylon-0.2: Babylon.hs

{-
  Game playing module for Babylon 
  Pedro Vasconcelos, 2009-2010
-}
module Babylon where

import List
import Maybe
import Data.Tree
import Control.Monad
import Minimax

-- piece colors
data Color = White | Black | Green | Brown 
             deriving (Eq,Ord,Show,Enum)

-- 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
type Move = (Int,Int)

-- list of all colors
colors :: [Color]
colors = [White .. Brown]

-- the initial board: 4 colors x 3 pieces
-- each piece in a separate stack
initialBoard :: Board
initialBoard = [[c] | c<-colors, _<-[1..3]]


-- play a move and update the game
-- assumes the move is valid
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]
deleteIndex i xs = let (xs',x:xs'') = splitAt i xs
                   in  xs' ++ xs''

-- list all valid moves of a given board
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 = (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 (b,m) 
    = nubBy (\x y->sort (fst x)==sort (fst y)) 
      [(play b m',  m `mplus` Just m') | m'<-valid b]

-- build the game tree from a starting position
gametree :: Position -> Tree Position
gametree p = Node p (map gametree (positions p))


-- the static evaluation function
-- yields -1 if the position is a loss (no available moves);
-- yields 0 in other positions (unknown)
static :: Position -> Eval Position
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 -> Board -> Eval Position
dynamic depth b
    = bbminimax (-1) 1 $
      fmap static $
      prune depth $
      gametree (b,Nothing)
          

-- get the best move from a given board (using the above)
bestmove :: Int -> Board -> Maybe Move
bestmove d b = snd $ fromEval (dynamic d b)

bestmove' :: Int -> Board -> (Int, Maybe Move)
bestmove' d b = case dynamic d b of
                  Eval x (b,m) ->  (x, m)