I am attempting to implement the Negamax algorithm in Haskell.
For this, I am representing the future possibilities a game might take in a rose tree (Data.Tree.Forest (depth, move, position)). However, often there are positions that can be reached with two different sequences of moves. It is a waste (and quickly becomes very slow) to re-evaluate (the subtrees of) repeated positions.
Here is what I tried so far:
Implement a variant of Tying the Knot to share common sub-results. However, I have only been able to find explanations of tying the knot for (potentially infinite) lists, and nothing about re-using subtrees.
Another approach I have considered was to build a tree inside the
Statemonad, where the state to keep would be aMap (depth, position) (Forest (depth, move, position))to perform explicit memoization but I have so far not been able to set this up properly either.
I think that both approaches might have the problem that a game tree can only be built in a corecursive way: We do not build the tree up to the root from the leaves, but build a (potentially infinite) tree lazily from the root down.
EDIT: To give you an example of the code I am currently using (that is too slow):
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module ZeroSumGame where
import qualified Control.Arrow
import Data.Tree
import Numeric.Natural (Natural)
(|>) :: a -> (a -> b) -> b
x |> f = f x
infixl 0 |>
{-# INLINE (|>) #-}
class Ord s => Game s where
data Move s
initial :: s -- | Beginning of the game
applyMove :: Natural -> s -> Move s -> s -- | Moving from one game state to the next
possibleMoves :: Natural -> s -> [Move s] -- | Lists moves the current player is able to do.
isGameOver :: s -> Bool -- | True if the game has ended. TODO: Maybe write default implementation using `possibleMoves state == []`?
scorePosition :: Natural -> Move s -> s -> Int -- | Turns a position in an integer, for the Negamax algorithm to decide which position is the best.
type Trimove state = (Natural, Move state, state) -- | Depth since start of game, move to next position, new position
gameforest :: Game s => Natural -> s -> Forest (Trimove s)
gameforest start_depth start_state = unfoldForest buildNode (nextpositions start_depth start_state)
where
buildNode (depth, move, current_state) =
if
isGameOver current_state
then
((depth, move, current_state), [])
else
((depth, move, current_state), nextpositions depth current_state)
nextpositions depth current_state =
current_state
|> possibleMoves depth
|> fmap (\move -> (succ depth, move, applyMove depth current_state move))
scoreTree :: Game s => Ord (Move s) => Natural -> Tree (Trimove s) -> (Move s, Int)
scoreTree depth node =
case (depth, subForest node) of
(0, _) ->
node |> rootLabel |> uncurry3dropFirst scorePosition
(_, []) ->
node |> rootLabel |> uncurry3dropFirst scorePosition
(_, children) ->
children
|> scoreForest (pred depth)
|> map (Control.Arrow.second negate)
|> maximum
uncurry3dropFirst :: (a -> b -> c -> d) -> (a, b, c) -> (b, d)
uncurry3dropFirst fun (a, b, c) = (b, fun a b c)
scoreForest :: Game s => Ord (Move s) => Natural -> Forest (Trimove s) -> [(Move s, Int)]
scoreForest depth forest =
forest
|> fmap (scoreTree depth)
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module TicTacToe where
import qualified Control.Monad.State
import Control.Monad.State (State)
import qualified Data.Map
import Data.Map (Map)
import qualified Control.Arrow
import Data.Tree
import Data.Array (Array)
import qualified Data.Array
import qualified Data.Maybe
import qualified Data.Foldable
import Numeric.Natural (Natural)
import ZeroSumGame
data CurrentPlayer = First | Second
deriving (Eq, Ord, Show)
instance Enum CurrentPlayer where
fromEnum First = 1
fromEnum Second = -1
toEnum 1 = First
toEnum (-1) = Second
toEnum _ = error "Improper player"
newtype TicTacToe = TicTacToe (Array (Int, Int) (Maybe CurrentPlayer))
deriving (Eq, Ord)
instance Game TicTacToe where
data Move TicTacToe = TicTacToeMove (Int, Int)
deriving (Eq, Ord, Show, Bounded)
initial = TicTacToe initialTicTacToeBoard
possibleMoves _depth = possibleTicTacToeMoves
applyMove depth (TicTacToe board) (TicTacToeMove (x, y)) =
TicTacToe newboard
where
newboard = board Data.Array.// [((x, y), Just player)]
player = case depth `mod` 2 of
0 -> First
_ -> Second
isGameOver state = Data.Maybe.isJust (findFilledLines state)
scorePosition _ _ state =
state
|> findFilledLines
|> fmap fromEnum
|> Data.Maybe.fromMaybe 0
|> (* (-10000))
findFilledLines :: TicTacToe -> Maybe CurrentPlayer
findFilledLines (TicTacToe board) =
(rows ++ columns ++ diagonals)
|> map winner
|> Data.Foldable.asum
where
rows = vals rows_indexes
columns = vals columns_indexes
diagonals = vals diagonals_indexes
rows_indexes = [[(i, j) | i <- [0..2]]| j <- [0..2]]
columns_indexes = [[(i, j) | j <- [0..2]]| i <- [0..2]]
diagonals_indexes = [[(i, i) ]| i <- [0..2]] ++ [[(i, 2 - i) ]| i <- [0..2]]
vals = map (map (\index -> board Data.Array.! index))
winner :: Eq a => [Maybe a] -> Maybe a
winner [x,y,z] =
if x == y && x == z then x else Nothing
winner _ = Nothing
initialTicTacToeBoard :: (Array (Int, Int) (Maybe CurrentPlayer))
initialTicTacToeBoard =
Data.Array.array ((0, 0), (2, 2)) [((i, j), Nothing) | i <- [0..2], j <- [0..2]]
possibleTicTacToeMoves :: TicTacToe -> [Move TicTacToe]
possibleTicTacToeMoves (TicTacToe board) = foldr checkSquareForMove [] (Data.Array.assocs board)
where
checkSquareForMove (index, val) acc = case val of
Nothing -> TicTacToeMove index : acc
Just _ -> acc
printBoard :: TicTacToe -> String
printBoard (TicTacToe board) =
unlines [unwords [showTile (board Data.Array.! (y, x)) | x <- [0..2]] | y <- [0..2]]
where
showTile loc =
case loc of
Nothing -> " "
Just Second -> "X"
Just First -> "O"
(TypeFamilies is used to allow each Game implementation to have their own notion of a Move, and FlexibleContexts is then required to enforce Move s to implement Ord.
