Minimax.hs

{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}

module AI.Minimax
   ( 
    Value
   , searchMove
   , negamax
   , alphaBeta
   , negascout
   , jamboree
   ) where

import AI.Gametree
import Data.List (minimumBy, maximumBy)
import Data.Function (on)
import Control.Parallel.Strategies

-- | a type for game position valuations;
-- simply a wrapper newtype over integers
newtype Value = Value Int deriving (Eq, Ord, Enum, Bounded,
                                    Num, Real, Integral, Show, Read)



-- compute best move using some search function
-- undefined for terminal positions
searchMove :: Transitions s l =>
              (Value -> Value -> Int -> s -> Value)
              -> Int -> s -> (l, Value)
searchMove abSearch depth s = cmx (minBound+1) first (transitions s)
  where
    first = head (actions s)
    cmx !alpha best [] = (best, alpha)
    cmx !alpha best ((l,s):rest) = cmx alpha' best' rest
        where !v = - abSearch (-maxBound) (-alpha) (depth-1) s
              !alpha' = if v>alpha then v else alpha
              !best' = if v>alpha then l else best


-- | Naive negamax algorithm (no alpha-beta prunning)
-- for specification only; use alphaBeta instead
negamax :: Transitions s l => (s -> Value) -> Int -> s -> Value
negamax valf = negamaxAux
  where
    -- recursive worker function
    negamaxAux d s
      | d==0 || isTerminal s = valf s
      | otherwise = - minimum [negamaxAux (d-1) s' | s' <- successors s]



-- compute minimax value using Negamax with alpha-beta prunning
alphaBeta :: Transitions s l =>
             (s -> Value) -> Value -> Value -> Int -> s -> Value
alphaBeta valf alpha beta depth s
  | depth==0 || isTerminal s = valf s
  | otherwise = cmx alpha (successors s)
  where
    cmx !alpha [] = alpha
    cmx !alpha (p:ps)
      | a'>=beta = a'
      | otherwise = cmx (max a' alpha) ps
        where a' = - alphaBeta valf (-beta) (-alpha) (depth-1) p





-- Negascout search
-- worker function
negascout :: Transitions s l =>
             (s -> Value) -> Value -> Value -> Int -> s -> Value
negascout valf alpha beta depth s
  | depth==0 || isTerminal s = valf s
  | depth==1  = - valf s0  -- short-circuit for depth 1
  | b >= beta = b
  | otherwise = scout (max alpha b) b succs
    where
      succs = successors s
      s0 = minimumBy (compare`on`valf) succs
        -- child with best static score
      b = - negascout valf (-beta) (-alpha) (depth-1) s0
        -- full search estimate for the best child

      scout !alpha !b [] = b
      scout !alpha !b (p:ps)
        | s>=beta = s
        | otherwise = scout alpha' b' ps
          where s = - negascout valf (-(1+alpha)) (-alpha) (depth-1) p
                s' | s>alpha = - negascout valf (-beta) (-alpha) (depth-1) p
                   | otherwise = s
                alpha' = max alpha s'
                b' = max b s'



-- | Parallel negascout, aka "Jamboree"
-- | result of each scout test
data Result a b = Cutoff a   -- beta cutoff found
                | Search b   -- do a full search
                | OK         -- test suceeded



jamboree :: Transitions s l =>
            (s -> Value) -> Value -> Value -> Int -> s -> Value
jamboree valf alpha beta depth p
  | depth<=1 = negascout valf alpha beta depth p
            -- use sequencial version for low depth
  | isTerminal p = valf p   -- terminal node?
  | b >= beta = b           -- 1st child failed high
  | otherwise = cutoff [] (map scout ps `using` parList rseq)
    where
      ps = successors p
      p0 = minimumBy (compare`on`valf) ps      -- estimated best child
      b =  - jamboree valf (-beta) (-alpha) (depth-1) p0  -- full search estimate
      alpha' = max alpha b

      scout p
        | s >= beta = Cutoff s
        | s > alpha' = Search p
        | otherwise = OK
          where s = - jamboree valf (-(1+alpha')) (-alpha') (depth-1) p
                    -- null window search

      -- join results of parallel scouts
      cutoff _  (Cutoff s : rs) = s
      cutoff ps (Search p : rs) = cutoff (p:ps) rs
      cutoff ps (OK : rs)       = cutoff ps rs
      cutoff ps []              = search alpha' b ps

      -- sequential full search for scout failures
      search !alpha !b [] = b
      search !alpha !b (p : ps)
        | s >= beta = s
        | otherwise = search (max s alpha) (max s b) ps
          where s = - jamboree valf (-beta) (-alpha)  (depth-1) p