hstzaar-0.6: src/Board.hs

{-# LANGUAGE BangPatterns #-}
-- | Board State and AI
module Board
  (
  -- * Types
    Board (..)
  --, move
  --, player
  --, active
  --, inactive
  , whites
  , blacks
  , boardSize
  , HalfBoard
  , BoardTree
  , GameTree(..)
  , Type (..)
  , Piece
  , Position
  , APosition (..)
  , fromAPos
  , toAPos
  , Move (..)
  , Turn
  -- , AtPosition
  , Strategy
  , AI (..)
  -- * Utilities
  , boardTree
  , startBoardTree
  , mapTree
  , mapTree'
  , endGame
  , endGameTree
  --, swapBoard
  --, swapBoardTree
  , nextCaptureMoves
  , nextStackingMoves
  , nextTurns
  , nextMoves
  , 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 { player :: !Bool,       -- True=white, False=black
                     move :: !Int,          -- 1 or 2
                     active :: !HalfBoard, 
                     inactive :: !HalfBoard 
                   } deriving (Eq,Show,Read)

-- | 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, Read, 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,Read, 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 a pair of positions, for either capturing or stacking.
-- type Move = (Position, Position)
data Move = Capture !Position !Position  -- from, to
          | Stack   !Position !Position  -- only as second move
          | Pass                         -- only as second move
            deriving (Eq,Show,Read)

-- | A complete turn is a pair of moves
type Turn = (Move, 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 
type BoardTree = GameTree Board Move

-- | 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, b) = showMove a ++ "  " ++ showMove b

showMove :: Move -> String
showMove (Capture a b) = show (toAPos a) ++ "x" ++ show (toAPos b)
showMove (Stack a b)   = show (toAPos a) ++ "-" ++ show (toAPos b)
showMove Pass          = "pass"


-- | Projections to get the white & black half-boards
whites, blacks :: Board -> HalfBoard
whites board | player board = active board
             | otherwise    = inactive board

blacks board | player board = inactive board
             | otherwise    = active board


-- | board size (number of pieces)
boardSize :: Board -> Int
boardSize board = IntMap.size (active board) + IntMap.size (inactive board)


-- | next complete turns for the active player
nextTurns :: Board -> [Turn]
nextTurns board
  | lostOneOfThree = []
  | otherwise      = captureCapture ++ captureStack ++ captureNothing
  where
    you = active board
    captures = nextCaptureMoves board
    bs = map (applyMove board) captures
    captures' = map nextCaptureMoves  bs
    stackings = map nextStackingMoves bs
    captureCapture = [ (m,m') | (m, ms)<-zip captures captures', m'<-ms]
    captureStack   = [ (m,m') | (m, ms)<-zip captures stackings, m'<-ms]
    captureNothing = zip captures (repeat Pass)
    lostOneOfThree = any (==0) (countStacks you) 


-- | next moves for the active player
nextMoves :: Board -> [Move]
nextMoves board 
    = case move board of
        1 -> nextCaptureMoves board
        2 -> nextStackingMoves board ++ nextCaptureMoves board ++ [Pass]
        _ -> error "nextMoves: invalid board"



-- | next capture moves for the active player
nextCaptureMoves :: Board -> [Move]
nextCaptureMoves board = IntMap.foldWithKey forPiece [] you
  where
    you = active board
    who = player board
    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 -> (Capture 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 = foldl' forPiece [] (IntMap.keys you)
  where 
    who = player board
    you = active board
    (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 (_, _) -> (Stack 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]



-- | The next board state after a move.  
-- | Assumes the move is valid.
applyMove :: Board -> Move -> Board
applyMove (Board who move you other) (Capture x y) 
    = makeBoard who (move+1) you' other'
    where
      (typeX, sizeX) = you!x
      (_    , sizeY) = other!y
      piece = (typeX, sizeX) 
      you' = IntMap.insert y piece (IntMap.delete x you)
      other' = IntMap.delete y other

applyMove (Board who move you other) (Stack x y) 
    = makeBoard who (move+1) you' other
    where
      (typeX, sizeX) = you!x
      (_    , sizeY) = you!y
      piece = (typeX, sizeX + sizeY)
      you' = IntMap.insert y piece (IntMap.delete x you)

applyMove (Board who move you other) Pass 
  = makeBoard who (move+1) you other


-- | check to swap board position if we are the end of a turn
makeBoard :: Bool -> Int -> HalfBoard -> HalfBoard -> Board
makeBoard who move you other
  | move>2   = Board (not who) 1 other you
  | otherwise= Board who move you 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 (m1,m2) = applyMove (applyMove board m1) m2


-- | Create a board tree from a mid-game position
boardTree :: Board -> BoardTree
boardTree b = GameTree b [(m, boardTree (applyMove b m)) | m<-nextMoves b]


-- | Create a board tree from a start position
-- | single captures only for the white's first turn
startBoardTree :: Board -> BoardTree
startBoardTree b = GameTree b [(m, GameTree b' [(Pass, boardTree b'')]) 
                    | m<-nextCaptureMoves b, 
                      let b'=applyMove b m, let b''=applyMove b' Pass]



-- | Check for a end of game position
endGame :: Board -> Bool
endGame b = move b==1 && null (nextTurns b)

-- | Check for a end of game tree
endGameTree :: GameTree s m -> Bool
endGameTree (GameTree _ []) = True
endGameTree _               = False


-- | 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 pos 
    = do { piece<-IntMap.lookup pos you
         ; return (who,piece) 
         } `mplus`
      do { piece<-IntMap.lookup pos other
         ; return (not who,piece)
         }
    where who = player board
          you = active board
          other = inactive board


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







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


-- | The default (non-randomized, non-tournament) starting position.
startingBoard :: Board
startingBoard = Board True 1 (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 1 (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
        = [board {active=you} | you<-shrinkHalf (active board)] ++
          [board {inactive=other} | other<-shrinkHalf (inactive board)] 


-- 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 1 (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')