hstzaar-0.5: src/Board.hs

{-# LANGUAGE BangPatterns #-}
-- | Board State and AI
module Board
  (
  -- * Types
    Board 
  , whiteTurn
  , active
  , inactive
  , whites
  , blacks
  , boardSize
  , HalfBoard
  , BoardTree
  , GameTree(..)
  , Type (..)
  , Piece
  , Position
  , APosition (..)
  , fromAPos
  , toAPos
  , Move
  , Turn
  -- , AtPosition
  , Strategy
  , AI (..)
  -- * Utilities
  , boardTree
  , startBoardTree
  , mapTree
  , mapTree'
  , isEndGame
  , swapBoard
  , swapBoardTree
  , nextCaptureMoves
  , nextStackingMoves
  , nextTurns
  , countStacks
  , sixLines
  , atPosition
  , emptyBoard
  , startingBoard
  , randomBoard
  , showTurn
  , showMove
  , applyMove
  , applyTurn
  , positions
    --  , shuffle
  , infinity
  ) where

import Data.List
import Data.IntMap (IntMap, (!))
import qualified Data.IntMap as IntMap
import System.Random
import Control.Monad (mplus)
import Test.QuickCheck

-- | The board state
-- | current turn, active player pieces, other player pieces
data Board = Board { whiteTurn :: !Bool, 
                     active :: !HalfBoard, 
                     inactive :: !HalfBoard }
             deriving (Eq,Show)

-- | A Half-board maps (unboxed) positions to pieces 
type HalfBoard = IntMap Piece 

-- | The three types of pieces
-- | Each player starts with 6 Tzaars, 9 Tzarras, and 15 Totts.
data Type = Tzaar | Tzarra | Tott deriving (Show, Eq, Ord)

-- | the type of a piece, and the level of the stack (starting with 1).
type Piece = (Type,Int)

-- | Algebraic board positions.  Letters left to right, numbers bottom to top.
-- | Column E has the hole in the middle.
data APosition
  = A1 | A2 | A3 | A4 | A5
  | B1 | B2 | B3 | B4 | B5 | B6
  | C1 | C2 | C3 | C4 | C5 | C6 | C7
  | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8
  | E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8
  | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8
  | G1 | G2 | G3 | G4 | G5 | G6 | G7
  | H1 | H2 | H3 | H4 | H5 | H6
  | I1 | I2 | I3 | I4 | I5
  deriving (Show, Eq, Ord, Enum, Bounded)

-- | "Unboxed" integer board positions
type Position = Int 

-- converto to/from algebraic positions
fromAPos :: APosition -> Position
fromAPos = fromEnum 

toAPos :: Position -> APosition
toAPos = toEnum 

-- | A move is one position to another, for either capturing or stacking.
type Move = (Position, Position)

-- | A complete turn is move, followed by an optional move.
type Turn = (Move, Maybe Move)


-- | A game tree with nodes s and moves m
data GameTree s m = GameTree s [(m, GameTree s m)] deriving Show

-- | A game tree of boards labeled with a boolean 
type BoardTree = GameTree Board Turn

-- | An AI strategy calculates the next turn from a board tree.
type Strategy = BoardTree -> StdGen -> (Turn, StdGen)

-- | An AI player.
data AI = AI
  { name        :: String   -- ^ Name of AI.
  , description :: String   -- ^ Brief description of AI.
  , strategy    :: Strategy -- ^ The strategy.
  }



-- | List of all positions (for enumeration purposes)
positions :: [Position]
positions = map fromAPos [minBound .. maxBound]

showTurn :: Turn -> String
showTurn (a, Nothing) = showMove a
showTurn (a, Just b ) = showMove a ++ "    " ++ showMove b

showMove :: Move -> String
showMove (a, b) = show (toAPos a) ++ " -> " ++ show (toAPos b)



-- | Projections to get the white & black half-boards
whites, blacks :: Board -> HalfBoard
whites (Board True you other)  = you
whites (Board False you other) = other
blacks (Board True you other)  = other
blacks (Board False you other) = you


-- | board size (number of pieces)
boardSize :: Board -> Int
boardSize (Board _ you other) = IntMap.size you + IntMap.size other


-- | next complete turns for the active player
nextTurns :: Board -> [Turn]
nextTurns board@(Board _ you _)
  | lostOneOfThree = []
  | otherwise      = captureCapture ++ captureStack ++ captureNothing
  where
  a = nextCaptureMoves board
  b = map (applyMove board) a
  c = map nextCaptureMoves  b
  d = map nextStackingMoves b
  captureCapture = [ (a, Just b) | (a, x) <- zip a c, b <- x ]
  captureStack   = [ (a, Just b) | (a, x) <- zip a d, b <- x ]
  captureNothing = zip a $ repeat Nothing
  lostOneOfThree = minimum (countStacks you) == 0


-- | next capture moves for the active player
nextCaptureMoves :: Board -> [Move]
nextCaptureMoves board@(Board who you _) = IntMap.foldWithKey forPiece [] you
  where
  forPiece :: Position -> Piece -> [Move] -> [Move]
  forPiece !p (_, !i) moves = foldl' downLine moves (sixLines p)
    where
    downLine :: [Move] -> [Position] -> [Move]
    downLine moves []   = moves
    downLine moves (q:ps) = case atPosition board q of
      Nothing -> downLine moves ps 
      Just (who', (_, j)) | who/=who' && i>=j -> (p,q):moves
      _  -> moves


{-
nextCaptureMoves :: Board -> [Move]
nextCaptureMoves board@(Board who you _) = concatMap forPiece (IntMap.assocs you)
  where
  forPiece :: (Position,Piece) -> [Move]
  forPiece (p, (_, i)) = concatMap downLine $ sixLines p
    where
    downLine :: [Position] -> [Move]
    downLine [] = []
    downLine (a:b) = case atPosition board a of
      Nothing -> downLine b
      Just (who', _) | who'==who ->  []
      Just (_, (_, j)) -> [(p, a) | i>=j]
-}


-- | next stacking moves for the active player
nextStackingMoves :: Board -> [Move]
nextStackingMoves board@(Board who you _) = foldl' forPiece [] (IntMap.keys you)
  where 
    (tzaars:tzarras:totts: _) = countStacks you
    forPiece :: [Move] -> Position -> [Move]
    forPiece moves p = foldl' downLine moves (sixLines p)
        where
          downLine :: [Move] -> [Position] -> [Move]
          downLine moves [] = moves
          downLine moves (q:ps) 
              = case atPosition board q of
                  Nothing  -> downLine moves ps
                  Just (who', _) | who'/=who -> moves
                  Just (_, (Tzaar,_)) | tzaars==1  -> moves
                  Just (_, (Tzarra,_)) | tzarras==1 -> moves
                  Just (_, (Tott, _)) | totts==1  -> moves
                  Just (_, _) -> (p,q) : moves


{-
nextStackingMoves :: Board -> [Move]
nextStackingMoves board@(you, _) = concatMap forPiece (IntMap.keys you)
  where
  (tzaars:tzarras:totts:_) = countStacks you
  forPiece :: Position -> [Move]
  forPiece p = concatMap downLine $ sixLines p
    where
    downLine :: [Position] -> [Move]
    downLine [] = []
    downLine (a:b) = case atPosition board a of
      Nothing   -> downLine b
      Just (False, _) -> []
      Just (True, (Tzaar,_)) | tzaars==1  -> []
      Just (True, (Tzarra,_)) | tzarras==1 -> []
      Just (True, (Tott, _)) | totts==1  -> []
      Just (True, _) -> [(p, a)]
-}

-- | count the number of stacks of each type in a half-board
countStacks :: HalfBoard -> [Int]
countStacks b 
    = count 0 0 0 (IntMap.elems b)
    where
      count :: Int -> Int -> Int -> [Piece] -> [Int]
      count !x !y !z ((Tzaar,_):ps)  = count (1+x) y z ps
      count !x !y !z ((Tzarra,_):ps) = count x (1+y) z ps
      count !x !y !z ((Tott,_):ps)   = count x y (1+z) ps
      count !x !y !z []              = [x,y,z]

{-
countStacks :: HalfBoard -> [Int]
countStacks b = [tzaars, tzarras, totts]
    where
      tzaars = IntMap.fold (\(!t,_) !s -> 
                          case t of { Tzaar-> s+1; _ -> s}) 0 b
      tzarras = IntMap.fold (\(!t,_) !s -> 
                           case t of { Tzarra-> s+1; _ -> s}) 0 b
      totts = IntMap.fold (\(!t,_) !s -> 
                         case t of { Tott-> s+1; _ -> s}) 0 b
      
-}


-- | Swaps board positions after the end of a turn
swapBoard :: Board -> Board
swapBoard (Board who you other) = Board (not who) other you

-- | Create a board tree from a board 
boardTree :: Board -> BoardTree
boardTree b 
  = GameTree b [(t, boardTree (swapBoard $ applyTurn b t)) | t<-nextTurns b]


-- | Consider single captures only for the white's first turn
startBoardTree :: Board -> BoardTree
startBoardTree = firstTurn . boardTree
    where
      firstTurn (GameTree node branches) 
        = GameTree node [t | t@((m,Nothing),bt)<-branches]

swapBoardTree :: BoardTree -> BoardTree
swapBoardTree = mapTree swapBoard


-- | Check for a game tree leaf (i.e. end of game situation)
isEndGame :: GameTree s m -> Bool
isEndGame (GameTree _ branches) = null branches

-- | some auxiliary functions over game trees
-- apply a function to each node
mapTree :: (a->b) -> GameTree a m -> GameTree b m
mapTree f (GameTree x branches) 
    = GameTree (f x) [(m,mapTree f t) | (m,t)<-branches]

-- apply a function to each edge
mapTree' :: (a->b) -> GameTree s a -> GameTree s b
mapTree' f (GameTree x branches) 
    = GameTree x [(f m,mapTree' f t) | (m,t)<-branches]


-- | Query the state of a board position.
atPosition :: Board -> Position -> Maybe (Bool,Piece)
atPosition (Board who you other) pos 
    = do { piece<-IntMap.lookup pos you
         ; return (who,piece) 
         } `mplus`
      do { piece<-IntMap.lookup pos other
         ; return (not who,piece)
         }


-- | All the lines that form connected positions on the board.
connectedPositions :: [[Position]]
connectedPositions =
  map (map fromAPos) 
  [ [A1, A2, A3, A4, A5]
  , [B1, B2, B3, B4, B5, B6]
  , [C1, C2, C3, C4, C5, C6, C7]
  , [D1, D2, D3, D4, D5, D6, D7, D8]
  , [E1, E2, E3, E4]
  , [E5, E6, E7, E8]
  , [F1, F2, F3, F4, F5, F6, F7, F8]
  , [G1, G2, G3, G4, G5, G6, G7]
  , [H1, H2, H3, H4, H5, H6]
  , [I1, I2, I3, I4, I5]

  , [A1, B1, C1, D1, E1]
  , [A2, B2, C2, D2, E2, F1]
  , [A3, B3, C3, D3, E3, F2, G1]
  , [A4, B4, C4, D4, E4, F3, G2, H1]
  , [A5, B5, C5, D5]
  , [F4, G3, H2, I1]
  ,     [B6, C6, D6, E5, F5, G4, H3, I2]
  ,         [C7, D7, E6, F6, G5, H4, I3]
  ,             [D8, E7, F7, G6, H5, I4]
  ,                 [E8, F8, G7, H6, I5]
   
  ,                 [E1, F1, G1, H1, I1]
  ,             [D1, E2, F2, G2, H2, I2]
  ,         [C1, D2, E3, F3, G3, H3, I3]
  ,     [B1, C2, D3, E4, F4, G4, H4, I4]
  , [A1, B2, C3, D4]
  , [F5, G5, H5, I5]
  , [A2, B3, C4, D5, E5, F6, G6, H6]
  , [A3, B4, C5, D6, E6, F7, G7]
  , [A4, B5, C6, D7, E7, F8]
  , [A5, B6, C7, D8, E8]
  ]

-- | The three lines that cross at a single board position.
threeLines :: Position -> [[Position]]
threeLines p = [ line | line <- connectedPositions, elem p line ]


-- | The six lines traveling radially out from a single board position.
-- | optimization: this map should be memoied lazily 
sixLines_memo :: IntMap [[Position]]  -- Map Position [[Position]]
sixLines_memo = IntMap.fromList [(p, radials p) | p<-positions]
    where radials p = [r | l<-threeLines p, r<-divide p l, not (null r)]
          divide a b = [reverse x, y]
              where (x, _:y) = span (/= a) b

sixLines :: Position -> [[Position]]
sixLines p = sixLines_memo!p



-- | The next board state after a move.  
-- | Assumes white is next to move and move is valid.
applyMove :: Board -> Move -> Board
applyMove (Board who you other) (x,y) 
    = Board who you' other'
    where
      capture = IntMap.member y other   -- capture or stacking?
      (typeX, sizeX) = you!x
      (_    , sizeY) | capture   = other!y
                     | otherwise = you!y
      piece | capture   = (typeX, sizeX) 
            | otherwise = (typeX, sizeX + sizeY)
      you' = IntMap.insert y piece (IntMap.delete x you)
      other' | capture   = IntMap.delete y other
             | otherwise = other

{-
applyMove :: Board -> Move -> Board
applyMove board@(a, b) (x, y) 
    | whoX     = (IntMap.insert y piece (IntMap.delete x a), b')
    | otherwise = (a', IntMap.insert y piece (IntMap.delete x b))
    where
      whoX = IntMap.member x a
      whoY = IntMap.member y a
      (typeX, sizeX) | whoX = a!x
                     | otherwise = b!x
      (_    , sizeY) | whoY = a!y
                     | otherwise = b!y
      capture = whoX /= whoY
      piece | capture = (typeX, sizeX) 
            | otherwise = (typeX, sizeX + sizeY)
      a' | capture = IntMap.delete y a
         | otherwise = a
      b' | capture = IntMap.delete y b
         | otherwise = b
-}

-- | The next board state after a complete turn.  Assumes turn is valid.
applyTurn :: Board -> Turn -> Board
applyTurn board (a, Just b ) = applyMove (applyMove board a) b
applyTurn board (a, Nothing) =            applyMove board a



-- | An empty board
emptyBoard :: Board
emptyBoard = Board True (IntMap.empty) (IntMap.empty)


-- | The default (non-randomized, non-tournament) starting position.
startingBoard :: Board
startingBoard = Board True (IntMap.fromList whites) (IntMap.fromList blacks)
  where
  f t p = (p, (t, 1))
  whites = map (f Tzaar) wTzaars ++ map (f Tzarra) wTzarras ++ map (f Tott) wTotts
  blacks = map (f Tzaar) bTzaars ++ map (f Tzarra) bTzarras ++ map (f Tott) bTotts
  wTzaars  = map fromAPos [D3, E3, G4, G5, C5, D6]
  wTzarras = map fromAPos [C2, D2, E2, H3, H4, H5, B5, C6, D7]
  wTotts   = map fromAPos [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]
  bTzaars  = map fromAPos [C3, C4, F3, G3, E6, F6]
  bTzarras = map fromAPos [B2, B3, B4, F2, G2, H2, E7, F7, G6]
  bTotts   = map fromAPos [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, 
                           G7, H6, D4, E5, F4]


-- | A randomized starting position
randomBoard :: StdGen -> (Board, StdGen)
randomBoard rnd 
    = (Board True (IntMap.fromList whites) (IntMap.fromList blacks), rnd')
    where pieces = replicate 6 (Tzaar,1) ++
                   replicate 9 (Tzarra,1) ++
                   replicate 15 (Tott,1)
          (positions',rnd') = shuffle rnd positions
          whites = zip (take 30 positions') pieces
          blacks = zip (drop 30 positions') pieces


-- an auxilary function to shuffle a list randomly
shuffle :: StdGen  -> [a] -> ([a], StdGen)
shuffle 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)



-- | maximum absolute value of static evaluation 
infinity :: Int
infinity = 2^20

------------------------------------------------------------------------
-- | QuickCheck generators
------------------------------------------------------------------------

-- generators for board elements
instance Arbitrary Type where
    arbitrary = elements [Tzaar,Tzarra,Tott]

-- default generator and counter-example shrinker for boards
instance Arbitrary Board where
    arbitrary = sized genBoard

    shrink (Board who you other) 
        = [Board who you' other | you'<-shrinkHalf you] ++
          [Board who you other' | other'<-shrinkHalf other] 


-- helper function to shrink half-boards
-- first try to remove pieces, then reduce heights
shrinkHalf :: HalfBoard -> [HalfBoard]
shrinkHalf b = [IntMap.delete p b | p<-IntMap.keys b] ++
               [IntMap.insert p (t,h') b | 
                (p,(t,h))<-IntMap.assocs b, h'<-[1..h-1]]



-- a generator for boards
-- size argument is a bound for the total number of pieces
genBoard :: Int -> Gen Board
genBoard n = do ws <- genPieces n'
                bs <- genPieces n'
                positions' <- genShuffle positions
                who <- arbitrary
                let whites = zip (take n' positions') ws
                let blacks = zip (drop n' positions') bs
                return $ Board who (IntMap.fromList whites) (IntMap.fromList blacks)
    where n' = (min 60 n)`div`2



genPieces :: Int -> Gen [(Type,Int)]
genPieces n = do pieces <- genShuffle allpieces
                 k <- choose (0,n)
                 genStacks k (take n pieces)
    where allpieces = [(t,1) | t<-replicate 6 Tzaar ++ 
                                  replicate 9 Tzarra ++ 
                                  replicate 15 Tott]
               

-- generate stacks from single pieces
genStacks 0 xs     = return xs
genStacks _     [] = return []
genStacks _     [x]= return [x]
genStacks (n+1) xs = do p1@(t1,h1) <- elements xs
                        let xs' = delete p1 xs
                        p2@(t2,h2) <- elements xs'
                        genStacks n ((t1,h1+h2) : delete p2 xs')
                  

-- auxiliary function to shuffle a list
genShuffle :: Eq a => [a] -> Gen [a]
genShuffle [] = return []
genShuffle xs = do x  <- elements xs
                   xs'<- genShuffle (delete x xs)
                   return (x:xs')