Eval.hs

{-# LANGUAGE BangPatterns #-}
-- Static evaluation functions of board positions
module AI.Eval( static_eval
              , zoneOfControl
              ) where

import Board
import qualified Data.IntMap as IntMap
import Debug.Trace

-- | Static evaluation function of a position for the active player
static_eval :: Board -> Int
static_eval b
  | least ==0  || null captures  = -infinity
  | least'==0  || null captures' =  infinity
  | otherwise = {- trace (unwords ["material=", show material, 
                                "positional=", show positional,
                                "threats=", show threats]) $ -}
                material + positional + threats
    where
      -- count stacks by piece kind for each player 
      counts = countStacks (active b)
      counts'= countStacks (inactive b)

      -- least count of stacks by kind
      least = minimum counts
      least'= minimum counts'
      
      -- capture moves for each player
      captures = nextCaptureMoves b
      captures'= nextCaptureMoves (swapBoard b)    

      -- stack heights by piece kinds
      heights = sumHeights (active b)

      -- material score 
      material = sum [(mw*h)`div`(c+1) | (c,h)<-zip counts heights]

      zoc = zoneOfControl b         -- zone of control for the active player
      zoc_heights = sumHeights zoc       -- piece types in the zone of control

      -- positional score      
      positional = sum [(pw*h)`div`(c+1) | (c,h)<-zip counts' zoc_heights]
          
      -- immediate threats to opponent pieces
      zoc_counts = countStacks zoc
      threats = sum [tw | (x,y)<-zip counts' zoc_counts, x<=min 2 y]
                
      -- scoreing weights coeficients
      mw = 10  -- material 
      pw = 50  -- positional
      tw = 1000  -- threats 
                



-- sum of heights of stacks for each kind
sumHeights :: HalfBoard -> [Int]
sumHeights b = sum 0 0 0 (IntMap.elems b)
  where sum :: Int -> Int -> Int -> [Piece] -> [Int]
        sum !x !y !z ((Tzaar,h):ps)  = sum (x+h) y z ps
        sum !x !y !z ((Tzarra,h):ps) = sum x (y+h) z ps
        sum !x !y !z ((Tott,h):ps)   = sum x y (z+h) ps
        sum !x !y !z []              = [x,y,z]


-- maximum heights of stacks for each kind
maxHeights :: HalfBoard -> [Int]
maxHeights b = maxh 0 0 0 (IntMap.elems b)
    where maxh :: Int -> Int -> Int -> [Piece] -> [Int]
          maxh !x !y !z ((Tzaar,h):ps)  = maxh (x`max`h) y z ps
          maxh !x !y !z ((Tzarra,h):ps) = maxh x (y`max`h) z ps
          maxh !x !y !z ((Tott,h):ps)   = maxh x y (z`max`h) ps
          maxh !x !y !z []              = [x,y,z]


-- Estimate the zone of control of the active player
-- i.e., the set of opponent pieces reachable in a turn (two capture moves)
zoneOfControl ::  Board -> HalfBoard
zoneOfControl board
    = IntMap.filterWithKey forPiece1 other
    where
      you   = active board
      other = inactive board
      who   = whiteTurn board
      -- white pieces that can make at least one capture
      captures = IntMap.filterWithKey forPiece2 you

      forPiece1, forPiece2 :: Position -> Piece -> Bool
      forPiece1 p (_, i) = or $ map (downLine0 i) $ sixLines p
      forPiece2 p (_, h) = or $ map (downLine2 h) $ sixLines p

      downLine0, downLine1, downLine2 :: Int -> [Position] -> Bool

      downLine0 i [] = False
      downLine0 i (p:ps) 
          = case atPosition board p of
              Nothing -> downLine0 i ps
              Just (who', (_, h)) | who'==who -> 
                  h>=i || (p`IntMap.member`captures && downLine1 i ps)
              Just (_, (_, j)) -> 
                  or $ map (downLine1 (max i j)) $ sixLines p

      downLine1 i [] = False
      downLine1 i (p:ps) 
          = case atPosition board p of
              Nothing -> downLine1 i ps
              Just (who', (_, h)) | who'==who -> h>=i
              _ -> False

      downLine2 h [] = False
      downLine2 h (p:ps) 
          = case atPosition board p of
              Nothing -> downLine2 h ps
              Just (who', (_, i)) | who'/=who -> h>=i
              _ -> False



{-
--- material-only evaluation 
---------------------------------------------------------------------------------
material_value :: Board -> Int
material_value b@(Board _ whites blacks)
    | least==0 || null captures = -infinity
    | least'==0 || null captures'= infinity
    | otherwise = w1*least^2 + w2*tscore + w3*pscore + round (w4*sscore)
    where
      captures = nextCaptureMoves b
      captures'= nextCaptureMoves (swapBoard b)
      kinds = [IntMap.filter ((==t).fst) whites | t<-[Tzaar,Tzarra,Tott]]
      kinds'= [IntMap.filter ((==t).fst) blacks | t<-[Tzaar,Tzarra,Tott]]
      counts = map IntMap.size kinds    -- stack count by kind
      counts'= map IntMap.size kinds'   -- stack count by kind
      least  = minimum counts         -- least count of any kind
      least'  = minimum counts'        -- least count of any kind
      heights = map sumSquareHeights kinds  -- sum of heights by kind
      tallest = map maxHeights kinds   -- tallest by kind
      -- scores
      tscore = sum (map (^2) tallest)
      pscore = sum (zipWith (*) counts heights)
      sscore :: Double
      sscore = sum [fromIntegral (count-least)/fromIntegral (count+1) | count<-counts]
      -- weights
      w1 = 5
      w2 = 1
      w3 = 1
      w4 = 10
-}