htzaar-0.0.2: src/Board.hs

-- | Board State and AI
module Board
  (
  -- * Types
    Board
  , BoardTree (..)
  , Type (..)
  , Piece
  , Position (..)
  , Move
  , Turn
  , AtPosition
  , Strategy
  , AI (..)
  -- * Utilities
  , boardTree
  , swapBoardTree
  , connectedPositions
  , threeLines
  , sixLines
  , atPosition
  , startingBoard
  , showTurn
  , showMove
  , applyMove
  ) where

import Data.List
import System.Random

-- | Board state is a list of pieces of you and oppenent.
type Board = ([Piece], [Piece])

-- | The board tree of all future moves.  Bool true if you, false if opponent.
data BoardTree = BoardTree Bool Board [(Turn, BoardTree)]

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

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

-- | Board position.  Letters left to right, numbers bottom to top.
--   Column E has the hole in the middle.
data Position
  = 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)

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

-- | An AI strategy calculates then 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.
  }

-- | The state of a single board position.  Bool true if you, false if opponent.
type AtPosition = (Bool, Type, Int)

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

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

-- | Possible next turns.
nextTurns :: Board -> [Turn]
nextTurns 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 = length (nub [ t | (_, t, _) <- you ]) /= 3

nextCaptureMoves :: Board -> [Move]
nextCaptureMoves board@(you, _) = concatMap forPiece you
  where
  forPiece :: 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 (True,  _, _) -> []
      Just (False, _, j) -> if i >= j then [(p, a)] else []

nextStackingMoves :: Board -> [Move]
nextStackingMoves board@(you, _) = concatMap forPiece you
  where
  forPiece :: Piece -> [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,  _) | oneTzaarRemaining  -> []
      Just (True, Tzarra, _) | oneTzarraRemaining -> []
      Just (True, Tott,   _) | oneTottRemaining   -> []
      Just (True, _, _) -> [(p, a)]
  oneTzaarRemaining  = 1 == length [ () | (_, t, _) <- you, t == Tzaar  ]
  oneTzarraRemaining = 1 == length [ () | (_, t, _) <- you, t == Tzarra ]
  oneTottRemaining   = 1 == length [ () | (_, t, _) <- you, t == Tott   ]

-- Creates a board tree for you and opponent.  Assumes you have the next turn.
boardTree :: Board -> BoardTree
boardTree board = boardTree True True board
  where
  boardTree :: Bool -> Bool -> Board -> BoardTree
  boardTree first you board = BoardTree you (if you then board else swapBoard board) [ (t, boardTree False (not you) $ swapBoard $ applyTurn board t) | t <- nextTurns board, imply first (snd t == Nothing) ]
  imply a b = not a || b

-- | Swaps board positions, i.e. white to black, black to white.
swapBoard :: Board -> Board
swapBoard (a, b) = (b, a)

-- | Swaps board trees, i.e. white to black, black to white.
swapBoardTree :: BoardTree -> BoardTree
swapBoardTree (BoardTree you board branches) = BoardTree (not you) (swapBoard board) [ (t, swapBoardTree bt) | (t, bt) <- branches ]


-- Querying the state of a board position.
atPosition :: Board -> Position -> Maybe AtPosition 
atPosition (you, opp) pos = if null a then Nothing else Just $ head a
  where
  a = [ (True, t, i) | (p, t, i) <- you, p == pos ] ++ [ (False, t, i) | (p, t, i) <- opp, p == pos ]

-- | All the lines that form connected positions on the board.
connectedPositions :: [[Position]]
connectedPositions =
  [ [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.
sixLines :: Position -> [[Position]]
sixLines p = concatMap f $ threeLines p where f l = [a, b] where (a, b) = divide p l

divide :: Eq a => a -> [a] -> ([a], [a])
divide a b = (reverse x, if null y then [] else tail y) where (x, y) = span (/= a) b

-- | The default (non-randomized, non-tournament) starting position.
startingBoard :: Board
startingBoard = (whites, 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  = [D3, E3, G4, G5, C5, D6]
  wTzarras = [C2, D2, E2, H3, H4, H5, B5, C6, D7]
  wTotts   = [B1, C1, D1, E1, I2, I3, I4, I5, D8, C7, B6, A5, E4, F5, D5]
  bTzaars  = [C3, C4, F3, G3, E6, F6]
  bTzarras = [B2, B3, B4, F2, G2, H2, E7, F7, G6]
  bTotts   = [A1, A2, A3, A4, F1, G1, H1, I1, E8, F8, G7, H6, D4, E5, F4]

-- | The next board state after a move.  Assumes move is valid.
applyMove :: Board -> Move -> Board
applyMove board@(a, b) (x, y) = (a', b')
  where
  Just (whoX, typeX, sizeX) = atPosition board x
  Just (whoY, _    , sizeY) = atPosition board y
  capture = whoX /= whoY
  fromA = null [ () | (p, _, _) <- b, p == x ]
  fromB = not fromA
  piece = (y, typeX, if capture then sizeX else sizeX + sizeY)
  a' = [ m | m@(p, _, _) <- a, p /= x, p /= y ] ++ if fromA then [piece] else []
  b' = [ m | m@(p, _, _) <- b, p /= x, p /= y ] ++ if fromB then [piece] else []

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