tak-ai-0.1.0.1: src/Negamax.hs

{-# LANGUAGE TypeFamilies, FlexibleInstances, BangPatterns #-}
module Negamax (
    Game(..),
    chooseplay
) where

import Data.List

class Game a where
    type Play a :: * -- ^ A play in the game.
    plays :: a -> [(Play a, a)] -- ^ All possible plays from a given game state,
                                --   and their successor states.
    eval :: a -> Double -- ^ An assessment of how good the current game state looks.
    ourmove :: a -> Bool -- ^ Whether the next play is ours or our opponents.
    finished :: a -> Bool -- ^ Whether the game has finished.

chooseplay
    :: (Show a, Game a)
    => Int -- ^ Number of levels to look ahead.
    -> a -- ^ The game state
    -> (Play a, a, Double) -- ^ The chosen play, successor state, and the
                           --   corresponding maximised minimum score
chooseplay levels state
    | length (plays state) == 0 = error $ "No plays from " ++ show state
    | otherwise = (play, nextState, score)
    where (_, _, score, Just (play, nextState), _) = chooseplay' levels state (-1e101) 1e101

maxGuaranteedScore
    :: (Game a, Show a)
    => Int -- ^ Number of levels to look ahead.
    -> a -- ^ The game state
    -> Double -- ^ The current maximum score that we are guaranteed
    -> Double -- ^ The minimum score that our opponent is guaranteed
    -> Double -- ^ The maximum guaranteed score
maxGuaranteedScore levels state alpha beta
    | levels <= 0 = eval state
    | length (plays state) == 0 = eval state
    | otherwise = score
    where (_, _, score, _, _) = chooseplay' levels state alpha beta

chooseplay'
    :: (Game a, Show a)
    => Int
    -> a
    -> Double
    -> Double
    -> (Double, Double, Double, Maybe (Play a, a), Int)
chooseplay' levels state alphaStart betaStart = bestScore
    where
        bestScore = foldl evalPlay (alphaStart, betaStart, initScore, Nothing, 0) sortedPlays
        initScore
            | ourmove state = -1e101
            | otherwise = 1e101
        evalPlay (alpha, beta, minimax, bestState, count) (play, nextState) =
            let score = maxGuaranteedScore (levels - 1) nextState alpha beta
                (minimax', bestState') = if ourmove state
                    then if score > minimax
                        then (score, Just (play, nextState))
                        else (minimax, bestState)
                    else
                        if score < minimax
                            then (score, Just (play, nextState))
                            else (minimax, bestState)
                alpha' = if ourmove state
                    then max alpha minimax'
                    else alpha
                beta' = if ourmove state
                    then beta
                    else min beta minimax'
            in
            if count > 100
                then (alpha, beta, minimax, bestState, count)
                else if beta <= alpha
                    then (alpha, beta, minimax, bestState, count)
                    else (alpha', beta', minimax', bestState', count + 1)
        sortedPlays =
            map fst $ sortPlays (not $ ourmove state) $ zip ps estimates
        estimates = map (\ s -> maxGuaranteedScore (levels - 2) s (-1e101) 1e101) states
        states = map snd ps
        ps = plays state

sortPlays :: Bool -> [(a, Double)] -> [(a, Double)]
sortPlays invert = sortBy $ \ (_, a) (_, b) ->
    if invert then compare a b else compare (-a) (-b)