{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE NumericUnderscores #-} module Exercise08 ( -- * Stock types Player, Field, Row, Column, Board, Pos, Size, -- * Stock operations updatePos, canPlaceOrb, hasWon, getCell, putOrb, neighbors, strategyState, play, playAndPrint, defaultSize, -- * Stock strategy definitions and helpers Strategy, StatefulStrategy, StatefulStrategyFunc, wrapStrategy, -- * Strategies searchStrategy, searchStrategy', abSearch, abSearchCPS, dlimSearch', -- ** A/B search helper types GameAction(..), INode(..), ABNode(..), SearchState(..), TranspositionTable(..), KillerMoveTable, SearchType(..), lookupHashMove, insertKiller, lookupKiller, -- * Various types PlayerU(..), Value(..), Noise(..), Depth(..), Move(..), Neighbors(..), applyMoveB, applyMoveU, -- * Board operations -- ** The MetaBoard MetaBoard(..), defaultMetaboard, -- ** The UBoard and associated types UBoard(..), BoardIdx(..), IdxType, FieldU, -- *** Constructing and deconstructing makeUBoard, unmakeUBoard, -- *** UBoard major operations sizeU, putOrbU, hasWonU, emptyBoard, -- ** The BitBoard and associated types BitBoard(..), BitBoardIdx(..), -- *** Constructing and deconstructing makeBitBoard, unmakeBitBoard, -- *** BitBoard major operations getCellB, putOrbB, hasWonB, bitNbs, -- *** Predefined and generated masks bitBoardMask, wouldOverflow, edgeMask, borderMask, playerFieldMask, -- *** BitBoard utilities bbIdx, playerSignBit, -- *** Bit mask operations ffsSplit, ffsIdx, maskToList, -- * Move generators ClassifiedMoves(..), MGResult, MoveGenerator, MoveGeneratorB, defaultMGU, defaultMGB, quiescentMGU, quiescentMGB, -- * Utilities showBoard, printBoard ) where import Control.Monad import Control.Monad.ST import Data.Bits hiding (bit, clearBit, testBit) import Data.Int ( Int8, Int16, Int32 ) import Data.Ix ( Ix(..) ) import Data.List import Data.Ord import Data.STRef.Strict import Data.Word (Word64) import System.Random (mkStdGen, randoms, randomIO, Random) import GHC.Generics ( Generic ) import Data.Array.Unboxed ( Array, IArray, UArray, (!), (//), elems, assocs, array, listArray ) import Data.Array.ST.Safe ( MArray(getBounds), STUArray, runSTUArray, freeze, thaw, readArray, writeArray ) import qualified Data.IntMap.Strict as IM import qualified Data.HashMap.Strict as HM import Data.Hashable {- import Debug.Trace (traceShowId, trace, traceM, traceEvent, traceEventIO, traceMarker, traceMarkerIO) -} {-MCCOMMENT This solution is essentialy just a rather optimized alpha-beta search. Rather than explaining all the different variations in detail, I am just going to give a coarse outline of the different techniques I used. There are excellent resources (including Wikipedia and the Chess Programming Wiki) that explain the rationale behind the optimizations. 1. Alpha/Beta Search: Please look up this up elsewhere, it would be out of scope for this comment. 2. Transposition Tables: For every board state we encounter, we save the it in a hash table (the transposition table). When considering moves given a certain board, we check for any moves in the transposition table as well as the old table from our previous move. If we get a hit, we check this move (called the hash move) first, before all other moves generated by the move generator. Note that in theory you could also save the Alpha/Beta-Window in the table and directly accept a move (if we found a PV-move previously) or reject a move (if it generated a cutoff previously). However, that is a recipe for disaster in my experience, since this leads to considerable search instability (non-repeatable search results) and overall impairs the AI's performance. There might be some outstanding bugs in my code that cause this, but reducing instability turns out to be rather hard. In other words, this is memoization/dynamic programming. 3. Iterative Deepening: Instead of search at full depth immediately, we increase the depth by one in multiple iterations until we reach the final depth. This only makes sense in combination with transposition tables. 4. Bitboards: It turns out we can efficiently represent the entire board state using only three 64 bit words. It also turns out that bitboards are an excellent way to create very obscure (yet performant) code, so I suggest you try to avoid all bitboard functions (ending with a B) unless you have too much time. They mostly have a non-B equivalent, so you don't need to actually understand what's going on with the bitboards in order to understand the search algorithm. 5. Killer Move Heuristic: We save all moves that generated a cutoff, and consider those moves (killer moves) right after the hash move. This is based on the assumption that killer moves have a high probability of causing a cutoff again, saving us time. 6. Aspiration Windows Instead of beginning with an open Alpha/Beta window of [-Infinity, Infinity], we begin with a rather narrow window and re-search if we fail high or low. We essentially gamble that the search returns a result in a certain range, but if the guess turns out to be wrong, we pay the high price of having to search again. Obviously, this is also a giant cause of search instability, but the increased performance should be worth it. Possible improvements/techniques I considered, but did not implement in the end: 1. Null move pruning/ProbCut (not applicable since a rather shallow search is enough for this game) 2. Late Move Reductions (same as null move pruning: only useful for higher depths) 3. History Heuristic (overlap with killer heuristic, questionable gain) 4. NegaMax framework (high risk of bugs during the conversion to NegaMax I didn't want to take) Note that this module contains a very interesting optimization I did not complete successfully in time: A continuation-passing style (CPS) version of abSearch called abSearchCPS. It actually works, but for some reason (i.e. bug) it performs measurably worse (playing strength-wise) than the non-CPS version. It should be a worthwile optimization though because this sort of algorithm fits CPS perfectly. A short explanation: CPS is essentially an inversion of the traditionall function return flow. Normally, a function callee returns a return value to the caller. With CPS, the caller passes the callee a number of continuations (functions that operate on the *return value* of the callee) and instead of just "returning" a return value, the callee calls one of the continuations with its return value. Further notes: - An unfinished optimization is porting of the defaultMGU to the BitBoard-based defaultMGB, that's why both exist. - That's also the reason for the parallel UBoard and BitBoard hierarchy. I retained UBoards because they are a bit more reliable than BitBoards, the latter have had their fair share of bugs in the past and I needed a known good implementation. - There are a few functions floating around this file that implement unsafe variations of other functions. This does not mean anything wonky is happening, these function only elide some extra checks that should be superfluous (as long as there are absolutely no bugs in other functions, which is obviously the case, right??) Suggested reading order: 1. Start with generating the Haddock documentation for this module, and skim it briefly. 2. Read the definition of dlimSearch', which is the original, simple search algorithm I used. It does not perform alpha-beta pruning, but the general structure is comparable to the actual alpha-beta function, so it should help getting the general idea across. 3. Familiarize yourself with the definitions of applyMoveB and the move generator defaultMGU. 3. Read the definitions of the ABNode and INode types 4. At this point, I suggest reading the actual abSearch function. However, if you are familiar with CPS, it might actually be easier to read the CPS version (abSearchCPS) first, as some concepts are more visible in the CPS version. (Possibly confusing) naming conventions: - biber: Refers to a BitBoard - ub/bb: Refers to a UBoard - suffix U: function operating on UBoards - suffix B: function operating on BBoards - suffix 0: the initial version of a binding - suffix 1: the new/updated version of a binding - prefix un: refers to the accessor function of a newtype -} {-WETT-} {-# INLINE trace #-} trace :: String -> a -> a trace _ = id {-# INLINE traceM #-} traceM :: Applicative f => String -> f () traceM _ = pure () {-# INLINE traceEvent #-} traceEvent :: String -> a -> a traceEvent _ = id {-# INLINE traceEventIO #-} traceEventIO :: String -> IO () traceEventIO _ = pure () {-# INLINE traceMarker #-} traceMarker :: String -> a -> a traceMarker _ = id {-# INLINE traceMarkerIO #-} traceMarkerIO :: String -> IO () traceMarkerIO _ = pure () {-# INLINE traceShowId #-} traceShowId :: a -> a traceShowId = id -- | Player is either 1 or -1 type Player = Int -- | A field is just an Int value where the absolute gives the number of pieces on the field -- and the sign corresponds to the player -- e.g. -3 would mean there are three blobs in this field of player -1 type Field = Int type Row = [Field] type Column = [Field] -- | boards are rectangles represented as a list of rows type Board = [Row] -- | A position on the board is represented as (row, column) -- (0,0) is the top left corner, coordinate values increase towards the bottom right type Pos = (Int, Int) -- | A size represented as (height,width) type Size = (Int, Int) -- | A strategy takes the player who's move it is, optionally takes a list of double values -- to allow for probabilistic strategies, takes the current board and gives back the position -- of the move the player should do type Strategy = [Double] -> Player -> Board -> Pos -- | A stateful strategy can additionally pass some object between invocations type StatefulStrategyFunc a = a -> [Double] -> Player -> Board -> (Pos, a) -- | first value is the state object to pass to the first invocation of each game type StatefulStrategy a = (a, StatefulStrategyFunc a) defaultSize :: (Int, Int) defaultSize = (9,6) -- Some useful helper functions row :: Board -> Int -> Row row = (!!) column :: Board -> Int -> Column column = row . transpose width :: Board -> Int width (x : _) = length x width _ = 0 height :: Board -> Int height = length size :: Board -> Size size b = (height b, width b) -- | Get a single cell getCell :: Pos -> Board -> Field getCell (y, x) b = b !! y !! x -- pretty print a single cell showCell :: Field -> String showCell c = "- +" !! succ (signum c) : show (abs c) -- pretty print the given board showBoard :: Board -> String showBoard = unlines . map (unwords . map showCell) -- print a board to the console printBoard :: Board -> IO () printBoard = putStr . showBoard -- check if a position is one a board of the given size isValidPos :: Size -> Pos -> Bool isValidPos (r, c) (y, x) = y >= 0 && y < r && x >= 0 && x < c {- x.1 -} -- | Check if the given player can put an orb on the given position canPlaceOrb :: Player -> Pos -> Board -> Bool canPlaceOrb p pos b = content == 0 || signum content == signum p where content = getCell pos b -- | Check if the given player has won the game, -- you can assume that the opponent has made at least one move before hasWon :: Player -> Board -> Bool hasWon p b = if res then traceW ("player=" ++ show p ++ " has won") res else res where traceW _ = id res = all check b check :: Row -> Bool check = all (\x -> x == 0 || signum x == signum p) -- | the list of neighbors of a cell neighbors :: Size -> Pos -> [Pos] neighbors bsize (y, x) = alls where alls = filter (isValidPos bsize) [ (y+1, x), (y-1, x), (y, x-1), (y, x+1) ] -- | Calculate neighbors for the static neighbor table neighborsGenU :: Size -> BoardIdx -> Neighbors neighborsGenU (fromIntegral -> r, fromIntegral -> c) (BoardIdx y x) = convert alls where isValidPosU :: BoardIdx -> Bool isValidPosU (BoardIdx iy ix) = iy >= 0 && iy < r && ix >= 0 && ix < c convert :: [BoardIdx] -> Neighbors convert (n1:n2:n3:n4:[]) = FourNeighbors n1 n2 n3 n4 convert (n1:n2:n3:[]) = ThreeNeighbors n1 n2 n3 convert (n1:n2:[]) = TwoNeighbors n1 n2 convert _ = error "unreachable" alls = filter isValidPosU [ BoardIdx (y+1) x , BoardIdx (y-1) x , BoardIdx y (x-1) , BoardIdx y (x+1) ] chunksOf :: Int -> [e] -> [[e]] chunksOf _ [] = [] chunksOf i ls = take i ls : chunksOf i (drop i ls) -- | The inner type for UBoard fields type FieldU = Int8 -- | The inner type used for UBoard indices type IdxType = Int8 -- | An index on a UBoard data BoardIdx = BoardIdx { idxY :: {-# UNPACK #-} !IdxType , idxX :: {-# UNPACK #-} !IdxType } deriving (Eq, Ord, Show, Generic) posToIdx :: Pos -> BoardIdx posToIdx (fromIntegral -> y, fromIntegral -> x) = BoardIdx y x idxToPos :: BoardIdx -> Pos idxToPos (BoardIdx y x) = (fromIntegral y, fromIntegral x) {- For future reference: {-# INLINE safeIndex #-} safeIndex :: (BoardIdx, BoardIdx) -> BoardIdx -> Int safeIndex b@(BoardIdx lba lbb, BoardIdx uba ubb) i@(BoardIdx qa qb) | inRange b i = fromIntegral (qa - lba) * fromIntegral(ubb - lbb + 1) + fromIntegral (qb - lbb) | otherwise = error "out of range" {-# INLINE unsafeIndex #-} -- assume: index in range, lower bound always zero unsafeIndex :: (BoardIdx, BoardIdx) -> BoardIdx -> Int unsafeIndex (_, BoardIdx _ !ubb) (BoardIdx !qa !qb) = fromIntegral qa * fromIntegral (ubb + 1) + fromIntegral qb -} instance Ix BoardIdx where {-# INLINE range #-} range (BoardIdx lba lbb, BoardIdx uba ubb) = [ BoardIdx a b | a <- [lba..uba], b <- [lbb..ubb] ] {-# INLINE index #-} index (_, BoardIdx _ !ubb) (BoardIdx !qa !qb) = fromIntegral qa * fromIntegral (ubb + 1) + fromIntegral qb {-# INLINE inRange #-} inRange (BoardIdx lba lbb, BoardIdx uba ubb) (BoardIdx qa qb) = (lba <= qa && qa <= uba) && (lbb <= qb && qb <= ubb) -- | Explicitly encoded neighbor list data Neighbors = TwoNeighbors !BoardIdx !BoardIdx | ThreeNeighbors !BoardIdx !BoardIdx !BoardIdx | FourNeighbors !BoardIdx !BoardIdx !BoardIdx !BoardIdx deriving (Eq, Ord, Show, Generic) {-# INLINE antiConvert #-} antiConvert :: Neighbors -> [BoardIdx] antiConvert = \case TwoNeighbors n1 n2 -> [n1, n2] ThreeNeighbors n1 n2 n3 -> [n1, n2, n3] FourNeighbors n1 n2 n3 n4 -> [n1, n2, n3, n4] -- | The MetaBoard encodes static properties of a board data MetaBoard = MetaBoard { ubHeight :: {-# UNPACK #-} !IdxType , ubWidth :: {-# UNPACK #-} !IdxType , nbcLut :: !(UArray BoardIdx FieldU) , neighborLut :: !(Array BoardIdx Neighbors) } deriving (Eq, Ord, Show, Generic) -- | The UBoard is an optimized board representation newtype UBoard = UBoard { unUBoard :: UArray BoardIdx FieldU } deriving (Eq, Ord, Show, Generic) -- | STUBoards are the inner arrays of a UBoard, as a mutable 'STUArray type STUBoard s = STUArray s BoardIdx FieldU instance (Ix i, Hashable a) => Hashable (Array i a) where hashWithSalt s arr = foldl' hashWithSalt s $ elems arr instance (Ix i, IArray UArray a, Hashable a) => Hashable (UArray i a) where hashWithSalt s arr = foldl' hashWithSalt s $ elems arr instance Hashable BoardIdx instance Hashable Neighbors instance Hashable MetaBoard instance Hashable UBoard {-# RULES "unmake/make" forall b. unmakeUBoard (makeUBoard b) = b ; "make/unmake" forall b. makeUBoard (unmakeUBoard b) = b #-} -- | Generate a 'UBoard' from a stock 'Board' {-# INLINE [1] makeUBoard #-} makeUBoard :: Board -> (MetaBoard, UBoard) makeUBoard b = (MetaBoard (fromIntegral r) (fromIntegral c) nbclut nblut, UBoard b') where b' = listArray bounds . fmap fromIntegral . concat $ b bounds = size2bounds sz sz@(r, c) = size b nbclut = array bounds [ (i, neighborCountm1 (r-1) (c-1) i) | i <- range bounds] nblut = array bounds [ (i, neighborsGenU sz i) | i <- range bounds] -- | Generate a standard 'Board' from 'UBoard' {-# INLINE [1] unmakeUBoard #-} unmakeUBoard :: (MetaBoard, UBoard) -> Board unmakeUBoard (MetaBoard _ c _ _, UBoard b) = chunksOf (fromIntegral c) . fmap fromIntegral $ elems b size2bounds :: Size -> (BoardIdx, BoardIdx) size2bounds (r, c) = (BoardIdx 0 0, BoardIdx (fromIntegral $ r-1) (fromIntegral $ c-1)) -- | 'UBoard'/'MetaBoard' version of 'size sizeU :: MetaBoard -> Size sizeU (MetaBoard r c _ _) = (fromIntegral r, fromIntegral c) -- unsafe version of some bit manipulation utilities (they use unsafeShiftL, i.e. don't check for overflow) {-# INLINE bit #-} bit :: (Bits a, Num a) => Int -> a bit = \i -> 1 `unsafeShiftL` i {-# INLINE clearBit #-} clearBit :: (Bits a, Num a) => a -> Int -> a x `clearBit` i = x .&. complement (bit i) {-# INLINE testBit #-} testBit ::(Bits a, Num a) => a -> Int -> Bool testBit = \x i -> (x .&. bit i) /= 0 -- | A compact representation of a default-sized board. -- -- Essentially, this is an array of two-bit values with a single sign bit, but every word encodes a certain bit of all fields. data BitBoard = BitBoard { sign :: {-# UNPACK #-} !Word64 -- ^ Sign word that encodes the player ownership of each field , data1 :: {-# UNPACK #-} !Word64 -- ^ Data word that encodes the least significant bit of the value of each field , data2 :: {-# UNPACK #-} !Word64 -- ^ Data word that encodes the most significant bit of the value of each field } deriving (Eq, Ord, Show, Generic) instance Hashable BitBoard -- | An index on a 'BitBoard' (a number between 0 and 53, inclusive) newtype BitBoardIdx = BitBoardIdx { unBitBoardIdx :: Int } deriving (Eq, Show) -- | 'MetaBoard' of a board with 'defaultSize' defaultMetaboard :: MetaBoard defaultMetaboard = fst $ makeUBoard $ emptyBoard defaultSize {-# RULES "unmakeB/makeB" forall b. unmakeBitBoard (makeBitBoard b) = b ; "makeB/unmakeB" forall b. makeBitBoard (unmakeBitBoard b) = b #-} -- | Convert a 'UBoard' to a 'BitBoard'. -- -- N.B. This assumes that the UBoard is of defaultSize {-# INLINE [1] makeBitBoard #-} makeBitBoard :: UBoard -> BitBoard makeBitBoard (UBoard u) = as where as = foldr apply (BitBoard 0 0 0) $ assocs u validContent x = abs x <= 3 apply (bbIdx -> BitBoardIdx idx, fv) (BitBoard s d1 d2) -- | not (validContent fv) = error $ "content" ++ show fv ++ -- " biber=\n" ++ showBoard (unmakeUBoard (defaultMetaboard, ub)) | idx >= totalSize = error "dim" | otherwise = BitBoard s' d1' d2' where fv' = min 3 $ abs fv -- fromIntegral fv fv1 = if testBit fv' 0 then 1 else 0 -- (fv' .&. 0b01) fv2 = if testBit fv' 1 then 1 else 0 -- (fv' .&. 0b10) `unsafeShiftR` 1 s' = s .|. (signBit fv `unsafeShiftL` idx) d1' = d1 .|. (fv1 `unsafeShiftL` idx) d2' = d2 .|. (fv2 `unsafeShiftL` idx) signBit :: FieldU -> Word64 signBit x = if x < 0 then 1 else 0 totalSize = fromIntegral $ r * c (MetaBoard r c _ _) = defaultMetaboard -- | 'BitBoard' version of 'getCell' {-# INLINE getCellB #-} getCellB :: BitBoard -> BoardIdx -> Int8 getCellB (BitBoard s d1 d2) (bbIdx -> BitBoardIdx idx) = applySign $ fromIntegral d where applySign = if testBit s idx then negate else id d = d1I .|. d2I d1I = (d1 `unsafeShiftR` idx) .&. 1 d2I = ((d2 `unsafeShiftR` idx) .&. 1) `unsafeShiftL` 1 getCellDataB :: BitBoard -> BoardIdx -> Int8 getCellDataB (BitBoard _ d1 d2) (bbIdx -> BitBoardIdx idx) = fromIntegral d where d = d1I .|. d2I d1I = (d1 `unsafeShiftR` idx) .&. 1 d2I = ((d2 `unsafeShiftR` idx) .&. 1) `unsafeShiftL` 1 -- | 'BitBoard' version of 'hasWon' hasWonB :: PlayerU -> BitBoard -> Bool hasWonB MaxPlayer (BitBoard s _ _) = s == 0 hasWonB MinPlayer (BitBoard s d1 d2) = anyV .&. (s `xor` anyV) == 0 where anyV = d1 .|. d2 -- | Convert a standard board index to a bit board index bbIdx :: BoardIdx -> BitBoardIdx bbIdx (BoardIdx y x) = BitBoardIdx $ fromIntegral y * c + fromIntegral x where c = 6 unbbIdx :: BitBoardIdx -> BoardIdx unbbIdx (BitBoardIdx bbi) = BoardIdx (fromIntegral q) (fromIntegral r) where (q, r) = bbi `divMod` c -- totalSize = fromIntegral $ r * c -- (MetaBoard _ c _ _) = defaultMetaboard c = 6 -- | Index of the first set bit ffsIdx :: Word64 -> BitBoardIdx ffsIdx = BitBoardIdx . countTrailingZeros -- | Split on the first set bit: Return the index of the first set bit and the updated mask with the corresponding bit cleared. {-# INLINE ffsSplit #-} ffsSplit :: Word64 -> (BitBoardIdx, Word64) ffsSplit mask = (BitBoardIdx idx, clearBit mask idx) where idx = countTrailingZeros mask updateSingle :: BitBoardIdx -> Word64 -> Word64 -> Word64 updateSingle (BitBoardIdx _) _ val | val > 1 = error "val out of range" updateSingle (BitBoardIdx bitidx) x val = (x .&. complement (bit bitidx)) .|. (val `unsafeShiftL` bitidx) -- | Convert a 'BitBoard' to a 'UBoard'. {-# INLINE [1] unmakeBitBoard #-} unmakeBitBoard :: BitBoard -> UBoard unmakeBitBoard bb = UBoard $ array bds els where els = [ (idx, getCellB bb idx) | idx <- range bds ] bds = size2bounds (fromIntegral r, fromIntegral c) (MetaBoard r c _ _) = defaultMetaboard -- | Sign bit corresponding to the player playerSignBit :: PlayerU -> Word64 playerSignBit MaxPlayer = 0 playerSignBit MinPlayer = 1 -- | Mask of all fields that belong to a certain player playerFieldMask :: PlayerU -> BitBoard -> Word64 playerFieldMask player (BitBoard s d1 d2)= bitBoardMask .&. playerMask .&. anyV where playerMask = playerMinMax s (complement s) player anyV = d1 .|. d2 -- | Generate a bit mask of all neighbors of the given field bitNbs :: BitBoardIdx -> Word64 -- bitNbs (BitBoardIdx i) | i >= 54 = error $ "idxerr idx=" ++ show i bitNbs (BitBoardIdx i) = nbs .&. bitBoardMask where bb = bit i rankSelector = fromIntegral $ i `div` c rankMask = 0b111_111 `unsafeShiftL` (c * rankSelector) b1 = rankMask .&. (bb `unsafeShiftL` 1) b2 = rankMask .&. (bb `unsafeShiftR` 1) b3 = (bb `unsafeShiftL` c) b4 = (bb `unsafeShiftR` c) nbs = b1 .|. b2 .|. b3 .|. b4 c = 6 countOwnNbs :: PlayerU -> BitBoard -> BitBoardIdx -> Int countOwnNbs player biber@(BitBoard s d1 d2) idx@(BitBoardIdx i) = popCount setNbs where nbs = bitNbs idx anyV = d1 .|. d2 -- playerFields = playerMinMax s (complement s) player playerFields = playerFieldMask player biber setNbs = playerFields .&. nbs .&. anyV data Carry3 = Carry3 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# INLINE satAdd #-} satAdd :: Bool -> BitBoardIdx -> Carry3 -> Carry3 satAdd addOne (BitBoardIdx bitidx) (Carry3 d1 d2 carry) = Carry3 d1' d2' carry' where bbi = bit bitidx bbi1 = bit $ bitidx + 1 bbi2 = bit $ bitidx + 2 bitmask = complement bbi dex1 = d1 .&. bbi dex2 = (d2 .&. bbi) `unsafeShiftL` 1 oldcarry = carry .&. bbi d = dex1 .|. dex2 d' = d + (if addOne then bbi + oldcarry else oldcarry) newcarry = (d' .&. bbi2) `unsafeShiftR` 2 dux1 = d' .&. bbi dux2 = (d' .&. bbi1) `unsafeShiftR` 1 d1' = (d1 .&. bitmask) .|. dux1 d2' = (d2 .&. bitmask) .|. dux2 carry' = (carry .&. bitmask) .|. newcarry satAddNC :: BitBoardIdx -> Carry3 -> Carry3 satAddNC (BitBoardIdx bitidx) (Carry3 d1 d2 _) = Carry3 d1' d2' 0 where bbi = bit bitidx bbi1 = bit $ bitidx + 1 bitmask = complement bbi dex1 = d1 .&. bbi dex2 = (d2 .&. bbi) `unsafeShiftL` 1 d = dex1 .|. dex2 d' = d + bbi dux1 = d' .&. bbi dux2 = (d' .&. bbi1) `unsafeShiftR` 1 d1' = (d1 .&. bitmask) .|. dux1 d2' = (d2 .&. bitmask) .|. dux2 -- | Convert a bitmask to a list of all set bits maskToList :: Word64 -> [BitBoardIdx] maskToList = go where go 0 = [] go mask = bbi : go mask' where (bbi, mask') = ffsSplit mask singleOverflow :: PlayerU -> BitBoardIdx -> [BitBoardIdx] -> BitBoard -> (BitBoard, [BitBoardIdx], [BitBoardIdx]) singleOverflow !player !bbi@(BitBoardIdx bitidx) !ovfs biber@(BitBoard !s !d1 !d2) = (BitBoard s' u1 u2, adds, overflows) where overflows = maskToList overflowingNbs adds = maskToList (ourNbs .&. complement overflowingNbs) `intersect` ovfs !dc1' = clearBit d1 bitidx !dc2' = clearBit d2 bitidx -- !c30 = Carry3 d1' d2' 0 -- !c3' = satAdd False bbi c30 ourNbs = bitNbs bbi overflowingNbs = ourNbs .&. wouldOverflow biber !s' = if player == MaxPlayer then s .&. complement ourNbs else s .|. ourNbs -- (Carry3 !u1 !u2 _) = addgo c30 ourNbs (u1, u2) = addgo dc1' dc2' ourNbs {- addgo g 0 = g addgo g mask = addgo g' mask' where (!idx, !mask') = ffsSplit mask !g' = satAddNC True idx g -} addgo !di1 !di2 0 = (di1, di2) addgo !di1 !di2 !mask = addgo dd1' dd2' mask' where ((BitBoardIdx !idx), !mask') = ffsSplit mask bbi0 = bit idx bbi1 = bit $ idx + 1 bitmask = complement bbi0 dex1 = di1 .&. bbi0 dex2 = (di2 .&. bbi0) `unsafeShiftL` 1 d = dex1 .|. dex2 d' = d + bbi0 dux1 = d' .&. bbi0 dux2 = (d' .&. bbi1) `unsafeShiftR` 1 dd1' = (di1 .&. bitmask) .|. dux1 dd2' = (di2 .&. bitmask) .|. dux2 -- | 'BitBoard' version of 'putOrb' putOrbB :: PlayerU -> BoardIdx -> BitBoard -> BitBoard putOrbB player pos bib@(BitBoard s d1 d2) = if testBit (wouldOverflow bib) posBit then if wouldOverflow bib .&. (bit posBit) /= 0 then go bib [] (bbi : initialOverflows) else go bib [bbi] initialOverflows else bib' where initialOverflows = maskToList $ realOverflow bib bbi@(BitBoardIdx posBit) = bbIdx pos (bib', carry) = let (Carry3 d1' d2' carry) = satAdd True bbi $ Carry3 d1 d2 0 s' = updateSingle bbi s $ playerSignBit player in (BitBoard s' d1' d2', carry) -- san (BitBoardIdx bitidx) (Carry3 d1 d2 _) = Carry3 dd1' dd2' 0 -- where singleAdd idx (BitBoard s d1 d2) = (BitBoard s d1' d2', overflows) where c30 = Carry3 d1 d2 0 (Carry3 d1' d2' carry1) = satAdd True idx c30 -- c30 = Carry3 d1' d2' carry0 -- adds = maskToList ourNbs \\ overflows -- overflows = maskToList overflowingNbs overflows = maskToList carry1 -- ourNbs = bitNbs bbi -- overflowingNbs = ourNbs .&. wouldOverflow biber go :: BitBoard -> [BitBoardIdx] -> [BitBoardIdx] -> BitBoard go biber _ _ | hasWonB player biber = biber go biber [] [] = biber go biber adds (ovf:ovfs) = go biber' (addNbs ++ adds) ovfs' where ovfs' = ovfNbs ++ ovfs (biber', addNbs, ovfNbs) = singleOverflow player ovf ovfs biber go biber (add:adds) [] = go biber' adds ovfs' where -- adds' = addNbs ++ adds --ovfs' = [] :: [BitBoardIdx] -- nub $ (ovfNbs) -- ++ maskToList (realOverflow biber') ovfs' = maskToList (realOverflow biber') ++ ovfNbs (biber', ovfNbs) = singleAdd add biber -- | Mask of all valid fields of the bitboard bitBoardMask :: Word64 bitBoardMask = (1 `unsafeShiftL` 54) - 1 -- | Mask of all border fields (including edge fields) of the bitboard borderMask :: Word64 borderMask = 0b111111_100001_100001_100001_100001_100001_100001_100001_111111 -- | Mask of all edge fields of the bitboard edgeMask :: Word64 edgeMask = 0b100001_000000_000000_000000_000000_000000_000000_000000_100001 realOverflow :: BitBoard -> Word64 realOverflow (BitBoard _ d1 d2) = borderMask .&. complement ((d1 `xor` realOverflowMaskD1) .|. (d2 `xor` realOverflowMaskD2)) where realOverflowMaskD1 = 0b011110_100001_100001_100001_100001_100001_100001_100001_011110 realOverflowMaskD2 = 0b111111_100001_100001_100001_100001_100001_100001_100001_111111 -- | Mask of all fields that would overflow if another orb was placed there wouldOverflow :: BitBoard -> Word64 wouldOverflow (BitBoard _ d1 d2) = bitBoardMask .&. complement ((d1 `xor` wouldOverflowMaskD1) .|. (d2 `xor` wouldOverflowMaskD2)) where wouldOverflowMaskD1 = 0b100001_011110_011110_011110_011110_011110_011110_011110_100001 wouldOverflowMaskD2 = 0b011110_111111_111111_111111_111111_111111_111111_111111_011110 {-} scoreByValueU :: BitBoard -> Value scoreByValueU = Value . sum . fmap (conv . fromIntegral) . elems . unUBoard where conv x | abs x == 3 = x*2 | otherwise = x -} neighborBonusB :: PlayerU -> BitBoard -> Int neighborBonusB player biber = go playerFields where playerFields = playerFieldMask player biber go 0 = 0 go mask = countOwnNbs player biber idx + go mask' where (idx, mask') = ffsSplit mask scoreByValueB :: BitBoard -> Value scoreByValueB biber@(BitBoard s d1 d2) = Value . fromIntegral $ maxScore - minScore where cs = complement s maxFields1 = d1 .&. cs maxFields2 = d2 .&. cs minFields1 = d1 .&. s minFields2 = d2 .&. s criticals = wouldOverflow biber criticalBonusMax = fromIntegral $ criticalBonusFactor * popCount (criticals .&. cs) criticalBonusMin = fromIntegral $ criticalBonusFactor * popCount (criticals .&. s) criticalBonusFactor = 1 neighborBonusMax = neighborBonusB MaxPlayer biber neighborBonusMin = neighborBonusB MinPlayer biber maxFields, minFields :: Int maxFields = fromIntegral $ popCount maxFields1 + (2 * popCount maxFields2) minFields = fromIntegral $ popCount minFields1 + (2 * popCount minFields2) maxScore, minScore :: Int maxScore = mainScoreAdjustment * (maxFields + criticalBonusMax) + neighborBonusMax minScore = mainScoreAdjustment * (minFields + criticalBonusMin) + neighborBonusMin mainScoreAdjustment = 6 scoreB :: BitBoard -> Value scoreB biber | hasWonB MaxPlayer biber = maxBound | hasWonB MinPlayer biber = minBound | otherwise = scoreByValueB biber -- update a single position on the board -- f: function that modifies the number of orbs in the cell -- p: player to whom the updated cell should belong updatePos :: (Int -> Int) -> Player -> Pos -> Board -> Board updatePos f p pos@(y, x) b = chunksOf c $ pre ++ [c'] ++ drop 1 post where (pre, post) = splitAt (y * c + x) $ concat b (r, c) = size b c' = (p*) . f . abs $ getCell pos b {- x.2 -} isFilled :: Board -> Pos -> Bool isFilled b pos = abs (getCell pos b) >= length nbs where nbs = neighbors (size b) pos overflow :: Player -> Pos -> Board -> Board overflow player pos b = b'' where nbs = neighbors (size b) pos nbsCount = length nbs b' = updatePos (\x -> x - nbsCount) player pos b b'' = foldr (updatePos (+1) player) b' nbs -- | place an orb for the given player in the given cell putOrb :: Player -> Pos -> Board -> Board putOrb player pos b = go (pos:nn) b' where sz@(h,w) = size b nn = neighbors sz pos go nbs bb | hasWon player bb = bb | any (isFilled bb) nbs = let nbs' = filter (isFilled bb) nbs in case nbs' of (nb:nbss) -> let bb' = overflow player nb bb nbs2 = nbss ++ neighbors sz nb in go nbs2 bb' [] -> bb -- go [(0,3)] bb | otherwise = bb b' = updatePos (+1) player pos b -- | 'UBoard' version of 'getCell' getCellU :: BoardIdx -> UBoard -> FieldU getCellU p (UBoard b) = b ! p updatePosU :: (FieldU -> FieldU) -> PlayerU -> BoardIdx -> UBoard -> UBoard updatePosU f p pos (UBoard b) = UBoard (b // [(pos, c')]) where c' = (playerValueU p* ) . f . abs $ b ! pos updatePosSTU :: (FieldU -> FieldU) -> PlayerU -> STUBoard s -> BoardIdx -> ST s () updatePosSTU f p b pos = do content <- readArray b pos let content' = (playerValueU p *) . f . abs $ content writeArray b pos content' updatePosSTU' :: (FieldU -> FieldU) -> PlayerU -> STUBoard s -> BoardIdx -> ST s FieldU updatePosSTU' f p b pos = do content <- readArray b pos let content' = (playerValueU p *) . f . abs $ content writeArray b pos content' pure content' -- | 'UBoard' version of 'hasWon' hasWonU :: PlayerU -> UBoard -> Bool hasWonU p (UBoard b) = all go $ elems b where go x = x == 0 || signum x == ps ps = playerValueU p neighborsU :: MetaBoard -> BoardIdx -> Neighbors neighborsU (MetaBoard _ _ _ nblut) pos = nblut ! pos neighborCountU :: MetaBoard -> BoardIdx -> Int8 neighborCountU (MetaBoard _ _ lut _) pos = lut ! pos neighborCountm1 :: Integral a => Int -> Int -> BoardIdx -> a neighborCountm1 (fromIntegral -> r) (fromIntegral -> c) (BoardIdx y x) | (x == 0 || x == c) && (y == 0 || y == r) = 2 | (y == 0 || y == r) && (x == 0 || x == c) = 2 | (x == 0) || (y == 0) || (x == c) || (y == r) = 3 | otherwise = 4 {-# INLINE isFilledU #-} isFilledU :: MetaBoard -> UBoard -> BoardIdx -> Bool isFilledU mb ub pos = abs (getCellU pos ub) >= neighborCountU mb pos overflowU :: MetaBoard -> PlayerU -> BoardIdx -> UBoard -> ([BoardIdx], UBoard) overflowU mbu player pos (UBoard b) = (nbs', UBoard b') where isFilledN (!nv, !nb) = abs nv >= neighborCountU mbu nb updateNeighbors stu = \case (FourNeighbors n1 n2 n3 n4) -> do f1 <- updatePosSTU' succ player stu n1 f2 <- updatePosSTU' succ player stu n2 f3 <- updatePosSTU' succ player stu n3 f4 <- updatePosSTU' succ player stu n4 pure . fmap snd $ filter isFilledN [ (f1, n1), (f2, n2), (f3, n3), (f4, n4) ] (ThreeNeighbors n1 n2 n3) -> do f1 <- updatePosSTU' succ player stu n1 f2 <- updatePosSTU' succ player stu n2 f3 <- updatePosSTU' succ player stu n3 pure . fmap snd $ filter isFilledN [ (f1, n1), (f2, n2), (f3, n3) ] (TwoNeighbors n1 n2) -> do f1 <- updatePosSTU' succ player stu n1 f2 <- updatePosSTU' succ player stu n2 pure . fmap snd $ filter isFilledN [ (f1, n1), (f2, n2) ] (nbs', b') = runST $ do stu <- thaw b updatePosSTU (\x -> x - nbsCount) player stu pos -- !nvs <- mapM (updatePosSTU' succ player stu) nbs nbsF <- updateNeighbors stu nbs -- let nbsF = fmap snd . filter isFilledN $ zip nvs nbs uu <- freeze stu pure (nbsF, uu) !nbs = neighborsU mbu pos !nbsCount = neighborCountU mbu pos -- | This is the 'UBoard' version of 'putOrbU' putOrbU :: MetaBoard -> PlayerU -> BoardIdx -> UBoard -> UBoard putOrbU mb player pos b = go hwuCheckInterval nbs0 b' where nn = antiConvert $ neighborsU mb pos nbs0 = filter (isFilledU mb b') $ pos:nn hwuCheckInterval = 10 go :: Int32 -> [BoardIdx] -> UBoard -> UBoard go _ [] bb = bb -- go _ bb | hasWonU player bb = bb go 0 (nb:nbs) bb = if | hasWonU player bb -> bb | isFilledU mb bb nb -> let (ovfNbs, bb') = overflowU mb player nb bb nbs2 = ovfNbs ++ nbs in go hwuCheckInterval nbs2 bb' | otherwise -> go hwuCheckInterval nbs bb go hwuCounter (nb:nbs) bb = if isFilledU mb bb nb then let (ovfNbs, bb') = overflowU mb player nb bb nbs2 = ovfNbs ++ nbs in go (hwuCounter - 1) nbs2 bb' else go (hwuCounter - 1) nbs bb b' = updatePosU (+1) player pos b {- x.3 -} -- | adds state to a strategy that doesn't use it wrapStrategy :: Strategy -> StatefulStrategy Int wrapStrategy strat = (0, \s r p b -> (strat r p b, succ s)) type MultiStrategy = PlayerU -> Board -> [Pos] -- | Moves classified by categories data ClassifiedMoves a = ClassifiedMoves { criticalMoves :: a -- ^ Moves that target critical cells. They are very important and should be searched first , uncriticalMoves :: a -- ^ Moves targeting occupied, but uncritical cells. , expansionMoves :: a -- ^ Moves targeting non currently occupied cells. , attackMoves :: a -- ^ Moves targeting cells near enemy cells. , extraMoves :: a -- ^ Moves not covered by the other categories (low priority, but interesting during openings) } deriving (Show, Functor, Eq) -- | The moves as generated by a 'MoveGenerator'/'MoveGeneratorB' type MGResult = ClassifiedMoves [BoardIdx] -- | A move generator returns a list of possible moves, 'MGResult', based on a board and a player type MoveGenerator = MetaBoard -> PlayerU -> UBoard -> MGResult -- | 'BitBoard' version of 'MoveGenerator' type MoveGeneratorB = PlayerU -> BitBoard -> MGResult possiblePosU :: PlayerU -> UBoard -> [(BoardIdx, FieldU)] possiblePosU player (UBoard ub) = as where canPlace (_, val) = val == 0 || signum val == playerValueU player as = filter canPlace $ assocs ub -- | Default move generator, operating on 'UBoard's defaultMGU :: MoveGenerator defaultMGU mb@(MetaBoard r c _ _) !p !b = fmap fst <$> ClassifiedMoves { criticalMoves = criticals , uncriticalMoves = uncriticals , expansionMoves = neighborings ++ edges , attackMoves = [] , extraMoves = borders ++ unedges } where pps = possiblePosU p b isFortify (_, fv) = fv /= 0 (fortifies, expansions) = partition isFortify pps isCritical (idx, fv) = abs fv == neighborCountU mb idx - 1 (criticals, uncriticals) = partition isCritical fortifies isFriendly idx = signum (getCellU idx b) == playerValueU p isNeighboring (idx, _) = not . any isFriendly . antiConvert $ neighborsU mb idx (neighborings, unneighborings) = partition isNeighboring expansions isBorder (BoardIdx y x, _) = (x == 0) || (y == 0) || (x == c) || (y == r) (borders, unborders) = partition isBorder unneighborings isEdge (BoardIdx y x, _) = (x == 0 || x == c) && (y == 0 || y == r) || (y == 0 || y == r) && (x == 0 || x == c) (edges, unedges) = partition isEdge unborders -- | Default move generator, operating on 'BitBoard's defaultMGB :: MoveGeneratorB defaultMGB !p biber@(BitBoard _ d1 d2) = fmap unbbIdx <$> ClassifiedMoves { criticalMoves = criticals , uncriticalMoves = uncriticals , expansionMoves = emptyFields , attackMoves = [] , extraMoves = [] } where -- playerFields = playerMinMax s (complement s) p playerFields = playerFieldMask p biber criticalFields = wouldOverflow biber uncriticalFields = nonemptyMask .&. (bitBoardMask .&. complement criticalFields) playerCriticalFields = playerFields .&. criticalFields criticals = maskToList playerCriticalFields playerUncriticalFields = bitBoardMask .&. (playerFields .&. uncriticalFields) uncriticals = maskToList playerUncriticalFields nonemptyMask = d1 .|. d2 empty = complement d1 .&. complement d2 emptyFields = maskToList empty -- | Quiescent move generator, operating on 'UBoard's quiescentMGU :: MoveGenerator quiescentMGU mb !p !b = fmap fst <$> ClassifiedMoves { criticalMoves = criticals , uncriticalMoves = [] , expansionMoves = [] , attackMoves = [] , extraMoves = [] } where pps = filter isCritical $ assocs $ unUBoard b isCritical (idx, fv) = signum fv == playerValueU p && abs fv == neighborCountU mb idx - 1 criticals = filter isCritical pps -- | Quiescent move generator, operating on 'BitBoard's quiescentMGB :: MoveGeneratorB quiescentMGB !p !biber@(BitBoard s _ _) = fmap unbbIdx <$> ClassifiedMoves { criticalMoves = criticals , uncriticalMoves = [] , expansionMoves = [] , attackMoves = [] , extraMoves = [] } where -- playerFields = playerMinMax s (complement s) p playerFields = playerFieldMask p biber criticalFields = wouldOverflow biber playerCriticalFields = playerFields .&. criticalFields criticals = maskToList playerCriticalFields -- | Type for all kinds of values (from board evaluations) newtype Value = Value { unValue :: Int32 } deriving (Show, Bounded, Eq, Ord, Generic) scoreByValueU :: UBoard -> Value scoreByValueU = Value . sum . fmap (conv . fromIntegral) . elems . unUBoard where conv x | abs x == 3 = x*2 | otherwise = x scoreU :: UBoard -> Value scoreU b | hasWonU MaxPlayer b = maxBound | hasWonU MinPlayer b = minBound | otherwise = scoreByValueU b -- | Type for noise values, i.e. the relative difference between two 'Value's newtype Noise = Noise { unNoise :: Int32 } deriving (Show, Eq, Ord, Generic) mkNoise :: Value -> Value -> Noise mkNoise preV postV | isVictoryValue postV = Noise . abs . unValue $ postV | otherwise = Noise . abs $ unValue postV - unValue preV data VNode a = VNode { vvalue :: Value , vstate :: a } deriving (Show, Eq) instance Eq a => Ord (VNode a) where compare = comparing vvalue -- | An applied move, including the resulting board, value and noise data Move = Move { mPos :: {-# UNPACK #-} !BoardIdx , mBoard :: !BitBoard , mValue :: {-# UNPACK #-} !Value , mNoise :: {-# UNPACK #-} !Noise } deriving (Eq, Ord, Show, Generic) -- | Explicit encoding of the player ID data PlayerU = MinPlayer | MaxPlayer deriving (Eq, Show) instance Hashable PlayerU where hashWithSalt s p = hashWithSalt s (playerValueU p :: Int8) toPlayerU :: Player -> PlayerU toPlayerU (-1) = MinPlayer toPlayerU 1 = MaxPlayer toPlayerU _ = error "invalid player number" otherPlayer :: PlayerU -> PlayerU otherPlayer p = case p of MinPlayer -> MaxPlayer MaxPlayer -> MinPlayer playerMinMax :: a -> a -> PlayerU -> a playerMinMax x _ MinPlayer = x playerMinMax _ x MaxPlayer = x playerValueU :: Integral a => PlayerU -> a playerValueU MinPlayer = -1 playerValueU MaxPlayer = 1 -- | 'BitBoard' version of 'applyMoveU' applyMoveB :: Value -> PlayerU -> BitBoard -> BoardIdx -> Move -- applyMoveB preV _ _ _ | isVictoryValue preV = error "applyMoveU called with victory preV!" applyMoveB preV player biber pos = Move pos biber' postV noise where biber' = putOrbB player pos biber postV = scoreB biber' noise = mkNoise preV postV -- | An empty board emptyBoard :: Size -> Board emptyBoard (r,c) = replicate r (replicate c 0) -- | Apply a single move to a board and return the resulting 'Move' applyMoveU :: Value -> MetaBoard -> PlayerU -> UBoard -> BoardIdx -> Move applyMoveU preV _ _ _ _ | isVictoryValue preV = error "applyMoveU called with victory preV!" applyMoveU preV mb player ub pos = if not (isVictoryValue postV) then if unbiber /= ub' then error $ "putOrbB mismatch: pos=" ++ show pos ++ " postV=" ++ show postV ++ " prior=\n" ++ showBoard (unmakeUBoard (mb, ub)) ++ " unbiber=\n" ++ showBoard (unmakeUBoard (mb, unbiber)) ++ " ub'=\n" ++ showBoard (unmakeUBoard (mb, ub')) else Move pos biber' postV noise else Move pos biber' postV noise where biber = makeBitBoard ub biber' = putOrbB player pos biber unbiber = unmakeBitBoard biber' postV = scoreU ub' noise = mkNoise preV postV ub' = putOrbU mb player pos ub dlimSearch' :: Int -> MultiStrategy -> MultiStrategy -> Player -> Board -> (Value, Move) dlimSearch' maxdepth sa sb p0 b = go maxdepth (toPlayerU p0) ub where (mb, ub) = makeUBoard b genMoves :: PlayerU -> UBoard -> [Move] genMoves player bb = let strat = playerMinMax sa sb player moves = fmap posToIdx $ take 10 $ strat player (curry unmakeUBoard mb bb) preV = scoreU bb in applyMoveU preV mb player bb <$> moves go :: Int -> PlayerU -> UBoard -> (Value, Move) go depth player bb | depth == 0 = let moves = genMoves player bb bestMove = playerMinMax minimumBy maximumBy player (comparing mValue) moves in (mValue bestMove, bestMove) | otherwise = let moves = genMoves player bb goc m@(Move _ b00 _ _) = let (v, _) = go (pred depth) (otherPlayer player) (unmakeBitBoard b00) in (v, m) moves' = fmap goc moves in playerMinMax minimumBy maximumBy player (comparing fst) moves' -- | A transposition table, associating 'BitBoard's with 'Move's -- -- Note the phantom player type parameter. This makes sure we don't accidentally mix up the min and the max player's transposition table. newtype TranspositionTable (player :: PlayerU) = TranspositionTable { unTranspositionTable :: HM.HashMap (Hashed BitBoard) Move } deriving (Show) -- | The killer move table associates 'BitBoard's with 'Move's for the killer heuristic type KillerMoveTable = IM.IntMap (HM.HashMap (Hashed BitBoard) Move) type AlphaBeta = (Value, Value) initialAB :: AlphaBeta initialAB = (Value minBound, Value maxBound) isVictoryValue :: Value -> Bool isVictoryValue v = v == maxBound || v == minBound mkWindow :: Int32 -> Value -> AlphaBeta mkWindow sz vu@(Value v) | isVictoryValue vu = initialAB | otherwise = (Value (v - sz), Value (v + sz)) widenA, widenB :: Int32 -> AlphaBeta -> AlphaBeta widenB multi (Value a, Value b) = let b' = b + multi*(b - a) in (Value a, Value b') widenA multi (Value a, Value b) = let a' = a - multi*(b - a) in (Value a', Value b ) widenAlphaAround, widenBetaAround :: Int32 -> AlphaBeta -> AlphaBeta widenBetaAround multi (Value a, Value b) = (Value a', Value b') where windowSize = b - a a' = a + (windowSize `div` 2) b' = b + 3^multi widenAlphaAround multi (Value a, Value b) = (Value a', Value b') where windowSize = b - a a' = a - 3^multi b' = b - (windowSize `div` 2) nullWindow :: Value -> AlphaBeta nullWindow (Value v) = (Value v, Value (v + 1)) -- | The strategy state, used for re-using the transposition and killer move tables data SearchState = SearchState { minTT :: !(TranspositionTable 'MinPlayer) -- ^ The min player transposition table , maxTT :: !(TranspositionTable 'MaxPlayer) -- ^ The max player transposition table , killerTT :: !KillerMoveTable -- ^ The killer move table (for the killer heuristic) , moveCount :: !Int -- ^ Current move count , lastValue :: !Value -- ^ Value the board had in our previous turn } deriving (Show) data NullMoveStatus = Inactive | Active | Forbidden deriving (Eq, Show) -- | Search stage/type data SearchType = Primary -- ^ Primary search (perform quiescence) | Deepening -- ^ Deepening search (quiescence search disabled) | Quiescence -- ^ Quiescence search (do not perform quiescence search at the horizon) deriving (Eq, Show) -- | Type for (search) depth values. newtype Depth = Depth { unDepth :: Int16 } deriving (Eq, Ord, Show) horizonDepth :: Depth horizonDepth = Depth 0 nextDepth :: Depth -> Depth nextDepth (Depth d) = Depth $ d - 1 ourPreviousDepth :: Depth -> Depth ourPreviousDepth (Depth d) = Depth $ d - 2 iterationsUpTo :: Depth -> [Depth] iterationsUpTo (Depth d) = Depth <$> [1..(d - 1)] lookupDepth :: Depth -> IM.IntMap v -> Maybe v lookupDepth (Depth d) = IM.lookup (fromIntegral d) -- | Insert a killer move into the 'KillerMoveTable' insertKiller :: Hashed BitBoard -> Depth -> Move -> KillerMoveTable -> KillerMoveTable insertKiller hbb (Depth d) m = IM.alter go (fromIntegral d) where go Nothing = Just $ HM.singleton hbb m go (Just tt) = Just $ HM.insert hbb m tt -- | Lookup killer moves based on the current 'BitBoard' lookupKiller :: Depth -> STRef s KillerMoveTable -> KillerMoveTable -> Hashed BitBoard -> ST s [Move] lookupKiller depth killerttref killertt0 hbb = killermove <$> readSTRef killerttref where killermove0 = case lookupDepth (ourPreviousDepth depth) killertt0 of Just tt -> case HM.lookup hbb tt of Just m -> [m] Nothing -> [] Nothing -> [] killermove killertt = case lookupDepth depth killertt of Just tt1 -> case HM.lookup hbb tt1 of Just m -> [m] Nothing -> killermove0 Nothing -> killermove0 -- | Lookup hash moves based on the current 'BitBoard' lookupHashMove :: STRef s (TranspositionTable p) -> (TranspositionTable p) -> Hashed BitBoard -> ST s [Move] lookupHashMove ttref (TranspositionTable tt0) hbb = (hashmove . unTranspositionTable) <$> readSTRef ttref where hashmove tt = case HM.lookup hbb tt of Just m -> [m] Nothing -> case HM.lookup hbb tt0 of Just m -> [m] Nothing -> [] -- | Reified node results data INode = Leaf -- ^ A real leaf | PV !Move -- ^ A PV-Node, i.e. a node with a score inside [α, β] | Alpha !Move -- ^ A Cut-Node or Alpha node, i.e. a node with a score below α | Beta !Move -- ^ An All-Node or Beta node, i.e. a node with a score above β deriving (Show) -- | Reified node results data ABNode = None -- ^ The search did not return any results. This is mostly used in the inner functions, if it ever leaks outside it indicates not enough moves being offered to the search. | Valued !Value !INode -- ^ A valued result, i.e. one that is associated with a leaf value. -- | The main search function (non-CPS version) abSearch :: SearchState -> Depth -> Player -> Board -> (SearchState, Value, Move) abSearch (SearchState mintt0 maxtt0 killertt0 mc lv) maxdepth p0 b = traceMarker ("phase=" ++ show mc) $ runST $ do mintt <- newSTRef $ TranspositionTable HM.empty -- mintt0 maxtt <- newSTRef $ TranspositionTable HM.empty -- maxtt0 killertt <- newSTRef IM.empty -- killertt0 traceM $ "MOVE: " ++ show mc traceM $ "LAST V: " ++ show lv traceM $ "NOW V: " ++ show currentScore traceM $ "DELTA: " ++ show deltaScore let iter multi ab0@(a, b) d = do Valued v _ <- go killertt maxtt mintt Deepening d pu0 ab0 biber0 traceM $ "iter=" ++ show d ++ " multi=" ++ show multi ++ " a=" ++ show a ++ " b=" ++ show b ++ " v=" ++ show v if | isVictoryValue v -> pure (v, v) | v >= b -> do traceM "fail high" let ab' = widenBetaAround multi (a, v) iter (succ multi) ab' d | v <= a -> do traceM "fail low" let ab' = widenAlphaAround multi (v, b) iter (succ multi) ab' d | otherwise -> pure $ nullWindow v iterPrimary multi ab0@(a, b) d = do Valued v mu <- go killertt maxtt mintt Primary d pu0 ab0 biber0 traceM $ "iter=" ++ show d ++ " multi=" ++ show multi ++ " a=" ++ show a ++ " b=" ++ show b ++ " v=" ++ show v let mm = case mu of PV m -> m Beta m -> m -- This actually happens, for whatever reason Alpha m -> m Leaf -> error "unreachable" if | isVictoryValue v -> pure (v, mm) | v >= b -> do traceM "fail high" let ab' = widenBetaAround multi (a, v) iterPrimary (succ multi) ab' d | v <= a -> do traceM "fail low" let ab' = widenAlphaAround multi (v, b) iterPrimary (succ multi) ab' d | otherwise -> pure (v, mm) ab <- foldM (iter 1) (mkWindow 10 currentScore) (iterationsUpTo maxdepth') (v1, m1) <- iterPrimary 1 ab maxdepth' mintt1 <- readSTRef mintt maxtt1 <- readSTRef maxtt killertt1 <- readSTRef killertt let sst' = SearchState mintt1 maxtt1 killertt1 (succ mc) currentScore pure (sst', v1, m1) where pu0 = toPlayerU p0 (mb, ub0) = makeUBoard b biber0 = makeBitBoard ub0 currentScore = if mc == 0 then Value 0 else scoreU ub0 deltaScore = unValue currentScore - unValue lv improvementScore = playerMinMax negate id pu0 deltaScore quiescenceEnabled = False quiescenceDepth = Depth 5 quiescenceThreshold = Noise 1 maxdepth' = if | mc < 15 -> Depth 3 | maxdepth == Depth 5 && improvementScore < -5 -> Depth 5 -- 7 | maxdepth > Depth 5 && mc < 25 -> Depth 5 --maxdepth - 2 | otherwise -> maxdepth requireValidMove :: Maybe (Value, Move) -> (Value, Move) requireValidMove (Just (v, m)) = (v, m) requireValidMove Nothing = error "PANIC: No viable moves found!" genPrimaryMoves :: PlayerU -> BitBoard -> [Move] genPrimaryMoves = if mc < 15 then genOpeningMoves else genMidgameMoves genOpeningMoves :: PlayerU -> BitBoard -> [Move] genOpeningMoves player biber = exps ++ extras ++ crits ++ uncrits where -- sortOrder = playerMinMax (sortOn mValue) (sortOn (Down . mValue)) player applyMoves :: [BoardIdx] -> [Move] applyMoves = fmap (applyMoveB currentScore player biber) -- defaultMGU mb player (unmakeBitBoard biber) -- defaultMGB player biber (ClassifiedMoves crits uncrits exps attacks extras) = applyMoves <$> defaultMGU mb player (unmakeBitBoard biber) genMidgameMoves :: PlayerU -> BitBoard -> [Move] genMidgameMoves player biber = crits ++ uncrits ++ exps ++ extras where --sortOrder = playerMinMax (sortOn mValue) (sortOn (Down . mValue)) player --appliedMoves = take 50 $ genMovesU innerMultiStrategyU player bb applyMoves = fmap (applyMoveB currentScore player biber) (ClassifiedMoves crits uncrits exps attacks extras) = applyMoves <$> defaultMGU mb player (unmakeBitBoard biber) genQuiescentMoves :: PlayerU -> BitBoard -> [Move] genQuiescentMoves player biber = crits where applyMoves = fmap (applyMoveB currentScore player biber) (ClassifiedMoves crits _ _ _ _) = applyMoves <$> quiescentMGB player biber -- null move R factor nmr :: Int -> Int nmr depth = max 1 (depth - 2) -- late move reductions lmr :: Int -> Depth -> Depth lmr mnum (Depth d) -- | mnum >= 5 = max 0 (depth - 2) -- | mnum >= 10 = max 0 (depth - 3) | otherwise = Depth $ d - 1 goMax :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Int -> NullMoveStatus -> Depth -> AlphaBeta -> (Value, Noise) -> BitBoard -> ST s ABNode goMax killerttref maxttref minttref stype pvPathCount nullMove depth (alpha, beta) (preVal, preNoise) bb | depth == horizonDepth = case stype of Primary | quiescenceEnabled && preNoise > quiescenceThreshold -> do let alpha1 = max alpha preVal qRes <- goMax killerttref maxttref minttref Quiescence pvPathCount Forbidden quiescenceDepth (alpha1, beta) (preVal, preNoise) bb case qRes of Valued qVal _ -> do --traceM $ "quiescence result=" ++ show qVal ++ " primary result=" ++ show preVal pure $ Valued qVal Leaf None -> do pure $ Valued preVal Leaf _ -> pure $ Valued preVal Leaf | otherwise = inner alpha where hbb = hashed bb moves = case stype of Primary -> genPrimaryMoves MaxPlayer bb Deepening -> genPrimaryMoves MaxPlayer bb Quiescence -> genQuiescentMoves MaxPlayer bb inner ualpha = do hashmove <- lookupHashMove maxttref maxtt0 hbb killermove <- lookupKiller depth killerttref killertt0 hbb let moves' = hashmove ++ killermove ++ moves checkRes <- checkMax 0 None ualpha moves' case checkRes of Valued vcr (PV mcr) -> do modifySTRef' maxttref (TranspositionTable . HM.insert hbb mcr . unTranspositionTable) pure $ Valued vcr (PV mcr) Valued vcr (Beta mcr) -> do modifySTRef' maxttref (TranspositionTable . HM.insert hbb mcr . unTranspositionTable) pure $ Valued vcr (Beta mcr) Valued _ (Alpha _) -> do error "encountered alpha during goMax" Valued vcr Leaf -> do pure $ Valued vcr Leaf None -> pure None checkMax :: Int -> ABNode -> Value -> [Move] -> ST s ABNode checkMax _ mcc _ [] = pure mcc checkMax mnum mcc alpha0 (m@(Move _ b00 mval mnoise):mvs) | mval == maxBound = pure $ Valued mval (Beta m) | otherwise = do let depth' = lmr mnum depth -- + if mnum == 0 && pvPathCount == 3 then 2 else 0 pvPathCount' = if mnum == 0 then pvPathCount + 1 else pvPathCount childRes <- goMin killerttref maxttref minttref stype pvPathCount' nullMove depth' (alpha0, beta) (mval, mnoise) b00 case childRes of Valued v _ -> do let cc'@(Valued v1 _) = case mcc of cc@(Valued cv _) -> if v > cv --max v0 v then Valued v $ if v >= beta then Beta m else PV m else cc None -> Valued v $ if v >= beta then Beta m else PV m alpha1 = max alpha0 v1 if alpha1 >= beta then do -- traceM ">>> BETA CUT" modifySTRef' killerttref (insertKiller hbb depth m) pure . traceEvent ("abs beta cut mnum=" ++ show mnum) $ cc' else do -- traceM ">>> BETA ..." traceEvent ("abs beta cont mnum=" ++ show mnum) $ checkMax (succ mnum) cc' alpha1 mvs None -> traceEvent ("abs beta skip mnum=" ++ show mnum) $ checkMax (succ mnum) mcc alpha0 mvs goMin :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Int -> NullMoveStatus -> Depth -> (Value, Value) -> (Value, Noise) -> BitBoard -> ST s ABNode goMin killerttref maxttref minttref stype pvPathCount nullMove depth (alpha, beta) (preVal, preNoise) bb | depth == horizonDepth = case stype of Primary | quiescenceEnabled && preNoise > quiescenceThreshold -> do let beta1 = min beta preVal qRes <- goMin killerttref maxttref minttref Quiescence pvPathCount Forbidden quiescenceDepth (alpha, beta1) (preVal, preNoise) bb case qRes of Valued qVal _ -> do --traceM $ "quiescence result=" ++ show qVal ++ " primary result=" ++ show preVal pure $ Valued qVal Leaf None -> do pure $ Valued preVal Leaf _ -> pure $ Valued preVal Leaf | otherwise = do hashmove <- lookupHashMove minttref mintt0 hbb killermove <- lookupKiller depth killerttref killertt0 hbb let moves' = hashmove ++ killermove ++ moves checkRes <- checkMin 0 None beta moves' case checkRes of Valued vcr (PV mcr) -> do modifySTRef' minttref (TranspositionTable . HM.insert hbb mcr . unTranspositionTable) pure $ Valued vcr (PV mcr) Valued vcr (Alpha mcr) -> do modifySTRef' minttref (TranspositionTable . HM.insert hbb mcr . unTranspositionTable) pure $ Valued vcr (Alpha mcr) Valued _ (Beta _) -> do error "encountered beta during goMin" Valued vcr Leaf -> do pure $ Valued vcr Leaf None -> pure None where hbb = hashed bb moves = case stype of Primary -> genPrimaryMoves MinPlayer bb Deepening -> genPrimaryMoves MinPlayer bb Quiescence -> genQuiescentMoves MinPlayer bb checkMin :: Int -> ABNode -> Value -> [Move] -> ST s ABNode checkMin _ mcc _ [] = pure mcc checkMin mnum mcc beta0 (m@(Move _ b00 mval mnoise):mvs) | mval == minBound = pure $ Valued mval (Alpha m) | otherwise = do let depth' = lmr mnum depth -- + if mnum == 0 && pvPathCount == 3 then 2 else 0 pvPathCount' = if mnum == 0 then pvPathCount + 1 else pvPathCount childRes <- goMax killerttref maxttref minttref stype pvPathCount' nullMove depth' (alpha, beta0) (mval, mnoise) b00 case childRes of None -> traceEvent ("abs alpha skip mnum=" ++ show mnum) $ checkMin (succ mnum) mcc beta0 mvs Valued v _ -> do let cc'@(Valued v1 _) = case mcc of cc@(Valued cv _) -> if v < cv --min v0 v then Valued v $ if v <= alpha then Alpha m else PV m else cc None -> Valued v $ if v <= alpha then Alpha m else PV m beta1 = min beta0 v1 if alpha >= beta1 then do -- traceM ">>> ALPHA CUT" modifySTRef' killerttref (insertKiller hbb depth m) pure . traceEvent ("abs alpha cut mnum=" ++ show mnum) $ cc' else do -- traceM ">>> ALPHA ..." traceEvent ("abs alpha cont mnum=" ++ show mnum) $ checkMin (succ mnum) cc' beta1 mvs go :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Depth -> PlayerU -> AlphaBeta -> BitBoard -> ST s ABNode go killertt maxtt mintt stype depth MinPlayer ab ub = goMin killertt maxtt mintt stype 0 Forbidden depth ab (scoreB ub, Noise 0) ub go killertt maxtt mintt stype depth MaxPlayer ab ub = goMax killertt maxtt mintt stype 0 Forbidden depth ab (scoreB ub, Noise 0) ub -- | The inner CPS type, with continuations corresponding to the 'ABNode'/'INode' values newtype GameAction s = GameAction { unGameAction :: forall a. ST s a -> -- None (Value -> ST s a) -> -- Leaf (Value -> Move -> ST s a) -> -- PV (Value -> Move -> ST s a) -> -- Alpha (Value -> Move -> ST s a) -> -- Beta ST s a } -- | The main search function (CPS version) abSearchCPS :: SearchState -> Depth -> Player -> Board -> (SearchState, Value, Move) abSearchCPS (SearchState mintt0 maxtt0 killertt0 mc lv) maxdepth p0 b = traceMarker ("phase=" ++ show mc) $ runST $ do mintt <- newSTRef $ TranspositionTable HM.empty -- mintt0 maxtt <- newSTRef $ TranspositionTable HM.empty -- maxtt0 killertt <- newSTRef IM.empty -- killertt0 traceM $ "MOVE: " ++ show mc traceM $ "LAST V: " ++ show lv traceM $ "NOW V: " ++ show currentScore traceM $ "DELTA: " ++ show deltaScore let iter multi ab0@(a, b) d = do let cnone = error "no result" continue v | isVictoryValue v = pure (v, v) | otherwise = pure $ nullWindow v cleaf v = continue v cpv v _ = continue v calpha v _ = do if isVictoryValue v then do traceM $ "vic fail low" ++ show v iter (succ multi) (v, b) d else do traceM "fail low" let ab' = widenAlphaAround multi (v, b) iter (succ multi) ab' d cbeta v _ = if isVictoryValue v then do traceM "vic fail high" iter (succ multi) (a, v) d else do traceM "fail high" let ab' = widenBetaAround multi (a, v) iter (succ multi) ab' d --Valued v mu <- go killertt maxtt mintt Deepening d pu0 ab0 biber0 traceM $ "iter=" ++ show d ++ " multi=" ++ show multi ++ " a=" ++ show a ++ " b=" ++ show b unGameAction (go killertt maxtt mintt Deepening d pu0 ab0 biber0) cnone cleaf cpv calpha cbeta iterPrimary multi ab0@(a, b) d = do let cnone = error "no result" continue v m | isVictoryValue v = pure (v, m) | otherwise = pure (v, m) cleaf _ = error "got only leaf" cpv v m = continue v m calpha v m = if isVictoryValue v then do traceM "pri vic fail low" continue v m else do traceM "pri fail low" let ab' = widenAlphaAround multi (v, b) iterPrimary (succ multi) ab' d cbeta v m = if isVictoryValue v then do traceM "pri vic fail high" continue v m else do traceM "pri fail high" let ab' = widenBetaAround multi (a, v) iterPrimary (succ multi) ab' d traceM $ "iter=" ++ show d ++ " multi=" ++ show multi ++ " a=" ++ show a ++ " b=" ++ show b unGameAction (go killertt maxtt mintt Primary d pu0 ab0 biber0) cnone cleaf cpv calpha cbeta -- traceM $ "iter=" ++ show d ++ " multi=" ++ show multi ++ " a=" ++ show a ++ " b=" ++ show b ++ " v=" ++ show v ab <- foldM (iter 1) (mkWindow 10 currentScore) (iterationsUpTo maxdepth') (v1, m1) <- iterPrimary 1 ab maxdepth' mintt1 <- readSTRef mintt maxtt1 <- readSTRef maxtt killertt1 <- readSTRef killertt let sst' = SearchState mintt1 maxtt1 killertt1 (succ mc) currentScore pure (sst', v1, m1) where pu0 = toPlayerU p0 (mb, ub0) = makeUBoard b biber0 = makeBitBoard ub0 currentScore = if mc == 0 then Value 0 else scoreU ub0 deltaScore = unValue currentScore - unValue lv improvementScore = playerMinMax negate id pu0 deltaScore quiescenceEnabled = False quiescenceDepth = Depth 5 quiescenceThreshold = Noise 1 maxdepth' = if | mc < 15 -> Depth 3 | maxdepth == Depth 5 && improvementScore < -5 -> Depth 5 -- 7 | maxdepth > Depth 5 && mc < 25 -> Depth 5 --maxdepth - 2 | otherwise -> maxdepth requireValidMove :: Maybe (Value, Move) -> (Value, Move) requireValidMove (Just (v, m)) = (v, m) requireValidMove Nothing = error "PANIC: No viable moves found!" genPrimaryMoves :: PlayerU -> BitBoard -> [Move] genPrimaryMoves = if mc < 15 then genOpeningMoves else genMidgameMoves genOpeningMoves :: PlayerU -> BitBoard -> [Move] genOpeningMoves player biber = exps ++ extras ++ crits ++ uncrits where -- sortOrder = playerMinMax (sortOn mValue) (sortOn (Down . mValue)) player applyMoves :: [BoardIdx] -> [Move] applyMoves = fmap (applyMoveB currentScore player biber) -- defaultMGU mb player (unmakeBitBoard biber) -- defaultMGB player biber (ClassifiedMoves crits uncrits exps attacks extras) = applyMoves <$> defaultMGU mb player (unmakeBitBoard biber) genMidgameMoves :: PlayerU -> BitBoard -> [Move] genMidgameMoves player biber = crits ++ uncrits ++ exps ++ extras where --sortOrder = playerMinMax (sortOn mValue) (sortOn (Down . mValue)) player --appliedMoves = take 50 $ genMovesU innerMultiStrategyU player bb applyMoves = fmap (applyMoveB currentScore player biber) (ClassifiedMoves crits uncrits exps attacks extras) = applyMoves <$> defaultMGU mb player (unmakeBitBoard biber) genQuiescentMoves :: PlayerU -> BitBoard -> [Move] genQuiescentMoves player biber = crits where applyMoves = fmap (applyMoveB currentScore player biber) (ClassifiedMoves crits _ _ _ _) = applyMoves <$> quiescentMGB player biber goMax :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Depth -> AlphaBeta -> (Value, Noise) -> BitBoard -> GameAction s goMax killerttref maxttref minttref stype depth (alpha, beta) (preVal, preNoise) bb | depth == horizonDepth = GameAction $ \ _ rleaf _ _ _ -> case stype of Primary | quiescenceEnabled && preNoise > quiescenceThreshold -> do let alpha1 = max alpha preVal cnone = rleaf preVal cleaf v = rleaf v cpv v _ = rleaf v calpha v _ = rleaf v cbeta v _ = rleaf v unGameAction (goMax killerttref maxttref minttref Quiescence quiescenceDepth (alpha1, beta) (preVal, preNoise) bb) cnone cleaf cpv calpha cbeta _ -> rleaf preVal | otherwise = inner alpha where hbb = hashed bb moves = case stype of Primary -> genPrimaryMoves MaxPlayer bb Deepening -> genPrimaryMoves MaxPlayer bb Quiescence -> genQuiescentMoves MaxPlayer bb inner ualpha = GameAction $ \ rnone rleaf rpv _ rbeta -> do hashmove <- lookupHashMove maxttref maxtt0 hbb killermove <- lookupKiller depth killerttref killertt0 hbb let moves' = hashmove ++ killermove ++ moves let cnone = rnone cleaf = rleaf cpv v m = do modifySTRef' maxttref (TranspositionTable . HM.insert hbb m . unTranspositionTable) rpv v m cbeta v m = do modifySTRef' maxttref (TranspositionTable . HM.insert hbb m . unTranspositionTable) rbeta v m calpha = error "encountered alpha during goMax" unGameAction (checkMax Nothing ualpha moves') cnone cleaf cpv calpha cbeta checkMax :: Maybe Value -> Value -> [Move] -> GameAction s checkMax _ _ [] = GameAction $ \ rnone _ _ _ _ -> rnone checkMax mcc alpha0 (m@(Move _ b00 mval mnoise):mvs) | mval == maxBound = GameAction $ \ _ _ rpv _ rbeta -> if beta /= maxBound then rbeta mval m else rpv mval m | otherwise = GameAction $ \ rnone rleaf rpv ralpha rbeta -> do let depth' = nextDepth depth cnone = unGameAction (checkMax mcc alpha0 mvs) rnone rleaf rpv ralpha rbeta continueRaise nv nm = unGameAction (checkMax (Just nv) nv mvs) (rpv nv nm) rleaf rpv ralpha rbeta continue nv nm = unGameAction (checkMax (Just nv) alpha0 mvs) (rpv nv nm) rleaf rpv ralpha rbeta cleaf v = checkAny v cpv v _ = checkAny v calpha v _ = checkAny v cbeta v _ = checkAny v cutChecks v = if v > alpha0 then if v >= beta then do modifySTRef' killerttref (insertKiller hbb depth m) if beta == maxBound then rpv v m else rbeta v m else continueRaise v m else continue v m checkAny v = case mcc of Just cv -> if v > cv then cutChecks v else cnone Nothing -> cutChecks v unGameAction (goMin killerttref maxttref minttref stype depth' (alpha0, beta) (mval, mnoise) b00) cnone cleaf cpv calpha cbeta goMin :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Depth -> (Value, Value) -> (Value, Noise) -> BitBoard -> GameAction s goMin killerttref maxttref minttref stype depth (alpha, beta) (preVal, preNoise) bb | depth == horizonDepth = GameAction $ \ _ rleaf _ _ _ -> case stype of Primary | quiescenceEnabled && preNoise > quiescenceThreshold -> do let beta1 = min beta preVal cnone = rleaf preVal cleaf v = rleaf v cpv v _ = rleaf v calpha v _ = rleaf v cbeta v _ = rleaf v unGameAction (goMin killerttref maxttref minttref Quiescence quiescenceDepth (alpha, beta1) (preVal, preNoise) bb) cnone cleaf cpv calpha cbeta _ -> rleaf preVal | otherwise = GameAction $ \ rnone rleaf rpv ralpha _ -> do hashmove <- lookupHashMove minttref mintt0 hbb killermove <- lookupKiller depth killerttref killertt0 hbb let moves' = hashmove ++ killermove ++ moves let cnone = rnone cleaf v = rleaf v cpv v m = do modifySTRef' minttref (TranspositionTable . HM.insert hbb m . unTranspositionTable) rpv v m calpha v m = do modifySTRef' minttref (TranspositionTable . HM.insert hbb m . unTranspositionTable) ralpha v m cbeta _ _ = error "encountered beta during goMin" unGameAction (checkMin Nothing beta moves') cnone cleaf cpv calpha cbeta where hbb = hashed bb moves = case stype of Primary -> genPrimaryMoves MinPlayer bb Deepening -> genPrimaryMoves MinPlayer bb Quiescence -> genQuiescentMoves MinPlayer bb checkMin :: Maybe Value -> Value -> [Move] -> GameAction s checkMin _ _ [] = GameAction $ \ rnone _ _ _ _ -> rnone checkMin mcc beta0 (m@(Move _ b00 mval mnoise):mvs) | mval == minBound = GameAction $ \ _ _ rpv ralpha _ -> if alpha /= minBound then do traceM "leaf cut alpha" ralpha mval m else rpv mval m | otherwise = GameAction $ \ rnone rleaf rpv ralpha rbeta -> do let depth' = nextDepth depth cnone = unGameAction (checkMin mcc beta0 mvs) rnone rleaf rpv ralpha rbeta continueRaise nv nm = unGameAction (checkMin (Just nv) nv mvs) (rpv nv nm) rleaf rpv ralpha rbeta continue nv nm = unGameAction (checkMin (Just nv) beta0 mvs) (rpv nv nm) rleaf rpv ralpha rbeta cleaf v = checkAny v cpv v _ = checkAny v calpha v _ = checkAny v cbeta v _ = checkAny v cutChecks v = if v < beta0 then if v <= alpha then do modifySTRef' killerttref (insertKiller hbb depth m) if alpha == minBound then rpv v m else ralpha v m else continueRaise v m else continue v m checkAny v = case mcc of Just cv -> if v < cv then cutChecks v {- if v <= alpha -- v <= alpha then ralpha v m -- v > alpha, v < beta0 else continueRaise v m-} else cnone --continue cv cm --Nothing -> rpv v m Nothing -> cutChecks v --continue v m unGameAction (goMax killerttref maxttref minttref stype depth' (alpha, beta0) (mval, mnoise) b00) cnone cleaf cpv calpha cbeta go :: forall s. STRef s KillerMoveTable -> STRef s (TranspositionTable 'MaxPlayer) -> STRef s (TranspositionTable 'MinPlayer) -> SearchType -> Depth -> PlayerU -> AlphaBeta -> BitBoard -> GameAction s go killertt maxtt mintt stype depth MinPlayer ab ub = goMin killertt maxtt mintt stype depth ab (scoreB ub, Noise 0) ub go killertt maxtt mintt stype depth MaxPlayer ab ub = goMax killertt maxtt mintt stype depth ab (scoreB ub, Noise 0) ub initialSearchState :: SearchState initialSearchState = SearchState (TranspositionTable HM.empty) (TranspositionTable HM.empty) IM.empty 0 (Value 0) searchStrategy1 :: StatefulStrategyFunc SearchState searchStrategy1 st _ player b = (idxToPos p, st') where depth = Depth 4 (st', _, Move p _ _ _) = abSearch st depth player b searchStrategy2 :: StatefulStrategyFunc SearchState searchStrategy2 st _ player b = (idxToPos p, st') where depth = Depth 4 (st', _, Move p _ _ _) = abSearchCPS st depth player b -- | Alternative strategy, for A/B testing. Currently the CPS-ed version searchStrategy' :: StatefulStrategy SearchState searchStrategy' = (initialSearchState, searchStrategy2) -- | Main strategy searchStrategy :: StatefulStrategy SearchState searchStrategy = (initialSearchState, searchStrategy1) -- the actual strategy submissions -- if you want to use state modify this instead of strategy -- additionally you may change the Int in this type declaration to any type that is usefully for your strategy strategyState :: StatefulStrategy SearchState strategyState = searchStrategy {-TTEW-} -- | Simulate a game between two strategies on a board of the given size and -- returns the state of the board before each move together with the player that won the game play :: [Int] -> Size -> StatefulStrategy a -> StatefulStrategy b -> [(Board, Pos)] play rss0 (r, c) (isa, sa) (isb, sb) = go rss0 isa sa isb sb 1 0 (replicate r (replicate c 0)) where -- type signature is necessary, inferred type is wrong! go :: [Int] -> a -> StatefulStrategyFunc a -> b -> StatefulStrategyFunc b -> Player -> Int -> Board -> [(Board, Pos)] go [] _ _ _ _ _ _ _ = error "empty randoms given" go (rs:rss) stc sc stn sn p n b | won = [] | valid = (b, m) : go rss stn sn st' sc (-p) (succ n) (putOrb p m b) | otherwise = [] where won = n > 1 && hasWon (-p) b (m, st') = sc stc (mkRandoms rs) p b valid = isValidPos (size b) m && canPlaceOrb p m b -- | Play a game and print it to the console playAndPrint :: Size -> StatefulStrategy a -> StatefulStrategy b -> IO () playAndPrint totalMoves sa sb = do -- seed <- randomIO let seed = 42 let moves = play (mkRandoms seed) totalMoves sa sb putStr $ unlines (zipWith showState moves $ cycle ['+', '-']) ++ "\n" ++ (case length moves `mod` 2 of { 1 -> "Winner: +"; 0 -> "Winner: -" }) ++ "\n" ++ "View at https://vmnipkow16.in.tum.de/christmas2020/embed.html#i" ++ base64 (1 : t totalMoves ++ concatMap (t . snd) moves) ++ "\n" putStrLn $ "Moves: " ++ show (length moves) where showState (b, pos) p = showBoard b ++ p : " places at " ++ show pos ++ "\n" t (a, b) = [a, b] mkRandoms :: Random a => Int -> [a] mkRandoms = randoms . mkStdGen base64 :: [Int] -> String base64 xs = case xs of [] -> "" [a] -> f1 a : f2 a 0 : "==" [a, b] -> f1 a : f2 a b : f3 b 0 : "=" a : b : c : d -> f1 a : f2 a b : f3 b c : f4 c : base64 d where alphabet = (!!) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" f1 a = alphabet $ shiftR a 2 f2 a b = alphabet $ shiftL (a .&. 3 ) 4 .|. shiftR b 4 f3 b c = alphabet $ shiftL (b .&. 15) 2 .|. shiftR c 6 f4 c = alphabet $ c .&. 63