babylon-0.1: Babylon.hs

{-
  Game playing module for Babylon 
  Pedro Vasconcelos, 2009
-}
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)

-- a game board is a list of stacks;
-- each stack is a list of colors
type Game = [[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 game game: 4 colors x 3 pieces
-- each piece in a separate stack
initialGame :: Game
initialGame = [[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'')

-- 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 :: 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)
          ]


-- 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)

-- 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) 
    = nubBy (\x y->sort (fst x)==sort (fst y)) 
      [(play g m', mplus m (Just m')) | m'<-valid g]

-- 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@(g,m) | null (valid g) = 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) $
      fmap static $
      prune depth $
      gametree (game,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 -> Game -> (Int, Maybe Move)
bestmove' d g = case dynamic d g of
                  Eval x (g,m) ->  (x, m)