game tree search notes

GameSearch.hs

{-# LANGUAGE
  LambdaCase, NoMonomorphismRestriction,
  RankNTypes, ScopedTypeVariables,
  TupleSections, GADTs, FlexibleContexts,
  ViewPatterns, GeneralizedNewtypeDeriving #-}

import Data.List
import Data.List.Split
import Data.Ord
import Control.Lens
import Control.Applicative
import Control.Monad
import Data.Array (Array, (//), (!))
import qualified Data.Array as A

-- TODO : Principal variation instead of Maybe move?
-- TODO : Mutable data with make/unmake move?
-- TODO : Transition tables
-- TODO : quiescence search
-- TODO : Search configuration data: defaults + monoid instance?

{-
  ATTENTION : Only use negaX if the following holds:
    1. negate minBound == maxBound
    2. negate maxBound == minBound
    3. the heuristic of a state with PMax == negate (heuristic of state with PMin)
  Use newtype wrappers when necessary to ensure the above conditions.
-}


{- Performance notes:
   Current implementation presents a purely functional interface.
   Optimization rests entirely on game state / heuristics / ordering.
-}


data Player = PMax | PMin deriving (Eq, Show)

switch :: Player -> Player
switch = \case PMax -> PMin; _ -> PMax

adjustHeu :: Num score => Player -> score -> score
adjustHeu = \case PMax -> id; _ -> negate


type TreeSearch score state state' move =
     Ord score
  => (state -> state')                     -- preprocess state (quiescence / end of game)
  -> (Player -> state' -> [(state, move)]) -- possible moves
  -> (state'-> score)                      -- heuristic
  -> Player                                -- starting player
  -> Int                                   -- max search depth
  -> state                                 -- starting state
  -> (score, Maybe move)                   -- result score, chosen move


minimax :: TreeSearch score state win move
minimax proc moves heu = go
  where
    go p d (proc -> s)
      | d == 0 || null ms = (heu s, Nothing)
      | otherwise         = (score, Just move)
      where
        compute = case p of PMax -> maximumBy; _ -> minimumBy
        ms = moves p s <&> _1 %~ go (switch p) (d - 1)
        ((score, _) , move) = compute (comparing (fst.fst)) ms

    
negamax :: Num score => TreeSearch score state win move
negamax proc moves heu = go
  where
    go p d (proc -> s)
      | d == 0 || null ms = (adjustHeu p $ heu s, Nothing)
      | otherwise         = (score, Just move)
      where
        ms = moves p s <&> _1 %~ (_1 %~ negate) . go (switch p) (d - 1)
        ((score, _) , move) = maximumBy (comparing (fst.fst)) ms    

  
alphaBeta :: Bounded score => TreeSearch score state win move
alphaBeta proc moves heu = go minBound maxBound                           
  where                           
    go alpha beta p d (proc -> s)
      | d == 0 || null ms = (heu s, Nothing)
      | otherwise         = either id fst $ loop ms
      where
        ms   = moves p s
        loop = foldM step ((startBound, Nothing), bound)
        
        (upd, cmp, startBound, bound, stop, goNext) = case p of
          PMax -> (max, (>), minBound, alpha, (beta <=), (`go` beta))
          PMin -> (min, (<), maxBound, beta, (<= alpha), go alpha)
    
        step (best@(bsc, _), bound) (st, mv)
          | stop bound' = Left best'
          | otherwise   = Right (best', bound')
          where
            (sc, _)         = goNext bound (switch p) (d - 1) st
            best'@(bsc', _) = if cmp sc bsc then (sc, Just mv) else best
            bound'          = upd bound bsc'                                   

  
negaAlphaBeta :: (Bounded score, Num score) => TreeSearch score state win move
negaAlphaBeta proc moves heu = go minBound maxBound
  where
    go alpha beta p d (proc -> s)
      | d == 0 || null ms = (adjustHeu p $ heu s, Nothing)
      | otherwise         = either id fst $ loop ms
      where
        ms   = moves p s
        loop = foldM step ((minBound, Nothing), alpha)  
        
        step (best@(bsc, _), alpha) (st, mv)
          | beta <= alpha' = Left best'
          | otherwise      = Right (best', alpha')
          where
            (negate -> sc, _) = go (-beta) (-alpha) (switch p) (d - 1) st
            best'@(bsc', _)   = if sc > bsc then (sc, Just mv) else best
            alpha'            = max alpha bsc'

  
---- tic tac toe

data Cell     = Empty | Filled Player deriving (Eq, Show)
type Move     = (Int, Int)
type GState   = Array Move Cell
type Win      = Maybe Player
newtype Score = Score Int deriving (Eq, Show, Ord, Num)

instance Bounded Score where
  maxBound = Score 1
  minBound = Score (-1)

moves :: Player -> (Win, GState) -> [(GState, Move)]
moves p (Nothing, s) = [(s // [(ix, Filled p)], ix) | (ix, Empty) <- A.assocs s]
moves _ _            = []

size    = 3
ixRange = ((1, 1), (size, size))
start   = A.listArray ixRange $ repeat Empty

proc :: GState -> (Win, GState)
proc s = (wins^?_head, s) where
  horizontal = chunksOf size $ A.elems s
  vertical   = transpose horizontal
  diagonal   = (map . map) (s!)
               [join zip [1..size], (zip <*> reverse) [1..size]]
               
  wins = [ p |
    c@(Filled p):cs <- horizontal ++ vertical ++ diagonal,
    all (==c) cs]         

heu :: (Win, GState) -> Score
heu = maybe 0 (\case PMax -> maxBound; _ -> minBound) . fst

tictac   = alphaBeta proc moves heu PMax
tictac'  = negaAlphaBeta proc moves heu PMax
tictac'' = negamax proc moves heu PMax
           
main = print $ tictac 11 start