{-# 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' , isEmptyTree , endGame , whiteWins --, swapBoard --, swapBoardTree , nextCaptureMoves , nextStackingMoves --, nextTurns , nextMoves , countStacks , sixLines , atPosition , emptyBoard , startingBoard , randomBoard , randomBoardIO , 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, -- next to play (True=White, False=Black) move :: !Int, -- first or second move in a turn active :: HalfBoard, -- active player's pieces inactive :: HalfBoard -- inactive player's pieces } 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 (Eq, Ord, Show, Read) -- | 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 (Eq, Ord, Enum, Bounded, Show, Read) -- | "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 -- | 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] -- | test for empty branches isEmptyTree :: GameTree a m -> Bool isEmptyTree (GameTree _ []) = True isEmptyTree _ = False -- | 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 an end of game position endGame :: Board -> Bool endGame b = case move b of 1 -> lostPieces || nullCaptures 2 -> lostPieces' _ -> error "endGame: invalid board" where lostPieces = any (==0) (countStacks (active b)) lostPieces'= any (==0) (countStacks (inactive b)) nullCaptures = null (nextCaptureMoves b) -- | Determine the game winner; assumes endGame is True whiteWins :: Board -> Bool whiteWins b = case move b of 1 -> not (player b) 2 -> player b _ -> error "whiteWins: invalid board" -- | 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 randomBoardIO :: IO Board randomBoardIO = do rnd <- getStdGen let (b, rnd') = randomBoard rnd setStdGen rnd' return b -- 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')