From 2890d3ec693e0bec525204e32e8c1cc03b68bd33 Mon Sep 17 00:00:00 2001 From: Nicu Ionita Date: Sat, 27 Apr 2013 19:18:49 +0200 Subject: [PATCH] The identity is changed on Barbarossa, other small changes, it compiles --- Barbarossa.cabal | 47 +- Eval/BasicEval.hs | 30 + Eval/Eval.hs | 607 +++++++++++++++++ Eval/FileParams.hs | 55 ++ Hash/TransTab.hs | 280 ++++++++ Hash/Zobrist.hs | 70 ++ Main/Barbarossa.hs | 114 ++-- Moves/Base.hs | 430 ++++++++++++ Moves/BaseTypes.hs | 24 + Moves/BitBoard.hs | 88 +++ Moves/Board.hs | 842 +++++++++++++++++++++++ Moves/GenMagics.hs | 196 ++++++ Moves/History.hs | 69 ++ Moves/Magics.hs | 170 +++++ Moves/Moves.hs | 151 +++++ Moves/Muster.hs | 71 ++ Moves/SEE.hs | 195 ++++++ Moves/ShowMe.hs | 44 ++ Search/Albeta.hs | 1472 +++++++++++++++++++++++++++++++++++++++++ Search/AlbetaTypes.hs | 55 ++ Search/SearchMonad.hs | 76 +++ Setup.hs | 2 + Struct/Context.hs | 49 +- Uci/UCI.hs | 266 ++++++++ Uci/UciGlue.hs | 61 ++ 25 files changed, 5339 insertions(+), 125 deletions(-) create mode 100644 Eval/BasicEval.hs create mode 100644 Eval/Eval.hs create mode 100644 Eval/FileParams.hs create mode 100644 Hash/TransTab.hs create mode 100644 Hash/Zobrist.hs create mode 100644 Moves/Base.hs create mode 100644 Moves/BaseTypes.hs create mode 100644 Moves/BitBoard.hs create mode 100644 Moves/Board.hs create mode 100644 Moves/GenMagics.hs create mode 100644 Moves/History.hs create mode 100644 Moves/Magics.hs create mode 100644 Moves/Moves.hs create mode 100644 Moves/Muster.hs create mode 100644 Moves/SEE.hs create mode 100644 Moves/ShowMe.hs create mode 100644 Search/Albeta.hs create mode 100644 Search/AlbetaTypes.hs create mode 100644 Search/SearchMonad.hs create mode 100644 Setup.hs create mode 100644 Uci/UCI.hs create mode 100644 Uci/UciGlue.hs diff --git a/Barbarossa.cabal b/Barbarossa.cabal index 5ef9cedc..c4f2c105 100644 --- a/Barbarossa.cabal +++ b/Barbarossa.cabal @@ -21,54 +21,15 @@ Flag Profile Executable Barbarossa Main-is: Main/Barbarossa.hs Build-depends: base >= 4.5, array, old-time, containers, mtl, parsec, vector, - random, stream-fusion, directory, transformers + random, stream-fusion, directory, transformers, QuickCheck GHC-Options: -O2 -Wall -funbox-strict-fields -threaded -rtsopts -fspec-constr-count=24 -funfolding-use-threshold=32 - -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques - -ddump-opt-cmm -ddump-asm + -- -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques + -- -ddump-opt-cmm -ddump-asm if flag(profile) - -- GHC-Options: -auto-all -with-rtsopts="-p -hc -smemop.txt" + GHC-Options: -auto-all -with-rtsopts="-p" else -- GHC-Options: -with-rtsopts=-N2 -M256m -H128m GHC-Options: -with-rtsopts=-N3 - -Executable FixPlayFen - Main-is: Main/MainFixPlayFen.hs - Build-depends: base >= 4.5, array, mtl, parsec, transformers, QuickCheck - GHC-Options: -O2 -Wall - -funbox-strict-fields -threaded -rtsopts - -fspec-constr-count=24 - -funfolding-use-threshold=32 - if flag(profile) - GHC-Options: -fprof-auto-top - -{- -Executable BenchTransTab - Main-is: Tests/TestTransTab.hs - Build-depends: base >= 4, array, mtl, parsec, criterion, QuickCheck - GHC-Options: -O2 -Wall - -funbox-strict-fields - -fspec-constr-count=4 -funfolding-use-threshold=32 - -Executable VizGraph - Main-is: Main/VizGraph.hs - Build-depends: base >= 4 - GHC-Options: -O2 - CPP-Options: -DVIZTREE - -Executable PlotEvolve - Main-is: Main/EvolveToPlot.hs - Build-depends: base >= 4, filepath, regex-compat - -Executable Evolve - Main-is: Main/MainEvolve.hs - Build-depends: base >= 4, process, filepath, bytestring, old-locale, async - GHC-Options: -O2 -Wall -threaded -rtsopts - -Executable CLOPDriver - Main-is: Main/MainCLOP.hs - Build-depends: base >= 4, process, filepath, bytestring, old-locale, async - GHC-Options: -O2 -Wall --} diff --git a/Eval/BasicEval.hs b/Eval/BasicEval.hs new file mode 100644 index 00000000..8928f397 --- /dev/null +++ b/Eval/BasicEval.hs @@ -0,0 +1,30 @@ +module Eval.BasicEval ( + matPiece +) where + +import Data.Array.Unboxed +import Data.Array.Base +import GHC.Arr (unsafeIndex) + +import Struct.Struct + +matvals :: UArray Piece Int +matvals = listArray (Pawn, King) [ 100, 325, 325, 500, 975, 20000 ] + +matPiece1 :: Piece -> Int +matPiece1 Pawn = 100 +matPiece1 Knight = 325 +matPiece1 Bishop = 325 +matPiece1 Rook = 500 +matPiece1 Queen = 975 +matPiece1 King = 20000 + +{-# INLINE matPiece #-} +matPiece :: Color -> Piece -> Int +{- +matPiece c p = case c of + White -> matPiece1 p + Black -> - matPiece1 p +-} +matPiece White = unsafeAt matvals . unsafeIndex (Pawn, King) +matPiece Black = negate . unsafeAt matvals . unsafeIndex (Pawn, King) diff --git a/Eval/Eval.hs b/Eval/Eval.hs new file mode 100644 index 00000000..945c520c --- /dev/null +++ b/Eval/Eval.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE BangPatterns, PatternGuards, ExistentialQuantification #-} +module Eval.Eval ( + initEvalState, + posEval, + maxStatsDepth, maxStatsIntvs, + inLimits, + paramNames, parLims, parDim +) where + +import Data.Array.Base (unsafeAt) +import Data.Bits hiding (popCount) +import Data.List +import Control.Monad.State.Lazy +import Data.Array.Unboxed + +import Struct.Struct +import Struct.Status +import Moves.Moves +import Moves.BitBoard +import Moves.Muster +-- import Eval.Gradient +import Eval.BasicEval + +-- Criteria (x2, once for every player): +-- + number of every piece (except king) (5 times) +-- + king safety 1st zone: opponents attacs & own defends (own & opponent's king) +-- * king safety 2nd zone: opponents attacs & own defends (own & opponent's king) +-- + king openness (attacs of a rook or bishop from the kings square) if the opponent has rook, bishop or queen +-- + attacs count +-- + attacs count in the center +-- + attacs count in the opponents fields +-- * pass pawns +-- * semifree pawns +-- * minimum squares to transform when pass +-- * minimum squares to transform when semi pass +-- * sum of squares to transform (all pawns) +-- * number of pawn groups +-- * number of undefended pieces + +type IParams = [Int] +type DParams = [Double] +type Limits = [(Double, Double)] + +class EvalItem a where + evalItem :: MyPos -> Color -> a -> IParams + evalItemNDL :: a -> [(String, (Double, (Double, Double)))] -- Name, Default, Limits + +-- some handy functions for eval item types: +paramName :: (a, b) -> a +paramName = fst + +paramDefault :: (a, (b, c)) -> b +paramDefault = fst . snd + +paramLimits :: (a, (b, c)) -> c +paramLimits = snd . snd + +data AnyEvalItem = forall a . EvalItem a => EvIt a + +-- This is the list of evaluated characteristics of a positions +-- Every item can have one or more parameters which have a name, a default value +-- and a range of values (values are kept for learning purposes as doubles, +-- but for the evaluation itself one copy of integer parameter values is also kept) +evalItems :: [AnyEvalItem] +evalItems = [ EvIt Material, -- material balance (i.e. white - black material + -- EvIt EnPrise, -- when not quiescent - pieces en prise + EvIt Redundance, -- bishop pair and rook redundance + EvIt NRCorrection, -- material correction for knights & rooks + EvIt RookPawn, -- the rook pawns are about 15% less valuable + EvIt KingSafe, -- king safety + EvIt KingOpen, -- malus for king openness + EvIt KingCenter, -- malus for king on center files + -- EvIt KingMob, -- bonus for restricted mobility of adverse king when alone + -- EvIt Castles, -- bonus for castle rights + EvIt LastLine, -- malus for pieces on last line (except rooks and king) + EvIt Mobility, -- pieces mobility + EvIt Center, -- attacs of center squares + -- EvIt DblPawns, -- malus for doubled pawns + EvIt PassPawns -- pass pawns + ] + +parDim :: Int +parDim = sum $ map evalLen evalItems + where evalLen (EvIt a) = length $ evalItemNDL a + +parLims :: [(Double, Double)] +parLims = concatMap evalLims evalItems + where evalLims (EvIt a) = map paramLimits $ evalItemNDL a + +zeroParam :: DParams +zeroParam = replicate parDim 0 -- theese are doubles + +zeroFeats :: [Int] +zeroFeats = replicate parDim 0 -- theese are ints + +evalItemPar :: EvalItem a => a -> DParams -> (String, Double) -> Maybe DParams +evalItemPar a dps (s, v) = lookup s (zip lu posi) >>= \i -> Just (replace dps i v) + where lu = map paramName $ evalItemNDL a + replace [] _ _ = [] + replace (_ : ds) 0 v' = v' : ds + replace (d : ds) i v' = d : replace ds (i-1) v' + posi = [0..] :: [Int] + +oneParam :: [(AnyEvalItem, DParams)] -> (String, Double) -> [(AnyEvalItem, DParams)] +oneParam [] _ = [] +oneParam (evp@(EvIt ei, dp) : evps) sd + | Just ndp <- evalItemPar ei dp sd = (EvIt ei, ndp) : evps + | otherwise = evp : oneParam evps sd + +-- Map a list of parameter assignments (name, value) +-- to a vector of parameter, taking defaults for missing parameters +allParams :: [(String, Double)] -> DParams +allParams = concatMap snd . foldl oneParam defevps + where defevps = map defp evalItems + defp ei@(EvIt a) = (ei, map paramDefault $ evalItemNDL a) + +paramNames :: [String] +paramNames = concatMap pnames evalItems + where pnames (EvIt a) = map paramName $ evalItemNDL a + +------------------------------------------------------------------ +-- Parameters of this module ------------ +granCoarse, granCoarse2, granCoarseM, maxStatsDepth, maxStatsIntvs :: Int +granCoarse = 4 -- coarse granularity +granCoarse2 = granCoarse `div` 2 +granCoarseM = complement (granCoarse - 1) +shift2Cp = 3 -- we have 2^shift2Cp units per centipawn +maxStatsDepth = 12 -- for error statistics of the eval function - maximum depth +maxStatsIntvs = 20 -- number of difference interval +-- statsIntv = 25 -- difference interval length + +subOptimal :: Double +subOptimal = 2 -- optimal step is so many times smaller + +samplesPerChange :: Int +samplesPerChange = 10 -- number of samples before a parameter change occurs +----------------------------------------------- + +initEvalState :: [(String, Double)] -> EvalState +initEvalState sds = EvalState { + esDParams = params, + esIParams = map round params + } + where params = inLimits parLims $ allParams sds + +inLimits :: Limits -> DParams -> DParams +inLimits ls ps = map inlim $ zip ls ps + where inlim ((mi, ma), p) = max mi $ min ma p + +(<*>) :: Num a => [a] -> [a] -> a +a <*> b = sum $ zipWith (*) a b +{-# SPECIALIZE (<*>) :: [Int] -> [Int] -> Int #-} + +matesc :: Int +matesc = 20000 - 255 -- attention, this is also defined in Base.hs!! + +posEval :: MyPos -> Color -> State EvalState (Int, [Int]) +posEval !p !c = do + sti <- get + let (sc''', feat) = evalDispatch p c sti + !sc' = if sc''' > matesc then matesc else if sc''' < -matesc then -matesc else sc''' + !sc'' = if granCoarse > 0 then (sc' + granCoarse2) .&. granCoarseM else sc' + !sc = if c == White then sc'' else -sc'' + return $! sc `seq` (sc, feat) + +evalDispatch :: MyPos -> Color -> EvalState -> (Int, [Int]) +evalDispatch p c sti + | pawns p == 0 = evalNoPawns p c sti + | pawns p .&. white p == 0 || + pawns p .&. black p == 0 = evalSideNoPawns p c sti + | otherwise = normalEval p c sti + +itemEval :: MyPos -> Color -> AnyEvalItem -> [Int] +itemEval p c (EvIt a) = evalItem p c a + +normalEval :: MyPos -> Color -> EvalState -> (Int, [Int]) +normalEval p c sti = (sc, feat) + where !feat = concatMap (itemEval p c) evalItems + !sc = feat <*> esIParams sti `shiftR` shift2Cp + +evalSideNoPawns :: MyPos -> Color -> EvalState -> (Int, [Int]) +evalSideNoPawns p c sti + | npwin && insufficient = (0, zeroFeats) + | otherwise = (nsc, feats) + where (nsc, feats) = normalEval p c sti + npside = if pawns p .&. white p == 0 then White else Black + npwin = npside == White && nsc > 0 || npside == Black && nsc < 0 + insufficient = majorcnt == 0 && (minorcnt == 1 || minorcnt == 2 && bishopcnt == 0) + col = if npside == White then white p else black p + bishopcnt = popCount1 $ bishops p .&. col + minorcnt = popCount1 $ (bishops p .|. knights p) .&. col + majorcnt = popCount1 $ (queens p .|. rooks p) .&. col + +-- These evaluation function distiguishes between some known finals with no pawns +evalNoPawns :: MyPos -> Color -> EvalState -> (Int, [Int]) +evalNoPawns p c sti = (sc, zeroFeats) + where !sc | onlykings = 0 + | kmk || knnk = 0 -- one minor or two knights + | kbbk = mateKBBK p kaloneb -- 2 bishops + | kbnk = mateKBNK p kaloneb -- bishop + knight + | kMxk = mateKMajxK p kaloneb -- simple mate with at least one major + -- | kqkx = mateQRest p kaloneb -- queen against minor or rook + | otherwise = fst $ normalEval p c sti + kalonew = white p `less` kings p == 0 + kaloneb = black p `less` kings p == 0 + onlykings = kalonew && kaloneb + kmk = (kalonew || kaloneb) && minorcnt == 1 && majorcnt == 0 + knnk = (kalonew || kaloneb) && minorcnt == 2 && majorcnt == 0 && bishops p == 0 + kbbk = (kalonew || kaloneb) && minorcnt == 2 && majorcnt == 0 && knights p == 0 + kbnk = (kalonew || kaloneb) && minorcnt == 2 && not (knnk || kbbk) + kMxk = (kalonew || kaloneb) && majorcnt > 0 + minor = bishops p .|. knights p + minorcnt = popCount1 minor + major = queens p .|. rooks p + majorcnt = popCount1 major + +winBonus :: Int +winBonus = 200 -- when it's known win + +mateKBBK :: MyPos -> Bool -> Int +mateKBBK p wwin = mater p + if wwin then sc else -sc + where kadv = if wwin then kb else kw + kw = kingSquare (kings p) (white p) + kb = kingSquare (kings p) (black p) + distk = squareDistance kw kb + distc = centerDistance kadv + sc = winBonus + distc*distc - distk*distk + +mateKBNK :: MyPos -> Bool -> Int +mateKBNK p wwin = mater p + if wwin then sc else -sc + where kadv = if wwin then kb else kw + kw = kingSquare (kings p) (white p) + kb = kingSquare (kings p) (black p) + distk = squareDistance kw kb + distc = bnMateDistance wbish kadv + wbish = bishops p .&. lightSquares /= 0 + sc = winBonus + distc*distc - distk*distk + +mateKMajxK :: MyPos -> Bool -> Int +mateKMajxK p wwin = mater p + if wwin then sc else -sc + where kadv = if wwin then kb else kw + kw = kingSquare (kings p) (white p) + kb = kingSquare (kings p) (black p) + distk = squareDistance kw kb + distc = centerDistance kadv + sc = winBonus + distc*distc - distk*distk + +-- This square distance should be pre calculated +squareDistance :: Square -> Square -> Int +squareDistance f t = max (abs (fr - tr)) (abs (fc - tc)) + where (fr, fc) = f `divMod` 8 + (tr, tc) = t `divMod` 8 + +-- This center distance should be pre calculated +centerDistance :: Int -> Int +centerDistance sq = max (r - 4) (3 - r) + max (c - 4) (3 - c) + where (r, c) = sq `divMod` 8 + +-- This distance for knight bishop mate should be pre calculated +-- Here we have to push the adverse king far from center and from the opposite bishop corners +bnMateDistance :: Bool -> Square -> Int +bnMateDistance wbish sq = min (squareDistance sq ocor1) (squareDistance sq ocor2) + where (ocor1, ocor2) = if wbish then (0, 63) else (7, 56) + +-- Some helper functions: + +{-# INLINE zoneAttacs #-} +zoneAttacs :: MyPos -> BBoard -> (Int, Int) +zoneAttacs p zone = (wh, bl) + where wh = popCount $ zone .&. whAttacs p + bl = popCount $ zone .&. blAttacs p + +---------------------------------------------------------------------------- +-- Here we have the implementation of the evaluation items +-- They do not return a score, but a vector of fulfillments of some criteria +-- With version 0.55 we compute everything from white point of view +-- and only at the end we negate the score if black side is asked +---------------------------------------------------------------------------- +------ King Safety ------ +data KingSafe = KingSafe + +instance EvalItem KingSafe where + evalItem p c _ = kingSafe p c + evalItemNDL _ = [("kingSafe", (1, (0, 20)))] + +-- Rewrite of king safety taking into account number and quality +-- of pieces attacking king neighbour squares +kingSafe :: MyPos -> Color -> [Int] +kingSafe p _ = [ksafe] + where !ksafe = wattacs - battacs + freew = popCount1 $ whKAttacs p .&. blAttacs p `less` white p + freeb = popCount1 $ blKAttacs p .&. whAttacs p `less` black p + flag k a = if k .&. a /= 0 then 1 else 0 + qual k a = popCount1 $ k .&. a + flagBlack = flag (whKAttacs p) + flagWhite = flag (blKAttacs p) + qualBlack = qual (whKAttacs p) + qualWhite = qual (blKAttacs p) + ($:) = flip ($) + attsw = map (p $:) [ whPAttacs, whNAttacs, whBAttacs, whRAttacs, whQAttacs, whKAttacs ] + fw = sum $ map flagWhite attsw + cw = sum $ zipWith (*) qualWeights $ map qualWhite attsw + ixw = max 0 $ min 63 $ fw * cw - freeb + attsb = map (p $:) [ blPAttacs, blNAttacs, blBAttacs, blRAttacs, blQAttacs, blKAttacs ] + fb = sum $ map flagBlack attsb + cb = sum $ zipWith (*) qualWeights $ map qualBlack attsb + ixb = max 0 $ min 63 $ fb * cb - freew + wattacs = attCoef `unsafeAt` ixw + battacs = attCoef `unsafeAt` ixb + qualWeights = [1, 1, 1, 2, 3, 1] + +attCoef :: UArray Int Int +attCoef = listArray (0, 63) [ f x | x <- [0..63] ] + where f :: Int -> Int + f x = let y = fromIntegral x :: Double in round $ (2.92968750 - 0.03051758*y)*y*y + +kingSquare :: BBoard -> BBoard -> Square +kingSquare kingsb colorp = head $ bbToSquares $ kingsb .&. colorp +{-# INLINE kingSquare #-} + +------ Material ------ +data Material = Material + +instance EvalItem Material where + evalItem p c _ = materDiff p c + evalItemNDL _ = [("materialDiff", (8, (8, 8)))] + +materDiff :: MyPos -> Color -> IParams +materDiff p _ = [mater p] + +------ King openness ------ +data KingOpen = KingOpen + +instance EvalItem KingOpen where + evalItem p c _ = kingOpen p c + evalItemNDL _ = [ ("kingOpenOwn", (-20, (-48, 1))), ("kingOpenAdv", (20, (0, 32)))] + +-- Openness can be tought only with pawns (like we take) or all pieces +kingOpen :: MyPos -> Color -> IParams +kingOpen p _ = own `seq` adv `seq` [own, adv] + where mopbishops = popCount1 $ bishops p .&. black p + moprooks = popCount1 $ rooks p .&. black p + mopqueens = popCount1 $ queens p .&. black p + mwb = popCount $ bAttacs paw msq `less` paw + mwr = popCount $ rAttacs paw msq `less` paw + yopbishops = popCount1 $ bishops p .&. white p + yoprooks = popCount1 $ rooks p .&. white p + yopqueens = popCount1 $ queens p .&. white p + ywb = popCount $ bAttacs paw ysq `less` paw + ywr = popCount $ rAttacs paw ysq `less` paw + paw = pawns p + msq = kingSquare (kings p) $ white p + ysq = kingSquare (kings p) $ black p + comb !oB !oR !oQ wb wr = + if oB /= 0 then oB * wb else 0 + + if oR /= 0 then oR * wr else 0 + + if oQ /= 0 then oQ * (wb + wr) else 0 + own = comb mopbishops moprooks mopqueens mwb mwr + adv = comb yopbishops yoprooks yopqueens ywb ywr + +------ King on a center file ------ +data KingCenter = KingCenter + +instance EvalItem KingCenter where + evalItem p c _ = kingCenter p c + evalItemNDL _ = [ ("kingCenter", (-120, (-200, 0))) ] + +kingCenter :: MyPos -> Color -> IParams +kingCenter p _ = [ kcd ] + where kcenter = fileC .|. fileD .|. fileE .|. fileF + !wkc = if kings p .&. white p .&. kcenter /= 0 then brooks + 2 * bqueens - 1 else 0 + !bkc = if kings p .&. black p .&. kcenter /= 0 then wrooks + 2 * wqueens - 1 else 0 + !kcd = wkc - bkc + wrooks = popCount1 $ rooks p .&. white p + wqueens = popCount1 $ queens p .&. white p + brooks = popCount1 $ rooks p .&. black p + bqueens = popCount1 $ queens p .&. black p + +------ Mobility ------ +data Mobility = Mobility -- "safe" moves + +instance EvalItem Mobility where + evalItem p c _ = mobDiff p c + evalItemNDL _ = [ ("mobilityKnight", (72, (60, 100))), + ("mobilityBishop", (72, (60, 100))), + ("mobilityRook", (48, (40, 100))), + ("mobilityQueen", (3, (0, 50))) ] + +-- Here we do not calculate pawn mobility (which, calculated as attacs, is useless) +mobDiff :: MyPos -> Color -> IParams +mobDiff p _ = [n, b, r, q] + where !whN = popCount1 $ whNAttacs p `less` (white p .|. blPAttacs p) + !whB = popCount1 $ whBAttacs p `less` (white p .|. blPAttacs p) + !whR = popCount1 $ whRAttacs p `less` (white p .|. blA1) + !whQ = popCount1 $ whQAttacs p `less` (white p .|. blA2) + !blA1 = blPAttacs p .|. blNAttacs p .|. blBAttacs p + !blA2 = blA1 .|. blRAttacs p + !blN = popCount1 $ blNAttacs p `less` (black p .|. whPAttacs p) + !blB = popCount1 $ blBAttacs p `less` (black p .|. whPAttacs p) + !blR = popCount1 $ blRAttacs p `less` (black p .|. whA1) + !blQ = popCount1 $ blQAttacs p `less` (black p .|. whA2) + !whA1 = whPAttacs p .|. whNAttacs p .|. whBAttacs p + !whA2 = whA1 .|. whRAttacs p + !n = whN - blN + !b = whB - blB + !r = whR - blR + !q = whQ - blQ + +------ Center control ------ +data Center = Center + +instance EvalItem Center where + evalItem p c _ = centerDiff p c + evalItemNDL _ = [("centerAttacs", (72, (50, 100)))] + +centerDiff :: MyPos -> Color -> IParams +centerDiff p _ = [wb] + where (w, b) = zoneAttacs p center + !wb = w - b + -- center = 0x0000001818000000 + center = 0x0000003C3C000000 + +------ En prise ------ +--data EnPrise = EnPrise +-- +--instance EvalItem EnPrise where +-- evalItem p c _ = enPrise p c +-- evalItemNDL _ = [("enPriseFrac", (10, (0, 100)))] + +-- Here we could also take care who is moving and even if it's check - now we don't +--enPrise :: MyPos -> Color -> IParams +--enPrise p _ = [epp] +-- where !ko = popCount1 $ white p .&. knights p .&. blAttacs p +-- !ka = popCount1 $ black p .&. knights p .&. whAttacs p +-- !bo = popCount1 $ white p .&. bishops p .&. blAttacs p +-- !ba = popCount1 $ black p .&. bishops p .&. whAttacs p +-- !ro = popCount1 $ white p .&. rooks p .&. blAttacs p +-- !ra = popCount1 $ black p .&. rooks p .&. whAttacs p +-- !qo = popCount1 $ white p .&. queens p .&. blAttacs p +-- !qa = popCount1 $ black p .&. queens p .&. whAttacs p +-- !k = (ka - ko) * matPiece White Knight +-- !b = (ba - bo) * matPiece White Bishop +-- !r = (ra - ro) * matPiece White Rook +-- !q = (qa - qo) * matPiece White Queen +-- !epp = (k + b + r + q) `div` 100 + +------ Castle rights ------ +--data Castles = Castles +-- +--instance EvalItem Castles where +-- evalItem p c _ = castles p c +-- evalItemNDL _ = [("castlePoints", (0, (-50, 200)))] + +-- This will have to be replaced, because not the castle rights are important, but +-- the king safety and the rook mobility +--castles :: MyPos -> Color -> IParams +--castles p _ = [crd] +-- where (ok, ork, orq, ak, ark, arq) = (4, 7, 0, 60, 63, 56) +-- !epc = epcas p +-- !okmoved = not $ epc `testBit` ok +-- !akmoved = not $ epc `testBit` ak +-- !orkc = if epc `testBit` ork then 1 else 0 +-- !arkc = if epc `testBit` ark then 1 else 0 +-- !orqc = if epc `testBit` orq then 1 else 0 +-- !arqc = if epc `testBit` arq then 1 else 0 +-- !co = if okmoved then 0 else orkc + orqc +-- !ca = if akmoved then 0 else arkc + arqc +-- !cdiff = co - ca +-- !qfact = popCount1 $ queens p +-- !rfact = popCount1 $ rooks p +-- !crd = cdiff * (2 * qfact + rfact) + +------ Last Line ------ +data LastLine = LastLine + +instance EvalItem LastLine where + evalItem p c _ = lastline p c + evalItemNDL _ = [("lastLinePenalty", (8, (0, 24)))] + +lastline :: MyPos -> Color -> IParams +lastline p _ = [cdiff] + where !whl = popCount1 $ (white p `less` (rooks p .|. kings p)) .&. 0xFF + !bll = popCount1 $ (black p `less` (rooks p .|. kings p)) .&. 0xFF00000000000000 + !cdiff = bll - whl + +------ King Mobility when alone ------ +--data KingMob = KingMob +-- +--instance EvalItem KingMob where +-- evalItem p c _ = kingAlone p c +-- evalItemNDL _ = [("advKingAlone", (26, (0, 100)))] +-- +--kingAlone :: MyPos -> Color -> IParams +--kingAlone p _ = [kmb] +-- where !kmb = if okalone then 8 - okmvs + together else 0 +-- !together = popCount1 $ whKAttacs p .&. blKAttacs p +-- !okmvs = popCount1 $ blAttacs p +-- !okalone = black p `less` kings p == 0 + +------ Redundance: bishop pair and rook redundance ------ +data Redundance = Redundance + +instance EvalItem Redundance where + evalItem p c _ = evalRedundance p c + evalItemNDL _ = [("bishopPair", (320, (100, 400))), + ("redundanceRook", (-104, (-150, 0))) ] + +evalRedundance :: MyPos -> Color -> [Int] +evalRedundance p _ = [bp, rr] + where !wbl = bishops p .&. white p .&. lightSquares + !wbd = bishops p .&. white p .&. darkSquares + !bbl = bishops p .&. black p .&. lightSquares + !bbd = bishops p .&. black p .&. darkSquares + !bpw = if wbl /= 0 && wbd /= 0 then 1 else 0 + !bpb = if bbl /= 0 && bbd /= 0 then 1 else 0 + !bp = bpw - bpb + !wro = rooks p .&. white p + !bro = rooks p .&. black p + !wrr = if wro > 1 then 1 else 0 + !brr = if bro > 1 then 1 else 0 + !rr = wrr - brr + +------ Knight & Rook correction according to own pawns ------ +data NRCorrection = NRCorrection + +instance EvalItem NRCorrection where + evalItem p _ _ = evalNRCorrection p + evalItemNDL _ = [("nrCorrection", (0, (0, 8)))] + +evalNRCorrection :: MyPos -> [Int] +evalNRCorrection p = [md] + where !wpc = popCount1 (pawns p .&. white p) - 5 + !bpc = popCount1 (pawns p .&. black p) - 5 + !wnp = popCount1 (knights p .&. white p) * wpc * 6 -- 1/16 for each pawn over 5 + !bnp = popCount1 (knights p .&. black p) * bpc * 6 -- 1/16 for each pawn over 5 + !wrp = - popCount1 (rooks p .&. white p) * wpc * 12 -- 1/8 for each pawn under 5 + !brp = - popCount1 (rooks p .&. black p) * bpc * 12 -- 1/8 for each pawn under 5 + !md = wnp + wrp - bnp - brp + +------ Rook pawn weakness ------ +data RookPawn = RookPawn + +instance EvalItem RookPawn where + evalItem p c _ = evalRookPawn p c + evalItemNDL _ = [("rookPawn", (-64, (-120, 0))) ] + +evalRookPawn :: MyPos -> Color -> [Int] +evalRookPawn p _ = [rps] + where !wrp = popCount1 $ pawns p .&. white p .&. rookFiles + !brp = popCount1 $ pawns p .&. black p .&. rookFiles + !rps = wrp - brp + +------ Pass pawns ------ +data PassPawns = PassPawns + +whitePassPBBs, blackPassPBBs :: UArray Square BBoard +whitePassPBBs = array (0, 63) [(sq, wPassPBB sq) | sq <- [0 .. 63]] +blackPassPBBs = array (0, 63) [(sq, bPassPBB sq) | sq <- [0 .. 63]] + +wPassPBB :: Square -> BBoard +wPassPBB sq = foldl' (.|.) 0 $ takeWhile (/= 0) $ iterate (`shiftL` 8) bsqs + where bsq = bit sq + bsq8 = bsq `shiftL` 8 + bsq7 = if bsq .&. fileA /= 0 then 0 else bsq `shiftL` 7 + bsq9 = if bsq .&. fileH /= 0 then 0 else bsq `shiftL` 9 + bsqs = bsq7 .|. bsq8 .|. bsq9 + +bPassPBB :: Square -> BBoard +bPassPBB sq = foldl' (.|.) 0 $ takeWhile (/= 0) $ iterate (`shiftR` 8) bsqs + where bsq = bit sq + bsq8 = bsq `shiftR` 8 + bsq7 = if bsq .&. fileH /= 0 then 0 else bsq `shiftR` 7 + bsq9 = if bsq .&. fileA /= 0 then 0 else bsq `shiftR` 9 + bsqs = bsq7 .|. bsq8 .|. bsq9 + +instance EvalItem PassPawns where + evalItem p c _ = passPawns p c + evalItemNDL _ = [("passPawnBonus", (104, ( 0, 160))), + ("passPawn4", (424, (400, 480))), + ("passPawn5", (520, (520, 640))), + ("passPawn6", (1132, (1100, 1200))), + ("passPawn7", (1920, (1600, 2300))) ] + +passPawns :: MyPos -> Color -> IParams +passPawns p _ = [dfp, dfp4, dfp5, dfp6, dfp7] + where !wfpbb = foldl' (.|.) 0 $ map bit $ filter wpIsPass $ bbToSquares wpawns + !bfpbb = foldl' (.|.) 0 $ map bit $ filter bpIsPass $ bbToSquares bpawns + !wfp = popCount1 wfpbb + !wfp4 = popCount1 $ wfpbb .&. row4 + !wfp5 = popCount1 $ wfpbb .&. row5 + !wfp6 = popCount1 $ wfpbb .&. row6 + !wfp7 = popCount1 $ wfpbb .&. row7 + !bfp = popCount1 bfpbb + !bfp4 = popCount1 $ bfpbb .&. row5 + !bfp5 = popCount1 $ bfpbb .&. row4 + !bfp6 = popCount1 $ bfpbb .&. row3 + !bfp7 = popCount1 $ bfpbb .&. row2 + !wpawns = pawns p .&. white p + !bpawns = pawns p .&. black p + !dfp = wfp - bfp + !dfp4 = wfp4 - bfp4 + !dfp5 = wfp5 - bfp5 + !dfp6 = wfp6 - bfp6 + !dfp7 = wfp7 - bfp7 + wpIsPass sq = (whitePassPBBs!sq) .&. bpawns == 0 + bpIsPass sq = (blackPassPBBs!sq) .&. wpawns == 0 +-------------------------------------- diff --git a/Eval/FileParams.hs b/Eval/FileParams.hs new file mode 100644 index 00000000..bb41edb3 --- /dev/null +++ b/Eval/FileParams.hs @@ -0,0 +1,55 @@ +module Eval.FileParams ( + makeEvalState, + fileToState + ) where + +import Data.Char (isSpace) +import Data.List (tails, intersperse) +import System.Directory + +import Struct.Status(EvalState) +import Eval.Eval (initEvalState) + +-- Opens a parameter file for eval, read it and create an eval state +makeEvalState :: Maybe FilePath -> String -> String -> IO (FilePath, EvalState) +makeEvalState argfile pver psuff = + case argfile of + Just afn -> do -- config file as argument + fex <- doesFileExist afn + if fex then filState afn afn else defState + Nothing -> go $ configFileNames pver psuff + where defState = return ("", initEvalState []) + go [] = defState + go (f:fs) = do + fex <- doesFileExist f + if fex then filState f "" else go fs + +filState :: FilePath -> String -> IO (String, EvalState) +filState fn ident = do + est <- fileToState fn + return (ident, est) + +fileToState :: FilePath -> IO EvalState +fileToState fn = fileToParams `fmap` readFile fn >>= return . initEvalState + +-- This produces a list of config file names depending on +-- program version and programm version suffix +-- The most specific will be first, the most general last +configFileNames :: String -> String -> [String] +configFileNames pver psuff = map cfname $ tails [psuff, pver] + where fnprf = "evalParams" + fnsuf = ".txt" + cfname = concat . (++ [fnsuf]) . intersperse "-" . (fnprf :) . reverse + +fileToParams :: String -> [(String, Double)] +fileToParams = map readParam . nocomments . lines + where nocomments = filter (not . iscomment) + iscomment [] = True + iscomment ('-':'-':_) = True + iscomment (c:cs) | isSpace c = iscomment cs + iscomment _ = False + +readParam :: String -> (String, Double) +readParam s = let (ns, vs) = span (/= '=') s in (strip ns, cleanread vs) + where strip = filter (not . isSpace) + cleanread = read . tail . strip diff --git a/Hash/TransTab.hs b/Hash/TransTab.hs new file mode 100644 index 00000000..b7429172 --- /dev/null +++ b/Hash/TransTab.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +module Hash.TransTab ( + Cache, newCache, readCache, writeCache, newGener, + checkProp + ) where + +import Data.Bits +import Data.Maybe (fromMaybe) +import Data.Int +import Data.Word +import Foreign.Marshal.Array +import Foreign.Storable +import Foreign.Ptr +import Test.QuickCheck hiding ((.&.)) + +import Struct.Struct + +type Index = Int +type Mask = Word64 + +cacheLineSize :: Int +cacheLineSize = 64 -- this should be the size in bytes of a memory cache line on modern processors + +-- The data type Cell and its Storable instance is declared only for alignement purposes +-- The operations in the cell are done on PCacheEn elements +data Cell + +instance Storable Cell where + sizeOf _ = cacheLineSize + alignment _ = cacheLineSize + peek _ = return undefined + poke _ _ = return () + +data Cache + = Cache { + mem :: Ptr Cell, -- the cache line aligned byte array for the data + lomask, mimask, + himask :: !Mask, -- masks depending on the size (in entries) of the table + gener :: !Word64 -- the generation of the current search + } + +data PCacheEn = PCacheEn { lo, hi :: {-# UNPACK #-} !Word64 } -- a packed TT entry + +pCacheEnSize :: Int +pCacheEnSize = 2 * sizeOf (undefined :: Word64) -- i.e. 16 bytes + +instance Storable PCacheEn where + sizeOf _ = pCacheEnSize + alignment _ = alignment (undefined :: Word64) + {-# INLINE peek #-} + peek e = let q = castPtr e + in do w1 <- peekElemOff q 0 + w2 <- peekElemOff q 1 + return $ PCacheEn { lo = w1, hi = w2 } + {-# INLINE poke #-} + poke e (PCacheEn { lo = w1, hi = w2 }) + = let q = castPtr e + in do pokeElemOff q 0 w1 + pokeElemOff q 1 w2 + +{-- +A packed cache entry consists of 2 Word64 parts (the order of the bit fields is fixed): +- word 1 (high) contains (ttbitlen is the number of bits to represent the table length in cells, + i.e. for 2^18 cells, ttbitlen = 18): + - part 1 of the ZKey: - the first (64 - ttbitlen - 2) higher bits of the ZKey + - unused bits - variable length depending on number of tt entries (= ttbitlen - 16) + - score - 16 bits + - part 3 of the ZKey: the last 2 bits +- word 2 (low) contains: + - nodes - 32 bits + - node type - 2 bit: exact = 2, lower = 1, upper = 0 + - depth - 5 bits + - move - 19 bits + - generation - 6 bits +It results that anyway the number of entries in the table must be at least 2^18 +(i.e. 2^16 cells with 4 entries each), in which case the "unused bits" part is empty (0 bits). +Part 2 of the ZKey is the cell number where the entry resides. + +These are fields of the word 1 and the masks that we keep (here for minimum of 2^18 entries): +|6 5 2 1 0| +|32109...1098765432109876543210| +|<--part 1--><----score-----><>| +|<--himask--><-----lomask----->| lomask and mimask cover also the unused bits, if any, +|... ...<-----mimask--->..| and the himask is shorter in that case +--} + +part3Mask :: Mask +part3Mask = 0x03 :: Mask -- the cell has 4 entries (other option: 8) + +minEntries :: Int +minEntries = 2 ^ 18 + +-- Create a new transposition table with a given number of entries +-- The given number will be rounded up to the next power of 2 +newCache :: Int -> IO Cache +newCache c = do + let nentries = max minEntries $ nextPowOf2 c + ncells = nentries `div` 4 -- 4 entries per cell + lom = fromIntegral $ nentries - 1 + mim = lom .&. cellMask + memc <- mallocArray ncells + return Cache { mem = memc, lomask = lom, mimask = mim, himask = complement lom, gener = 0 } + where cellMask = complement part3Mask -- for speed we keep both masks + +-- Increase the generation by 1 for a new search, wrap on 6 bits (i.e. 0 to 63) +newGener :: Cache -> Cache +newGener c = c { gener = (gener c + 1) .&. 0x3F } + +-- This computes the adress of the first entry of the cell where an entry given by the key +-- should be stored, and the (ideal) index of that entry +-- The (low) mask of the transposition table is also used - this determines the size of the index +zKeyToCellIndex :: Cache -> ZKey -> (Ptr PCacheEn, Index) +zKeyToCellIndex tt zkey = (base, idx) + where idx = fromIntegral $ zkey .&. lomask tt + -- This is the wanted calculation: + -- cell = idx `unsafeShiftR` 2 -- 2 because we have 4 entries per cell + -- base = mem tt `plusPtr` (cell * sizeOf Cell) + -- NB: plusPtr advances Bytes! + -- And this is how it is done efficiently: + -- idx is entry number, we want cell number: 4 entries per cell ==> shiftR 2 + -- plusPtr needs bytes, 16 bytes/entry * 4 entries/cell = 64 bytes/cell ==> shiftL 6 + !base = mem tt `plusPtr` ((idx `unsafeShiftR` 2) `unsafeShiftL` 6) + +-- Retrieve the ZKey of a packed entry +getZKey :: Cache -> Index -> PCacheEn -> ZKey +getZKey tt idx (PCacheEn {hi = w1}) = zkey + where !zkey = w1 .&. himask tt -- the first part of the stored ZKey + .|. widx .&. mimask tt -- the second part of the stored ZKey + .|. w1 .&. part3Mask -- the 3rd part of stored ZKey + widx = fromIntegral idx + +-- Given a ZKey, an index and a packed cache entry, determine if that entry has the same ZKey +isSameEntry :: Cache -> ZKey -> Index -> PCacheEn -> Bool +isSameEntry tt zkey idx pCE = zkey == getZKey tt idx pCE + +-- Search a position in table based on ZKey +-- The position ZKey determines the cell where the TT entry should be, and there we do a linear search +-- (i.e. 4 comparisons in case of a miss) +readCache :: Cache -> ZKey -> IO (Maybe (Int, Int, Int, Move, Int)) +readCache tt zkey = do + mpce <- retrieveEntry tt zkey + return $! fmap cacheEnToQuint mpce + +retrieveEntry :: Cache -> ZKey -> IO (Maybe PCacheEn) +retrieveEntry tt zkey = do + let (bas, idx) = zKeyToCellIndex tt zkey + retrieve idx bas (4::Int) + where retrieve idx = go + where go !crt0 !tries0 = do + pCE <- peek crt0 + if isSameEntry tt zkey idx pCE + then return (Just pCE) + else if tries0 <= 1 + then return Nothing + else do + let crt1 = crt0 `plusPtr` pCacheEnSize + tries1 = tries0 - 1 + go crt1 tries1 + +-- Write the position in the table +-- We want to keep table entries that: +-- + are from the same generation, or +-- + have more nodes behind (from a previous search), or +-- + have been searched deeper, or +-- + have a more precise score (node type 2 before 1 and 0) +-- That's why we choose the order in second word like it is (easy comparison) +-- Actually we always search in the whole cell in the hope to find the zkey and replace it +-- but also keep track of the weakest entry in the cell, which will be replaced otherwise +writeCache :: Cache -> ZKey -> Int -> Int -> Int -> Move -> Int -> IO () +writeCache tt zkey depth tp score move nodes = do + let (bas, idx) = zKeyToCellIndex tt zkey + gen = gener tt + pCE = quintToCacheEn tt zkey depth tp score move nodes + store gen pCE idx bas bas (4::Int) + where store gen pCE idx = go + where go !crt0 !rep0 !tries0 = do + cpCE <- peek crt0 + if isSameEntry tt zkey idx cpCE + then poke crt0 pCE -- here we found the same entry: just update + else if tries0 <= 1 + then poke rep0 pCE -- replace the weakest entry with the current one + else do -- search further + rep1 <- chooseReplaceEntry gen crt0 rep0 + let crt1 = crt0 `plusPtr` pCacheEnSize + tries1 = tries0 - 1 + go crt1 rep1 tries1 + +-- Here we implement the logic which decides which entry is weaker +-- If the current entry has the current generation then we consider the old replacement to be weaker +-- without to consider other criteria in case it has itself the current generation +chooseReplaceEntry :: Word64 -> Ptr PCacheEn -> Ptr PCacheEn -> IO (Ptr PCacheEn) +chooseReplaceEntry gen crt rep = if rep == crt then return rep else do + crte <- peek crt + if generation crte == gen + then return rep + else do + repe <- peek rep + if betterpart repe > betterpart crte + then return crt + else return rep + where generation = (.&. 0x3F) . lo + betterpart = lo -- there is some noise at the end of that word (26 bits), but we don't care + +quintToCacheEn :: Cache -> ZKey -> Int -> Int -> Int -> Move -> Int -> PCacheEn +quintToCacheEn tt zkey depth tp score (Move move) nodes = pCE + where w1 = (zkey .&. himask tt) + .|. fromIntegral ((score .&. 0xFFFF) `unsafeShiftL` 2) + .|. (zkey .&. part3Mask) + w2 = (fromIntegral nodes `unsafeShiftL` 32) + .|. (fromIntegral tp `unsafeShiftL` 30) + .|. (fromIntegral depth `unsafeShiftL` 25) + .|. (fromIntegral move `unsafeShiftL` 6) + .|. gener tt + !pCE = PCacheEn { hi = w1, lo = w2 } + +cacheEnToQuint :: PCacheEn -> (Int, Int, Int, Move, Int) +cacheEnToQuint (PCacheEn { hi = w1, lo = w2 }) = (de, ty, sc, Move mv, no) + where scp = (w1 .&. 0x3FFFF) `unsafeShiftR` 2 + ssc = (fromIntegral scp) :: Int16 + !sc = fromIntegral ssc + !no = fromIntegral $ w2 `unsafeShiftR` 32 + -- w2low = (fromIntegral (w2 .&. 0xFFFFFFFF)) :: Word32 + w2low = (fromIntegral w2) :: Word32 -- does it work so? + w21 = w2low `unsafeShiftR` 6 -- don't need the generation + !mv = fromIntegral $ w21 .&. 0x7FFFF + w22 = w21 `unsafeShiftR` 19 + !de = fromIntegral $ w22 .&. 0x1F + !ty = fromIntegral $ w22 `unsafeShiftR` 5 + -- perhaps is not a good idea to make them dependent on each other + -- this must be tested and optimised for speed + +nextPowOf2 :: Int -> Int +nextPowOf2 x = bit (l - 1) + where pow2s = iterate (* 2) 1 + l = length $ takeWhile (<= x) pow2s + +----------- QuickCheck ------------- +newtype Quint = Q (Int, Int, Int, Move, Int) deriving Show + +mvm = (1 `shiftL` 19) - 1 :: Word32 + +instance Arbitrary Quint where + arbitrary = do + sc <- choose (-20000, 20000) + ty <- choose (0, 2) + de <- choose (0, 31) + mv <- arbitrary `suchThat` (<= mvm) + no <- arbitrary `suchThat` (>= 0) + return $ Q (de, ty, sc, Move mv, no) + +{-- +newtype Gener = G Int +instance Arbitrary Gener where + arbitrary = do + g <- arbitrary `suchThat` (inRange (0, 256)) + return $ G g +--} + +prop_Inverse :: Cache -> ZKey -> Int -> Quint -> Bool +prop_Inverse tt zkey _ (Q q@(de, ty, sc, mv, no)) -- unused: gen + = q == cacheEnToQuint (quintToCacheEn tt zkey de ty sc mv no) + +checkProp :: IO () +checkProp = do + tt <- newCache 128 + let zkey = 0 + gen = 0 :: Int + putStrLn $ "Fix zkey & gen: " ++ show zkey ++ ", " ++ show gen + -- quickCheck $ prop_Inverse tt zkey gen + verboseCheck $ prop_Inverse tt zkey gen + putStrLn $ "Arbitrary zkey, fixed gen = " ++ show gen + -- quickCheck $ \z -> prop_Inverse tt z gen + verboseCheck $ \z -> prop_Inverse tt z gen +{-- + putStrLn $ "Arbitrary gen, fixed zkey = " ++ show gen + -- quickCheck $ \g -> prop_Inverse tt zkey g + verboseCheck $ \(G g) -> do let tt' = head $ drop g (iterate newGener tt) + return $ prop_Inverse tt zkey g +--} diff --git a/Hash/Zobrist.hs b/Hash/Zobrist.hs new file mode 100644 index 00000000..028d5272 --- /dev/null +++ b/Hash/Zobrist.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} + +module Hash.Zobrist ( + ZKey, + zobrist, + zobMove, + zobPiece, + zobCastKw, zobCastQw, zobCastKb, zobCastQb, + zobEP +) where + +import Data.Array.Base +import Data.Array.IArray +import Data.Array.Unboxed +import Data.Bits +import GHC.Arr (unsafeIndex) +import Data.Word +import System.Random +import Foreign.Storable +import Control.Exception (assert) + +import Struct.Struct + +genInit = 118863 +zLen = 781 + +zobrist :: UArray Int ZKey +zobrist = array (0, zLen-1) $ take zLen $ zip [0..] randomW64s + +w32Tow64 :: [Word64] -> [Word64] +w32Tow64 (x:y:ws) = w : w32Tow64 ws + where w = (x `shift` 32) .|. y + +randomInts :: [Int] +randomInts = randoms (mkStdGen genInit) + +randomW64s :: [ZKey] +randomW64s = toW64 $ map fromIntegral randomInts + where isize = sizeOf (undefined :: Word) + toW64 = case isize of + 64 -> id + _ -> w32Tow64 + +-- When black is moving: xor with that number +zobMove :: ZKey +zobMove = fromIntegral $ zobrist `unsafeAt` (12*64) + +-- For every pice type of every color on every valid +-- field: one index in zobrist (0 to 12*64-1) +{-# INLINE zobPiece #-} +zobPiece :: Color -> Piece -> Square -> ZKey +zobPiece White p sq = zobrist `unsafeAt` idx + where !idx = (p2intw `unsafeAt` unsafeIndex (Pawn, King) p) + sq +zobPiece Black p sq = zobrist `unsafeAt` idx + where !idx = (p2intb `unsafeAt` unsafeIndex (Pawn, King) p) + sq + +p2intw, p2intb :: UArray Piece Int +p2intw = array (Pawn, King) $ zip [Pawn .. King] [0, 64 .. ] +p2intb = array (Pawn, King) $ zip [Pawn .. King] [b0, b1 .. ] + where b0 = p2intw!King + 64 + b1 = b0 + 64 + +zobCastBegin = 12*64+1 +zobCastKw = zobrist `unsafeAt` zobCastBegin +zobCastQw = zobrist `unsafeAt` (zobCastBegin + 1) +zobCastKb = zobrist `unsafeAt` (zobCastBegin + 2) +zobCastQb = zobrist `unsafeAt` (zobCastBegin + 3) + +zobEP :: Int -> ZKey +zobEP x = assert (x >= 1 && x <= 8) $ zobrist `unsafeAt` (zobCastBegin + 3 + x) diff --git a/Main/Barbarossa.hs b/Main/Barbarossa.hs index 8a098408..a5049af6 100644 --- a/Main/Barbarossa.hs +++ b/Main/Barbarossa.hs @@ -1,11 +1,15 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveDataTypeable #-} module Main where +import Prelude hiding (catch) import Control.Monad import Control.Monad.Reader +import Control.Concurrent +import Control.Exception import Data.Array.Unboxed import Data.Maybe -import Control.Concurrent -import qualified Control.Exception as CE +import Data.Typeable +import System.Console.GetOpt import System.Environment (getArgs) import System.IO import System.Time @@ -13,7 +17,6 @@ import System.Time import Struct.Struct import Struct.Status import Struct.Context -import Config.ConfigClass import Hash.TransTab import Uci.UCI import Uci.UciGlue @@ -42,34 +45,35 @@ defaultOptions :: Options defaultOptions = Options { optConfFile = Nothing, optParams = [], - optLogging = LogError + optLogging = LogInfo } setConfFile :: String -> Options -> Options -setConfFile cf opt = opt { optConfFile = Just sc } +setConfFile cf opt = opt { optConfFile = Just cf } addParam :: String -> Options -> Options addParam pa opt = opt { optParams = pa : optParams opt } -setLogging :: Int -> Options -> Options +setLogging :: String -> Options -> Options setLogging lev opt = opt { optLogging = llev } - where llev = case lev of + where llev = case levi of 0 -> DebugSearch 1 -> DebugUci 2 -> LogInfo 3 -> LogWarning 4 -> LogError - _ -> if llev < 0 then DebugSearch else LogNever + _ -> if levi < 0 then DebugSearch else LogNever + levi = read lev :: Int options :: [OptDescr (Options -> Options)] options = [ - Option ['c'] ["config"] (ReqArg setConfFile "STRING") "Configuration file", - Option ['l'] ["loglev"] (ReqArg setLogging "INT") "Logging level: 0=debug, 5=never" - Option ['p'] ["param"] (ReqArg addParam "STRING") "Eval parameters: name=value,..." + Option ['c'] ["config"] (ReqArg setConfFile "STRING") "Configuration file", + Option ['l'] ["loglev"] (ReqArg setLogging "STRING") "Logging level from 0 (debug) to 5 (never)", + Option ['p'] ["param"] (ReqArg addParam "STRING") "Eval parameters: name=value,..." ] theOptions :: IO (Options, [String]) -theOptions argv = do +theOptions = do args <- getArgs case getOpt Permute options args of (o, n, []) -> return (foldr ($) defaultOptions o, n) @@ -79,15 +83,14 @@ theOptions argv = do initContext :: Options -> IO Context initContext opts = do clktm <- getClockTime - let llev = getIParamDefault cfg "logLevel" 0 - mlchan <- newChan + let llev = optLogging opts + lchan <- newChan wchan <- newChan ichan <- newChan - ha <- newCache cfg + ha <- newCache 1 -- it will take the minimum number of entries hi <- newHist (parc, evs) <- makeEvalState (optConfFile opts) progVersion progVerSuff let chg = Chg { - config = cf, working = False, compThread = Nothing, crtStatus = posToState initPos ha hi evs, @@ -97,7 +100,7 @@ initContext opts = do } ctxVar <- newMVar chg let context = Ctx { - logger = mlchan, + logger = lchan, writer = wchan, inform = ichan, strttm = clktm, @@ -109,15 +112,14 @@ initContext opts = do main :: IO () main = do - opts <- theOptions + (opts, _) <- theOptions ctx <- initContext opts runReaderT startTheMachine ctx startTheMachine :: CtxIO () startTheMachine = do ctx <- ask - let TOD crts _ = strttm ctx - logFileName = progLogName ++ show crtt ++ ".log" + let logFileName = progLogName ++ "-" ++ show (startSecond ctx) ++ ".log" startLogger logFileName startWriter startInformer @@ -138,16 +140,16 @@ data LoggerState = LoggerFile String startLogger :: String -> CtxIO () startLogger file = do ctx <- ask - _ <- liftIO $ forkIO $ CE.catch (theLogger (logger ctx) (LoggerFile file)) collectError + void $ liftIO $ forkIO $ catch (theLogger (logger ctx) (LoggerFile file)) collectError ctxLog LogInfo "Logger started" theLogger :: Chan String -> LoggerState -> IO () theLogger lchan lst = do s <- readChan lchan case lst of - LoggerError -> theLogger lchan lst - LoggerFile -> flip CE.catch collectError $ do - h <- openFile file AppendMode + LoggerError -> theLogger lchan lst + LoggerFile f -> flip catch collectError $ do + h <- openFile f AppendMode hPutStrLn h s hFlush h theLogger lchan (LoggerHandle h) @@ -161,15 +163,15 @@ theLogger lchan lst = do startWriter :: CtxIO () startWriter = do ctx <- ask - _ <- liftIO $ forkIO $ theWriter (writer ctx) (logger ctx) - return () + void $ liftIO $ forkIO + $ theWriter (writer ctx) (logger ctx) (LogInfo >= loglev ctx) (startSecond ctx) -theWriter :: Chan String -> Chan String -> Bool -> IO () -theWriter wchan lchan log = forever $ do +theWriter :: Chan String -> Chan String -> Bool -> Integer -> IO () +theWriter wchan lchan mustlog refs = forever $ do s <- readChan wchan hPutStrLn stdout s hFlush stdout - when log $ logging lchan $ "Output: " ++ s + when mustlog $ logging lchan refs "Output" s -- The informer is getting structured data -- and formats it to a string which is set to the writer @@ -177,7 +179,7 @@ theWriter wchan lchan log = forever $ do startInformer :: CtxIO () startInformer = do ctx <- ask - _ <- newThread (theInformer (inform ctx)) + void $ newThread (theInformer (inform ctx)) return () theInformer :: Chan InfoToGui -> CtxIO () @@ -198,11 +200,12 @@ toGui s = case s of theReader :: CtxIO () theReader = do line <- liftIO getLine + ctxLog DebugUci $ "Input: " ++ line let euci = parseUciStr line stop <- case euci of Left _ -> do - ctxLog DebugUci $ "Input: " ++ line - ctxLog DebugUci $ "Parse: " ++ show euci + ctxLog LogWarning $ "Input: " ++ line + ctxLog LogWarning $ "Parse: " ++ show euci return False Right uci -> interpret uci unless stop theReader @@ -235,7 +238,9 @@ doUci = do answer (idName ++ " " ++ evid) >> answer idAuthor >> answer uciOk doIsReady :: CtxIO () -doIsReady = when (movesInit == 0) $ answer readyOk +doIsReady = do + when (movesInit == 0) $ return () + answer readyOk ignore :: CtxIO () ignore = notImplemented "ignored" @@ -288,8 +293,8 @@ doGo cmds = do else if Ponder `elem` cmds then ctxLog DebugUci "Just ponder: ignored" else do - md <- getIParamDef "maxDepth" 20 let (tim, tpm, mtg) = getTimeParams cmds lastsc $ myColor chg + md = 20 -- max search depth dpt = fromMaybe md (findDepth cmds) lastsc = case forGui chg of Just InfoB { infoScore = sc } -> sc @@ -344,7 +349,8 @@ newThread a = do startWorking :: Int -> Int -> Int -> Int -> CtxIO () startWorking tim tpm mtg dpt = do - currms <- lift currMilli + ctx <- ask + currms <- lift $ currMilli (startSecond ctx) ctxLog DebugUci $ "Start at " ++ show currms ++ " to search: " ++ show tim ++ " / " ++ show tpm ++ " / " ++ show mtg ++ " - maximal " ++ show dpt ++ " plys" @@ -359,9 +365,8 @@ startWorking tim tpm mtg dpt = do -- This is not good, then it can lead to race conditions. We should -- find another scheme, for example with STM startSearchThread :: Int -> Int -> Int -> Int -> CtxIO () -startSearchThread tim tpm mtg dpt = do - fd <- getIParamDef "firstDepth" 1 - ctxCatch (searchTheTree fd dpt 0 tim tpm mtg Nothing [] []) +startSearchThread tim tpm mtg dpt = + ctxCatch (searchTheTree 1 dpt 0 tim tpm mtg Nothing [] []) $ \e -> do chg <- readChanging let mes = "searchTheTree terminated by exception: " ++ show e @@ -369,17 +374,18 @@ startSearchThread tim tpm mtg dpt = do case forGui chg of Just ifg -> giveBestMove $ infoPv ifg Nothing -> return () - ctx <- ask - case logger ctx of - Just _ -> ctxLog LogError mes - Nothing -> return () - lift $ collectError mes + ctxLog LogError mes + lift $ collectError $ SomeException (SearchException mes) -- Why? liftIO $ threadDelay $ 50*1000 -- give time to send the ans -ctxCatch :: CtxIO a -> (CE.SomeException -> CtxIO a) -> CtxIO a +data SearchException = SearchException String deriving (Show, Typeable) + +instance Exception SearchException + +ctxCatch :: CtxIO a -> (SomeException -> CtxIO a) -> CtxIO a ctxCatch a f = do ctx <- ask - liftIO $ CE.catch (runReaderT a ctx) + liftIO $ catch (runReaderT a ctx) (\e -> runReaderT (f e) ctx) internalStop :: Int -> CtxIO () @@ -396,13 +402,14 @@ betterSc = 25 -- Search with the given depth searchTheTree :: Int -> Int -> Int -> Int -> Int -> Int -> Maybe Int -> [Move] -> [Move] -> CtxIO () searchTheTree tief mtief timx tim tpm mtg lsc lpv rmvs = do + ctx <- ask chg <- readChanging ctxLog LogInfo $ "Time = " ++ show tim ++ " Timx = " ++ show timx (path, sc, rmvsf, stfin) <- bestMoveCont tief timx (crtStatus chg) lsc lpv rmvs case length path of _ -> return () -- because of lazyness! storeBestMove path sc -- write back in status modifyChanging (\c -> c { crtStatus = stfin }) - currms <- lift currMilli + currms <- lift $ currMilli (startSecond ctx) let (ms', mx) = compTime tim tpm mtg sc ms = if sc > betterSc then ms' * 4 `div` 5 @@ -461,6 +468,8 @@ beforeReadLoop = do let evst = evalst $ crtStatus chg ctxLog LogInfo "Initial eval parameters:" forM_ (zip paramNames (esDParams evst)) $ \(n, v) -> ctxLog LogInfo $! n ++ "\t" ++ show v + bm <- liftIO $ hGetBuffering stdin + ctxLog DebugUci $ "Stdin: " ++ show bm beforeProgExit :: CtxIO () beforeProgExit = return () @@ -490,7 +499,7 @@ answer s = do -- Name of the log file progLogName :: String -progLogName = "abulafia" ++ "-" ++ progVersion +progLogName = "barbarossa" ++ "-" ++ progVersion ++ if null progVerSuff then "" else "-" ++ progVerSuff @@ -582,11 +591,12 @@ infos :: String -> String infos s = "info string " ++ s -- Append error info to error file: -collectError :: CE.SomeException -> IO () -collectError e = CE.catch (do - let efname = "Abulafia_collected_errors.txt" - tm <- currentSecs +collectError :: SomeException -> IO () +collectError e = flip catch cannot $ do + let efname = "Barbarossa_collected_errors.txt" + TOD tm _ <- getClockTime ef <- openFile efname AppendMode hPutStrLn ef $ show tm ++ " " ++ idName ++ ": " ++ show e hClose ef - ) $ \_ -> return () + where cannot :: IOException -> IO () + cannot _ = return () diff --git a/Moves/Base.hs b/Moves/Base.hs new file mode 100644 index 00000000..e3931250 --- /dev/null +++ b/Moves/Base.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE TypeSynonymInstances, + MultiParamTypeClasses, + BangPatterns, + RankNTypes, UndecidableInstances, + FlexibleInstances + #-} + +module Moves.Base ( + CtxMon(..), + posToState, initPos, getPos, posNewSearch, + doMove, undoMove, genMoves, genTactMoves, + useHash, + staticVal0, mateScore, + showMyPos, + nearmate, special +) where + +import Data.Array.IArray +import Debug.Trace +import Control.Exception (assert) +import Data.Bits +import Data.List +import Control.Monad.State +import Data.Ord (comparing) +import System.Random + +import Moves.BaseTypes +import Search.AlbetaTypes +import qualified Search.SearchMonad as SM +import Struct.Struct +import Hash.TransTab +import Struct.Status +import Moves.Board +import Moves.SEE +import Eval.Eval +import Moves.ShowMe +import Moves.History + +{-# INLINE nearmate #-} +nearmate :: Int -> Bool +nearmate i = i >= mateScore - 255 || i <= -mateScore + 255 + +-- instance Edge Move where +special :: Move -> Bool +{-# INLINE special #-} +special = moveIsSpecial + +instance CtxMon m => Node (Game r m) where + staticVal = staticVal0 + materVal = materVal0 + genEdges = genMoves + genTactEdges = genTactMoves + {-# INLINE tactical #-} + tactical = tacticalPos + legalEdge = isMoveLegal + {-# INLINE killCandEdge #-} + killCandEdge = isKillCand + inSeq = okInSequence + doEdge = doMove False + undoEdge = undoMove + betaMove = betaMove0 + nullEdge = doNullMove + retrieve = currDSP + store = storeSearch + {-# INLINE curNodes #-} + curNodes = getNodes + inform = lift . tellCtx + choose = choose0 + timeout = isTimeout + +-- Some options and parameters: +debug, useHash :: Bool +debug = False +useHash = True + +depthForMovesSortPv, depthForMovesSort, scoreDiffEqual :: Int +depthForMovesSortPv = 1 -- use history for sorting moves when pv or cut nodes +depthForMovesSort = 1 -- use history for sorting moves +scoreDiffEqual = 4 -- under this score difference moves are considered to be equal (choose random) +-- scoreDiffEqual = 0 -- under this score difference moves are considered to be equal (choose random) + +mateScore :: Int +mateScore = 20000 + +getNodes :: CtxMon m => Game r m Int +{-# INLINE getNodes #-} +getNodes = gets (nodes . stats) + +{-# INLINE getPos #-} +getPos :: CtxMon m => Game r m MyPos +getPos = gets (head . stack) + +posToState :: MyPos -> Cache -> History -> EvalState -> MyState +posToState p c h e = MyState { + stack = [updatePos p], + hash = c, + hist = h, + stats = stats0, + evalst = e + } + where stats0 = Stats { + nodes = 0, + maxmvs = 0 + } + +posNewSearch :: MyState -> MyState +posNewSearch p = p { hash = newGener (hash p) } + +-- debugGen :: Bool +-- debugGen = False + +captWLDepth :: Int +captWLDepth = 5 -- so far 5 seems to be best (after ~100 games) + +loosingLast :: Bool +loosingLast = False + +genMoves :: CtxMon m => Int -> Int -> Bool -> Game r m ([Move], [Move]) +genMoves depth absdp pv = do + p <- getPos + -- when debugGen $ do + -- lift $ ctxLog "Debug" $ "--> genMoves:\n" ++ showTab (black p) (slide p) (kkrq p) (diag p) + let !c = moving p + lc = map (genmv True p) $ genMoveFCheck p c + if isCheck p c + then return (lc, []) + else do + let l0 = genMoveCast p c + l1 = map (genmvT p) $ genMoveTransf p c + l2 = map (genmv True p) $ genMoveCapt p c + (pl2w, pl2l) = genMoveCaptWL p c + l2w = map (genmv True p) pl2w + l2l = map (genmv True p) pl2l + l3'= map (genmv False p) $ genMoveNCapt p c + l3 <- if pv && depth >= depthForMovesSortPv + || not pv && depth >= depthForMovesSort + -- then sortMovesFromHash l3' + then sortMovesFromHist absdp l3' + else return l3' + return $! if pv || depth >= captWLDepth + then if loosingLast + then (l1 ++ l2w, l0 ++ l3 ++ l2l) + else (l1 ++ l2w ++ l2l, l0 ++ l3) + else (l1 ++ l2, l0 ++ l3) + +onlyWinningCapts :: Bool +onlyWinningCapts = True + +-- Generate only tactical moves, i.e. promotions, captures & check escapes +genTactMoves :: CtxMon m => Game r m [Move] +genTactMoves = do + p <- getPos + let !c = moving p + l1 = map (genmvT p) $ genMoveTransf p c + l2 = map (genmv True p) $ genMoveCapt p c + -- lnc = map (genmv True p) $ genMoveNCaptToCheck p c + (pl2, _) = genMoveCaptWL p c + l2w = map (genmv True p) pl2 + -- l2w = map (genmv True p) $ genMoveCaptSEE p c + lc = map (genmv True p) $ genMoveFCheck p c + -- the non capturing check moves have to be at the end (tested!) + -- else if onlyWinningCapts then l1 ++ l2w ++ lnc else l1 ++ l2 ++ lnc + !mvs | isCheck p c = lc + | onlyWinningCapts = l1 ++ l2w + | otherwise = l1 ++ l2 + return mvs + +sortMovesFromHist :: CtxMon m => Int -> [Move] -> Game r m [Move] +sortMovesFromHist d mvs = do + s <- get + -- mvsc <- liftIO $ mapM (\m -> fmap negate $ valHist (hist s) (fromSquare m) (toSquare m) d) mvs + mvsc <- liftIO $ mapM (\m -> valHist (hist s) (fromSquare m) (toSquare m) d) mvs + -- return $ map fst $ sortBy (comparing snd) $ zip mvs mvsc + let (posi, zero) = partition ((/=0) . snd) $ zip mvs mvsc + return $! map fst $ sortBy (comparing snd) posi ++ zero + +-- massert :: CtxMon m => String -> Game r m Bool -> Game r m () +-- massert s mb = do +-- b <- mb +-- if b then return () else error s + +{-# INLINE statNodes #-} +statNodes :: CtxMon m => Game r m () +statNodes = do + s <- get + let st = stats s + !n = nodes st + 1 + !s1 = s { stats = st { nodes = n } } + put s1 + +showMyPos :: MyPos -> String +showMyPos p = showTab (black p) (slide p) (kkrq p) (diag p) ++ "================ " ++ mc ++ "\n" + where mc = if moving p == White then "w" else "b" + +-- move from a node to a descendent +doMove :: CtxMon m => Bool -> Move -> Bool -> Game r m DoResult +doMove real m qs = do + -- logMes $ "** doMove " ++ show m + statNodes -- when counting all visited nodes + s <- get + -- let pc = if null (stack s) then error "doMove" else head $ stack s + let (pc:_) = stack s -- we never saw an empty stack error until now + !m1 = if real then checkCastle (checkEnPas m pc) pc else m + -- Moving a non-existent piece? + il = case tabla pc (fromSquare m1) of + Busy _ _ -> False + _ -> True + -- Capturing one king? + kc = case tabla pc (toSquare m1) of + Busy _ King -> True + _ -> False + p' = doFromToMove m1 pc { realMove = real } + kok = kingsOk p' + cok = checkOk p' + -- If the move is real and one of those conditions occur, + -- then we are really in trouble... + if not real && (il || kc || not kok) + then do + logMes $ "Illegal move or position: move = " ++ show m + ++ ", il = " ++ show il ++ ", kc = " ++ show kc ++ "\n" + when (not kok) + $ logMes $ "Illegal position (after the move):\n" ++ showMyPos p' + logMes $ "Stack:\n" ++ showStack 3 (stack s) + -- After an illegal result there must be no undo! + return Illegal + else if not cok + then return Illegal + else do + let !c = moving p' + (!sts, feats) = if real + then (0, []) + else evalState (posEval p' c) (evalst s) + !p = p' { staticScore = sts, staticFeats = feats } + dext = if inCheck p || goPromo p m1 then 1 else 0 + -- when debug $ + -- lift $ ctxLog "Debug" $ "*** doMove: " ++ showMyPos p + -- remis' <- checkRepeatPv p pv + -- remis <- if remis' then return True else checkRemisRules p + put s { stack = p : stack s } + remis <- if qs then return False else checkRemisRules p' + if remis + then return $ Final 0 + else return $ Exten dext + +doNullMove :: CtxMon m => Game r m () +doNullMove = do + -- logMes "** doMove null" + s <- get + let !p0 = if null (stack s) then error "doNullMove" else head $ stack s + !p' = reverseMoving p0 + !c = moving p' + (!sts, feats) = evalState (posEval p' c) (evalst s) + !p = p' { staticScore = sts, staticFeats = feats } + put s { stack = p : stack s } + +checkRemisRules :: CtxMon m => MyPos -> Game r m Bool +checkRemisRules p = do + s <- get + if remis50Moves p + then return True + else do -- check repetition rule + let revers = map zobkey $ takeWhile isReversible $ stack s + equal = filter (== zobkey p) revers -- if keys are equal, pos is equal + case equal of + (_:_:_) -> return True + _ -> return False + +-- checkRepeatPv :: CtxMon m => MyPos -> Bool -> Game r m Bool +-- checkRepeatPv _ False = return False +-- checkRepeatPv p _ = do +-- s <- get +-- let search = map zobkey $ takeWhile imagRevers $ stack s +-- equal = filter (== zobkey p) search -- if keys are equal, pos is equal +-- case equal of +-- (_:_) -> return True +-- _ -> return False +-- where imagRevers t = isReversible t && not (realMove t) + +{-# INLINE undoMove #-} +undoMove :: CtxMon m => Game r m () +undoMove = do + -- logMes "** undoMove" + modify $ \s -> s { stack = tail $ stack s } + +-- Tactical positions will be searched complete in quiescent search +-- Currently only when in in check +{-# INLINE tacticalPos #-} +tacticalPos :: CtxMon m => Game r m Bool +tacticalPos = do + t <- getPos + return $! check t /= 0 + +{-# INLINE isMoveLegal #-} +isMoveLegal :: CtxMon m => Move -> Game r m Bool +isMoveLegal m = do + t <- getPos + return $! legalMove t m + +isKillCand :: CtxMon m => Move -> Move -> Game r m Bool +isKillCand mm ym + | toSquare mm == toSquare ym = return False + | otherwise = do + t <- getPos + return $! nonCapt t ym + +okInSequence :: CtxMon m => Move -> Move -> Game r m Bool +okInSequence m1 m2 = do + t <- getPos + return $! alternateMoves t m1 m2 + +-- Static evaluation function +{-# INLINE staticVal0 #-} +staticVal0 :: CtxMon m => Game r m Int +staticVal0 = do + s <- get + t <- getPos + let !c = moving t + !stSc = if not (kingsOk t && checkOk t) + then error $ "Wrong position, pos stack:\n" ++ concatMap showMyPos (stack s) + else staticScore t + -- Here we actually don't need genMoves - it would be enough to know that + -- there is at least one legal move, which should be much cheaper + stSc1 | hasMoves t c = stSc + | check t /= 0 = -mateScore + | otherwise = 0 + -- when debug $ lift $ ctxLog "Debug" $ "--> staticVal0 " ++ show stSc1 + return $! stSc1 + +materVal0 :: CtxMon m => Game r m Int +materVal0 = do + t <- getPos + let !m = mater t + return $! case moving t of + White -> m + _ -> -m + +-- quiet :: MyPos -> Bool +-- quiet p = at .&. ta == 0 +-- where (!at, !ta) = if moving p == White then (whAttacs p, black p) else (blAttacs p, white p) + +-- Fixme!! We have big problems with hash store/retrieval: many wrong scores (and perhaps hash moves) +-- come from there!! + +{-# INLINE currDSP #-} +currDSP :: CtxMon m => Game r m (Int, Int, Int, Move, Int) +currDSP = if not useHash then return empRez else do + -- when debug $ lift $ ctxLog "Debug" $ "--> currDSP " + s <- get + p <- getPos + mhr <- liftIO $ readCache (hash s) (zobkey p) + -- let (r, sc) = case mhr of + -- Just t@(_, _, sco, _, _) -> (t, sco) + -- _ -> (empRez, 0) + let r = case mhr of + Just t -> t + _ -> empRez + -- (_, _, sc, _, _) = r + -- if (sc `mod` 4 /= 0) + -- then do + -- logMes $ "*** currDSP " ++ show r ++ " zkey " ++ show (zobkey p) + -- return empRez + -- else return r + return r + where empRez = (-1, 0, 0, Move 0, 0) + +{-# INLINE storeSearch #-} +storeSearch :: CtxMon m => Int -> Int -> Int -> Move -> Int -> Game r m () +storeSearch deep tp sc bestm nds = if not useHash then return () else do + s <- get + p <- getPos + -- when (sc `mod` 4 /= 0 && tp == 2) $ liftIO $ do + -- putStrLn $ "info string In storeSearch: tp = " ++ show tp ++ " sc = " ++ show sc + -- ++ " best = " ++ show best ++ " nodes = " ++ show nodes + -- putStrLn $ "info string score in position: " ++ show (staticScore p) + -- We use the type: 0 - upper limit, 1 - lower limit, 2 - exact score + liftIO $ writeCache (hash s) (zobkey p) deep tp sc bestm nds + -- when debug $ lift $ ctxLog "Debug" $ "*** storeSearch (deep/tp/sc/mv) " ++ show deep + -- ++ " / " ++ show tp ++ " / " ++ show sc ++ " / " ++ show best + -- ++ " status: " ++ show st ++ " (" ++ show (zobkey p) ++ ")" + -- return () + +-- History heuristic table update when beta cut move +betaMove0 :: CtxMon m => Bool -> Int -> Int -> Move -> Game r m () +betaMove0 good _ absdp m = do -- dummy: depth + s <- get + t <- getPos + -- liftIO $ toHist (hist s) good (fromSquare m) (toSquare m) absdp + case tabla t (toSquare m) of + Empty -> liftIO $ toHist (hist s) good (fromSquare m) (toSquare m) absdp + _ -> return () + +{-- +showChoose :: CtxMon m => [] -> Game m () +showChoose pvs = do + mapM_ (\(i, (s, pv)) -> lift $ ctxLog "Info" + $ "choose pv " ++ show i ++ " score " ++ show s ++ ": " ++ show pv) + $ zip [1..] pvs + return $ if null pvs then error "showChoose" else head pvs +--} + +-- Choose between almost equal (root) moves +choose0 :: CtxMon m => Bool -> [(Int, [Move])] -> Game r m (Int, [Move]) +choose0 True pvs = return $ if null pvs then error "Empty choose!" else head pvs +choose0 _ pvs = case pvs of + p1 : [] -> return p1 + p1 : ps -> do + let equal = p1 : takeWhile inrange ps + minscore = fst p1 - scoreDiffEqual + inrange x = fst x >= minscore + len = length equal + logMes $ "Choose from: " ++ show pvs + logMes $ "Choose length: " ++ show len + logMes $ "Choose equals: " ++ show equal + if len == 1 + then return p1 + else do + r <- liftIO $ getStdRandom (randomR (0, len - 1)) + return $! equal !! r + [] -> return (0, []) -- just for Wall + +logMes :: CtxMon m => String -> Game r m () +logMes s = lift $ tellCtx . LogMes $ s + +isTimeout :: CtxMon m => Int -> Game r m Bool +isTimeout msx = do + curr <- lift timeCtx + return $! msx < curr + +showStack :: Int -> [MyPos] -> String +showStack n = concatMap (\p -> showMyPos p) . take n diff --git a/Moves/BaseTypes.hs b/Moves/BaseTypes.hs new file mode 100644 index 00000000..8668eaf0 --- /dev/null +++ b/Moves/BaseTypes.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeSynonymInstances, + MultiParamTypeClasses, + BangPatterns, + RankNTypes, UndecidableInstances + #-} + +module Moves.BaseTypes ( + CtxMon(..), Game +) where + +import Control.Monad.IO.Class + +import qualified Search.SearchMonad as SM +import Struct.Struct +import Struct.Status +import Search.AlbetaTypes + +-- This is a specialized monad transformer for state +-- type Game m = SM.STPlus MyState m +type Game r m = SM.STPlus r MyState m + +class (Monad m, MonadIO m) => CtxMon m where + tellCtx :: Comm -> m () + timeCtx :: m Int diff --git a/Moves/BitBoard.hs b/Moves/BitBoard.hs new file mode 100644 index 00000000..5378bf4f --- /dev/null +++ b/Moves/BitBoard.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +module Moves.BitBoard ( + popCount, popCount1, lsb, bbToSquares, less, firstOne, exactOne, bbToSquaresBB, + uTestBit +) where + +-- import Control.Exception (assert) +import Data.Array.Base +import Data.Array.Unboxed +import Data.Bits hiding (popCount) +import qualified Data.Bits as B +import Data.List.Stream (unfoldr) +import Data.Word + +import Struct.Struct + +-- First, the bit scan funtion +-- This could be replaced through an asm function for CPUs which have bitscan +{-# INLINE lsb #-} +lsb :: BBoard -> BBoard +lsb b = b .&. (-b) + +{-# INLINE exactOne #-} +exactOne :: BBoard -> Bool +exactOne = (==1) . B.popCount + +{-# INLINE less #-} +less :: BBoard -> BBoard -> BBoard +less w1 w2 = w1 .&. complement w2 + +{-# INLINE firstOne #-} +firstOne :: BBoard -> Square +firstOne = bitToSquare . lsb + +-- Here the bitboard must have exactly one bit set! +bitToSquare :: BBoard -> Square +bitToSquare !b = bitScanDatabase `unsafeAt` mbsm b + +bitScanMagic :: BBoard +bitScanMagic = 0x07EDD5E59A4E28C2 + +bitScanDatabase :: UArray Int Int +bitScanDatabase = array (0, 63) paar + where ones = take 64 $ zip [0..] $ iterate (`unsafeShiftL` 1) 1 + paar = [(mbsm bit, i) | (i, bit) <- ones] + +{-# INLINE mbsm #-} +mbsm :: BBoard -> Int +mbsm x = fromIntegral $ (x * bitScanMagic) `unsafeShiftR` 58 + +{-# INLINE bbToSquares #-} +bbToSquares :: BBoard -> [Square] +bbToSquares bb = unfoldr f bb + where f :: BBoard -> Maybe (Square, BBoard) + f 0 = Nothing + f b = let lsbb = lsb b + !sq = bitToSquare lsbb + nlsbb = complement lsbb + b' = b .&. nlsbb + in Just (sq, b') + +{-# INLINE bbToSquaresBB #-} +bbToSquaresBB :: (Square -> BBoard) -> BBoard -> BBoard +bbToSquaresBB f bb = go bb 0 + where go 0 w = w + go b w = let lsbb = lsb b + !sq = bitToSquare lsbb + nlsbb = complement lsbb + b' = b .&. nlsbb + !w' = f sq .|. w + in go b' w' + +-- Population count function, good for bigger populations: +{-# INLINE popCount #-} +popCount :: BBoard -> Int +popCount = B.popCount + +-- Population count function, good for small populations: +{-# INLINE popCount1 #-} +popCount1 :: BBoard -> Int +popCount1 = B.popCount + +-- Because the normal Bits operations are all safe +-- we define here the unsafe versions specialized for BBoard +{-# INLINE uTestBit #-} +uTestBit :: BBoard -> Int -> Bool +uTestBit w b = let bb = 1 `unsafeShiftL` b + in w .&. bb /= 0 diff --git a/Moves/Board.hs b/Moves/Board.hs new file mode 100644 index 00000000..ef06081c --- /dev/null +++ b/Moves/Board.hs @@ -0,0 +1,842 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards, BangPatterns #-} +module Moves.Board ( + posFromFen, initPos, + isCheck, inCheck, + goPromo, hasMoves, + genmv, genmvT, + genMoveCapt, genMoveCast, genMoveNCapt, genMoveTransf, genMovePCapt, genMovePNCapt, genMoveFCheck, + genMoveNCaptToCheck, + updatePos, kingsOk, checkOk, + legalMove, alternateMoves, nonCapt, + doFromToMove, reverseMoving + ) where + +import Prelude hiding ((++), foldl, filter, map, concatMap, concat, head, tail, repeat, zip, + zipWith, null, words, foldr, elem, lookup, any) +-- import Control.Exception (assert) +import Data.Bits +import Data.List.Stream +import Data.Char +import Data.Maybe +import Data.Ord (comparing) + +import Struct.Struct +import Moves.Moves +import Moves.BitBoard +import Moves.ShowMe +import Moves.SEE +import Eval.BasicEval +import Hash.Zobrist + +startFen :: String +startFen = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR/ w KQkq - 0 1" + +fenToTable :: String -> MyPos +fenToTable fen = foldr setp emptyPos $ fenToAssocs fen + where setp (sq, (c, p)) = setPiece sq c p + +fenToAssocs :: String -> [(Square, (Color, Piece))] +fenToAssocs str = go 56 str [] + where go _ [] acc = acc + go sq (c:cs) acc + | sq < 0 = acc + | c `elem` "PRNBQK" = go (sq+1) cs $ (sq, fcw):acc + | c `elem` "prnbqk" = go (sq+1) cs $ (sq, fcb):acc + -- | c == '/' = go (nextline sq) cs acc + | isDigit c = go (skip sq c) cs acc + -- | otherwise = go sq cs acc -- silently ignore other chars + | otherwise = go (nextline sq) cs acc -- treat like / + where fcw = (White, toPiece c) + fcb = (Black, toPiece $ toUpper c) + skip f c = f + fromIntegral (ord c - ord '0') + nextline f = f - 16 + toPiece c = fromJust $ lookup c letterToPiece + +letterToPiece :: [(Char, Piece)] +letterToPiece = [('P', Pawn), ('R', Rook), ('N', Knight), ('B', Bishop), + ('Q', Queen), ('K', King)] + +initPos :: MyPos +initPos = posFromFen startFen + +-- TODO: en passant +posFromFen :: String -> MyPos +posFromFen fen = p { basicPos = bp, zobkey = zk } + where fen1:fen2:fen3:_:fen5:_ = fenFromString fen + p = fenToTable fen1 + bp = (basicPos p) { bpepcas = x } + x = fyInit . castInit . epInit $ epcas0 + (epcas0, z) = case fen2 of + 'w':_ -> (0, 0) + 'b':_ -> (mvMask, zobMove) + _ -> error "posFromFen: expect w or b" + (cK, z1) = if 'K' `elem` fen3 then ((.|. caRKiw), zobCastKw) else (id, 0) + (cQ, z2) = if 'Q' `elem` fen3 then ((.|. caRQuw), zobCastQw) else (id, 0) + (ck, z3) = if 'k' `elem` fen3 then ((.|. caRKib), zobCastKb) else (id, 0) + (cq, z4) = if 'q' `elem` fen3 then ((.|. caRQub), zobCastQb) else (id, 0) + castInit = cQ . cK . cq . ck + epInit = id -- TODO: ep field + fyInit = set50Moves $ read fen5 + zk = zobkey p `xor` z `xor` z1 `xor` z2 `xor` z3 `xor` z4 -- also for ep + +-- A primitive decomposition of the fen string +fenFromString :: String -> [String] +fenFromString fen = zipWith ($) fenfuncs fentails + where fentails = tails $ words fen + fenfuncs = [ getFenPos, getFenMv, getFenCast, getFenEp, getFenHalf, getFenMvNo ] + headOrDefault a0 as = if null as then a0 else head as + getFenPos = headOrDefault "" + getFenMv = headOrDefault "w" + getFenCast = headOrDefault "-" + getFenEp = headOrDefault "-" + getFenHalf = headOrDefault "-" + getFenMvNo = headOrDefault "-" + +{-- +-- find rook-like possibly pinning pieces for a position & color +-- that is: rooks or queens, which possibly pin oponent pieces in regard to the (oponent) king +findPKAr p c = rAttacs defksq 0 .&. rs .&. atp + where (atp, defp) = if c == White then (white p, black p) else (black p, white p) + rs = rooks p .|. queens p + defksq = firstOne $ defp .&. kings p + +-- find bishop-like possibly pinning pieces for a position & color +-- that is: bishops or queens, which possibly pin oponent pieces in regard to the (oponent) king +findPKAb p c = bAttacs defksq 0 .&. bs .&. atp + where (atp, defp) = if c == White then (white p, black p) else (black p, white p) + bs = bishops p .|. queens p + defksq = firstOne $ defp .&. kings p + +-- find all possibly pining pieces and lines in a given position +-- this has to be calculated per position, and recalculated +-- only when the king or one of the pinning pieces move or is captured +allPLKAs p = (lwr ++ lwb, lbr ++ lbb) + where pkaswr = findPKAr p White + pkaswb = findPKAb p White + pkasbr = findPKAr p Black + pkasbb = findPKAb p Black + kwsq = firstOne $ kings p .&. white p + kbsq = firstOne $ kings p .&. black p + lwr = filter f $ map (findLKA Rook kbsq) $ bbToSquares pkaswr + lwb = filter f $ map (findLKA Bishop kbsq) $ bbToSquares pkaswb + lbr = filter f $ map (findLKA Rook kwsq) $ bbToSquares pkasbr + lbb = filter f $ map (findLKA Bishop kwsq) $ bbToSquares pkasbb + f = (/= 0) . snd +--} + +-- For pinned pieces the move generation is restricted to the pinned line +-- so the same attacs .&. direction +pinningDir :: MyPos -> Color -> Square -> BBoard +pinningDir p c sq = let ds = filter (exactOne . (.&. bit sq)) $ map snd + $ if c == White then bpindirs p else wpindirs p + in if null ds then error "pinningDir" else head ds + +pinningCapt :: MyPos -> Color -> Square -> BBoard +pinningCapt p c sq = let ds = filter (exactOne . (.&. bit sq) . snd) + $ if c == White then bpindirs p else wpindirs p + in if null ds then error "pinningCapt" else bit . fst . head $ ds + +-- Is color c in check in position p? +isCheck :: MyPos -> Color -> Bool +isCheck p c = (ckp /= 0) && (ckp .&. colp /= 0) + where colp = if c == White then white p else black p + ckp = check p + +{-# INLINE inCheck #-} +inCheck :: MyPos -> Bool +inCheck = (/= 0) . check + +goPromo :: MyPos -> Move -> Bool +goPromo p m + | moveIsTransf m = True + | otherwise = case tabla p t of + Busy White Pawn -> ppw + Busy Black Pawn -> ppb + _ -> False + where t = toSquare m + ppw = t >= 48 -- 40 + ppb = t < 16 -- 24 + +-- {-# INLINE genmv #-} +genmv :: Bool -> MyPos -> (Square, Square) -> Move +genmv spec _ (f, t) = if spec then makeSpecial m else m + where !m = moveFromTo f t + +-- Used only with transformation pawns +genmvT :: MyPos -> (Square, Square) -> Move +genmvT _ (f, t) = makeTransf Queen f t + +-- Here it seems we have a problem when we are not in check but could move +-- only a pinned piece: then we are stale mate but don't know (yet) +-- In the next ply, when we try to find a move, we see that all moves are illegal +-- In this case we should take care in search that the score is 0! +hasMoves :: MyPos -> Color -> Bool +hasMoves !p c + | chk = not . null $ genMoveFCheck p c + | otherwise = anyMove + where hasPc = any (/= 0) $ map (pcapt . pAttacs c) + $ bbToSquares $ pawns p .&. myfpc + hasPm = not . null $ pAll1Moves c (pawns p .&. mypc) (occup p) + hasN = any (/= 0) $ map (legmv . nAttacs) $ bbToSquares $ knights p .&. myfpc + hasB = any (/= 0) $ map (legmv . bAttacs (occup p)) + $ bbToSquares $ bishops p .&. myfpc + hasR = any (/= 0) $ map (legmv . rAttacs (occup p)) + $ bbToSquares $ rooks p .&. myfpc + hasQ = any (/= 0) $ map (legmv . qAttacs (occup p)) + $ bbToSquares $ queens p .&. myfpc + !hasK = 0 /= (legal . kAttacs $ firstOne $ kings p .&. mypc) + !anyMove = hasK || hasN || hasPm || hasPc || hasQ || hasR || hasB + chk = inCheck p + (!mypc, !yopi) = thePieces p c + -- myfpc = mypc `less` pinned p + myfpc = mypc + !yopiep = yopi .|. (epcas p .&. epMask) + legmv x = x `less` mypc + pcapt x = x .&. yopiep + legal x = x `less` oppAt + !oppAt = if c == White then blAttacs p else whAttacs p + +-- Move generation generates legal moves +genMoveCapt :: MyPos -> Color -> [(Square, Square)] +genMoveCapt !p c = sortByMVVLVA p allp + where !pGenC = concatMap (srcDests (pcapt . pAttacs c)) + $ bbToSquares $ pawns p .&. myfpc `less` traR + !nGenC = concatMap (srcDests (capt . nAttacs)) + $ bbToSquares $ knights p .&. myfpc + !bGenC = concatMap (srcDests (capt . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. myfpc + !rGenC = concatMap (srcDests (capt . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. myfpc + !qGenC = concatMap (srcDests (capt . qAttacs (occup p))) + $ bbToSquares $ queens p .&. myfpc + !kGenC = srcDests (capt . legal . kAttacs) + $ firstOne $ kings p .&. myfpc + allp = concat [ pGenC, nGenC, bGenC, rGenC, qGenC, kGenC ] + (!mypc, !yopi) = thePieces p c + -- myfpc = mypc `less` pinned p + myfpc = mypc + -- yopi = yoPieces p c + !yopiep = yopi .|. (epcas p .&. epMask) + capt x = x .&. yopi + pcapt x = x .&. yopiep + legal x = x `less` oppAt + !oppAt = if c == White then blAttacs p else whAttacs p + !traR = if c == White then 0x00FF000000000000 else 0xFF00 + +-- For quiescent search we generate only winning captures +-- This is just an approximation +{- +genMoveWCapt :: MyPos -> Color -> [(Square, Square)] +genMoveWCapt !p !c = concat [ pGenC, nGenC, bGenC, rGenC, qGenC, kGenC ] + where pGenC = concatMap (srcDests (pcapt . pAttacs c)) + $ bbToSquares $ pawns p .&. mypc `less` traR + nGenC = concatMap (srcDests (wcapt yopfornb . nAttacs)) + $ bbToSquares $ knights p .&. mypc + bGenC = concatMap (srcDests (wcapt yopfornb . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. mypc + rGenC = concatMap (srcDests (wcapt yopforr . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. mypc + qGenC = concatMap (srcDests (wcapt yopforq . qAttacs (occup p))) + $ bbToSquares $ queens p .&. mypc + kGenC = srcDests (capt . legal . kAttacs) + $ firstOne $ kings p .&. mypc + mypc = myPieces p c `less` pinned p + yopi = yoPieces p c + yopiep = yopi .|. (epcas p .&. epMask) + capt x = x .&. yopi + wcapt y x = x .&. y + pcapt x = x .&. yopiep + legal x = x `less` oppAt + oppAt = if c == White then blAttacs p else whAttacs p + traR = if c == White then 0x00FF000000000000 else 0xFF00 + hanging = yopi `less` oppAt + yopfornb = hanging .|. (yopi `less` pawns p) + yopforr = hanging .|. (yopfornb `less` knights p `less` bishops p) + yopforq = hanging .|. (yopi .&. queens p) +-} + +genMoveNCapt :: MyPos -> Color -> [(Square, Square)] +-- genMoveNCapt p c = concat [ pGenNC2, qGenNC, rGenNC, bGenNC, nGenNC, pGenNC1, kGenNC ] +-- genMoveNCapt p c = concat [ pGenNC1, nGenNC, bGenNC, rGenNC, qGenNC, pGenNC2, kGenNC ] +genMoveNCapt !p c = concat [ nGenNC, bGenNC, rGenNC, qGenNC, pGenNC1, pGenNC2, kGenNC ] + -- where pGenNCT = concatMap (srcDests True (ncapt . \s -> pMovs s c ocp)) + -- $ bbToSquares $ pawns p .&. mypc .&. traR + -- pGenNC = concatMap (srcDests False (ncapt . \s -> pMovs s c ocp)) + -- $ bbToSquares $ pawns p .&. mypc `less` traR + where pGenNC1 = pAll1Moves c (pawns p .&. mypc `less` traR) (occup p) + pGenNC2 = pAll2Moves c (pawns p .&. mypc) (occup p) + nGenNC = concatMap (srcDests (ncapt . nAttacs)) + $ bbToSquares $ knights p .&. mypc + bGenNC = concatMap (srcDests (ncapt . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. mypc + rGenNC = concatMap (srcDests (ncapt . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. mypc + qGenNC = concatMap (srcDests (ncapt . qAttacs (occup p))) + $ bbToSquares $ queens p .&. mypc + kGenNC = srcDests (ncapt . legal . kAttacs) + $ firstOne $ kings p .&. mypc + -- mypc = myPieces p c `less` pinned p + mypc = myPieces p c + ncapt x = x `less` occup p + legal x = x `less` oppAt + oppAt = if c == White then blAttacs p else whAttacs p + traR = if c == White then 0x00FF000000000000 else 0xFF00 + -- mypawns = pawns p .&. mypc + +-- Generate only transformations (now only to queen) - captures and non captures +genMoveTransf :: MyPos -> Color -> [(Square, Square)] +genMoveTransf !p c = pGenC ++ pGenNC + where pGenC = concatMap (srcDests (pcapt . pAttacs c)) + $ bbToSquares $ pawns p .&. myfpc + -- pGenNC = concatMap (srcDests False (ncapt . \s -> pMovs s c ocp)) + -- $ bbToSquares $ pawns p .&. myfpc .&. traR + pGenNC = pAll1Moves c (pawns p .&. myfpc) (occup p) + (!mypc, !yopi) = thePieces p c + -- myfpc = mypc .&. traR `less` pinned p + !myfpc = mypc .&. traR + !yopiep = yopi .|. (epcas p .&. epMask) + pcapt x = x .&. yopiep + !traR = if c == White then 0x00FF000000000000 else 0xFF00 + +-- Generate the captures with pinned pieces +genMovePCapt :: MyPos -> Color -> [(Square, Square)] +genMovePCapt !p !c = concat [ pGenC, nGenC, bGenC, rGenC, qGenC ] + where pGenC = concatMap (srcDests $ pinCapt p c (pcapt . pAttacs c)) + $ bbToSquares $ pawns p .&. myfpc `less` traR + nGenC = concatMap (srcDests $ pinCapt p c (capt . nAttacs)) + $ bbToSquares $ knights p .&. myfpc + bGenC = concatMap (srcDests $ pinCapt p c (capt . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. myfpc + rGenC = concatMap (srcDests $ pinCapt p c (capt . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. myfpc + qGenC = concatMap (srcDests $ pinCapt p c (capt . qAttacs (occup p))) + $ bbToSquares $ queens p .&. myfpc + (mypc, yopi) = thePieces p c + myfpc = mypc .&. pinned p + -- yopi = yoPieces p c + yopiep = yopi .|. (epcas p .&. epMask) + capt x = x .&. yopi + pcapt x = x .&. yopiep + traR = if c == White then 0x00FF000000000000 else 0xFF00 + +-- Generate the non-captures with pinned pieces +genMovePNCapt :: MyPos -> Color -> [(Square, Square)] +genMovePNCapt !p !c = concat [ pGenNC, qGenNC, rGenNC, bGenNC, nGenNC ] + where pGenNC = concatMap (srcDests $ pinMove p c (ncapt . \s -> pMovs s c (occup p))) + $ bbToSquares $ pawns p .&. mypc `less` traR + nGenNC = concatMap (srcDests $ pinMove p c (ncapt . nAttacs)) + $ bbToSquares $ knights p .&. mypc + bGenNC = concatMap (srcDests $ pinMove p c (ncapt . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. mypc + rGenNC = concatMap (srcDests $ pinMove p c (ncapt . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. mypc + qGenNC = concatMap (srcDests $ pinMove p c (ncapt . qAttacs (occup p))) + $ bbToSquares $ queens p .&. mypc + mypc = myPieces p c .&. pinned p + ncapt x = x `less` occup p + traR = if c == White then 0x00FF000000000000 else 0xFF00 + -- mypawns = pawns p .&. mypc + +-- {-# INLINE pinMove #-} +pinMove :: MyPos -> Color -> (Square -> BBoard) -> Square -> BBoard +pinMove p c f sq = f sq .&. pinningDir p c sq + +-- {-# INLINE pinCapt #-} +pinCapt :: MyPos -> Color -> (Square -> BBoard) -> Square -> BBoard +pinCapt p c f sq = f sq .&. pinningCapt p c sq + +-- {-# INLINE srcDests #-} +srcDests :: (Square -> BBoard) -> Square -> [(Square, Square)] +srcDests f !s = zip (repeat s) $ bbToSquares $ f s + +-- Because finding the blocking square for a queen check is so hard, +-- we define a data type and, in case of a queen check, we give also +-- the piece type (rook or bishop) in which direction the queen checks +data CheckInfo = NormalCheck Piece !Square + | QueenCheck Piece !Square + +-- Finds pieces which check +findChecking :: MyPos -> Color -> [CheckInfo] +findChecking !p !c = concat [ pChk, nChk, bChk, rChk, qbChk, qrChk ] + where pChk = map (NormalCheck Pawn) $ filter ((/= 0) . kattac . pAttacs c) + $ bbToSquares $ pawns p .&. mypc + nChk = map (NormalCheck Knight) $ filter ((/= 0) . kattac . nAttacs) + $ bbToSquares $ knights p .&. mypc + bChk = map (NormalCheck Bishop) $ filter ((/= 0) . kattac . bAttacs (occup p)) + $ bbToSquares $ bishops p .&. mypc + rChk = map (NormalCheck Rook) $ filter ((/= 0) . kattac . rAttacs (occup p)) + $ bbToSquares $ rooks p .&. mypc + qbChk = map (QueenCheck Bishop) $ filter ((/= 0) . kattac . bAttacs (occup p)) + $ bbToSquares $ queens p .&. mypc + qrChk = map (QueenCheck Rook) $ filter ((/= 0) . kattac . rAttacs (occup p)) + $ bbToSquares $ queens p .&. mypc + -- mypc = myPieces p c + -- yopi = yoPieces p c + (!mypc, !yopi) = thePieces p c + kattac x = x .&. kings p .&. yopi + +-- Generate move when in check +genMoveFCheck :: MyPos -> Color -> [(Square, Square)] +genMoveFCheck !p c + | null chklist = error "genMoveFCheck" + | null $ tail chklist = r1 ++ kGen ++ r2 -- simple check + | otherwise = kGen -- double check, only king moves help + where !chklist = findChecking p $ other c + !kGen = srcDests (legal . kAttacs) ksq + !ksq = firstOne kbb + !kbb = kings p .&. mypc + !ocp1 = occup p `less` kbb + legal x = x `less` alle + !alle = mypc .|. oppAt .|. excl + !mypc = myPieces p c + !oppAt = if c == White then blAttacs p else whAttacs p + !excl = foldl' (.|.) 0 $ map chkAtt chklist + chkAtt (NormalCheck f s) = fAttacs s f ocp1 + chkAtt (QueenCheck f s) = fAttacs s f ocp1 + (r1, r2) = case head chklist of -- this is needed only when simple check + NormalCheck Pawn sq -> (beatAt p c (bit sq), []) -- cannot block pawn + NormalCheck Knight sq -> (beatAt p c (bit sq), []) -- or knight check + NormalCheck Bishop sq -> beatOrBlock Bishop p c sq + NormalCheck Rook sq -> beatOrBlock Rook p c sq + QueenCheck pt sq -> beatOrBlock pt p c sq + _ -> error "genMoveFCheck: what check?" + +-- Generate moves ending on a given square (used to defend a check by capture or blocking) +-- This part is only for queens, rooks, bishops and knights (no pawns and, of course, no kings) +defendAt :: MyPos -> Color -> BBoard -> [(Square, Square)] +defendAt p c bb = concat [ nGenC, bGenC, rGenC, qGenC ] + where nGenC = concatMap (srcDests (target . nAttacs)) + $ bbToSquares $ knights p .&. mypc `less` pinned p + bGenC = concatMap (srcDests (target . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. mypc `less` pinned p + rGenC = concatMap (srcDests (target . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. mypc `less` pinned p + qGenC = concatMap (srcDests (target . qAttacs (occup p))) + $ bbToSquares $ queens p .&. mypc `less` pinned p + target x = x .&. bb + mypc = myPieces p c + +-- Generate capture pawn moves ending on a given square (used to defend a check by capture) +-- TODO: Here: the promotion is not correct (does not promote!) +pawnBeatAt :: MyPos -> Color -> BBoard -> [(Square, Square)] +pawnBeatAt p c bb = concatMap (srcDests (pcapt . pAttacs c)) + $ bbToSquares $ pawns p .&. mypc `less` pinned p + where -- yopi = yoPieces p c + yopiep = bb .&. (yopi .|. (epcas p .&. epMask)) + pcapt x = x .&. yopiep + -- mypc = myPieces p c + (mypc, yopi) = thePieces p c + +-- Generate blocking pawn moves ending on given squares (used to defend a check by blocking) +-- TODO: Here: the promotion is not correct (does not promote!) +pawnBlockAt :: MyPos -> Color -> BBoard -> [(Square, Square)] +pawnBlockAt p c bb = concatMap (srcDests (block . \s -> pMovs s c (occup p))) + $ bbToSquares $ pawns p .&. mypc `less` pinned p + where block x = x .&. bb + mypc = myPieces p c + +beatAt :: MyPos -> Color -> BBoard -> [(Square, Square)] +beatAt p c bb = pawnBeatAt p c bb ++ defendAt p c bb + +blockAt :: MyPos -> Color -> BBoard -> [(Square, Square)] +blockAt p c bb = pawnBlockAt p c bb ++ defendAt p c bb + +-- Defend a check from a sliding piece: beat it or block it +beatOrBlock :: Piece -> MyPos -> Color -> Square -> ([(Square, Square)], [(Square, Square)]) +beatOrBlock f p c sq = (beat, block) + where !beat = beatAt p c $ bit sq + atp = if c == White then white p else black p + aksq = firstOne $ atp .&. kings p + (_, line) = findLKA f aksq sq + !block = blockAt p c line + +genMoveNCaptToCheck :: MyPos -> Color -> [(Square, Square)] +genMoveNCaptToCheck p c = genMoveNCaptDirCheck p c ++ genMoveNCaptIndirCheck p c + +-- Todo: check with pawns (should be also without transformations) +genMoveNCaptDirCheck :: MyPos -> Color -> [(Square, Square)] +-- genMoveNCaptDirCheck p c = concat [ nGenC, bGenC, rGenC, qGenC ] +genMoveNCaptDirCheck p c = concat [ qGenC, rGenC, bGenC, nGenC ] + where nGenC = concatMap (srcDests (target nTar . nAttacs)) + $ bbToSquares $ knights p .&. mypc `less` pinned p + bGenC = concatMap (srcDests (target bTar . bAttacs (occup p))) + $ bbToSquares $ bishops p .&. mypc `less` pinned p + rGenC = concatMap (srcDests (target rTar . rAttacs (occup p))) + $ bbToSquares $ rooks p .&. mypc `less` pinned p + qGenC = concatMap (srcDests (target qTar . qAttacs (occup p))) + $ bbToSquares $ queens p .&. mypc `less` pinned p + target b x = x .&. b + (mypc, yopc) = thePieces p c + ksq = firstOne $ yopc .&. kings p + nTar = fAttacs ksq Knight (occup p) `less` yopc + bTar = fAttacs ksq Bishop (occup p) `less` yopc + rTar = fAttacs ksq Rook (occup p) `less` yopc + qTar = bTar .|. rTar + +-- TODO: indirect non capture checking moves +genMoveNCaptIndirCheck :: MyPos -> Color -> [(Square, Square)] +genMoveNCaptIndirCheck _ _ = [] + +sortByMVVLVA :: MyPos -> [(Square, Square)] -> [(Square, Square)] +sortByMVVLVA p = map snd . sortBy (comparing fst) . map va + where va ft@(f, t) | Busy _ f1 <- tabla p f, Busy _ f2 <- tabla p t + = let !vic = - matPiece White f2 + !agr = matPiece White f1 + in ((vic, agr), ft) + va _ = error "sortByMVVLVA: not a capture" + +-- {-# INLINE updatePos #-} +updatePos :: MyPos -> MyPos +updatePos = updatePosCheck . updatePosAttacs . updatePosOccup + +updatePosOccup :: MyPos -> MyPos +updatePosOccup p = p { + occup = toccup, white = twhite, kings = tkings, + pawns = tpawns, knights = tknights, queens = tqueens, + rooks = trooks, bishops = tbishops + } + where !toccup = kkrq p .|. diag p + !tkings = kkrq p .&. diag p `less` slide p + !twhite = toccup `less` black p + !tpawns = diag p `less` (kkrq p .|. slide p) + !tknights = kkrq p `less` (diag p .|. slide p) + !tqueens = slide p .&. kkrq p .&. diag p + !trooks = slide p .&. kkrq p `less` diag p + !tbishops = slide p .&. diag p `less` kkrq p + +updatePosAttacs :: MyPos -> MyPos +updatePosAttacs p = p { + whPAttacs = twhPAtt, whNAttacs = twhNAtt, whBAttacs = twhBAtt, + whRAttacs = twhRAtt, whQAttacs = twhQAtt, whKAttacs = twhKAtt, + -- whAttacs = twhPAtt .|. twhNAtt .|. twhBAtt .|. twhRAtt .|. twhQAtt .|. twhKAtt, + blPAttacs = tblPAtt, blNAttacs = tblNAtt, blBAttacs = tblBAtt, + blRAttacs = tblRAtt, blQAttacs = tblQAtt, blKAttacs = tblKAtt, + -- blAttacs = tblPAtt .|. tblNAtt .|. tblBAtt .|. tblRAtt .|. tblQAtt .|. tblKAtt + whAttacs = twhAttacs, blAttacs = tblAttacs + } + where !twhPAtt = bbToSquaresBB (pAttacs White) $ pawns p .&. white p + !twhNAtt = bbToSquaresBB nAttacs $ knights p .&. white p + -- !twhBAtt = foldl' (\w s -> w .|. bAttacs s (occup p)) 0 $ bbToSquares $ bishops p .&. white p + -- !twhRAtt = foldl' (\w s -> w .|. rAttacs s (occup p)) 0 $ bbToSquares $ rooks p .&. white p + -- !twhQAtt = foldl' (\w s -> w .|. qAttacs s (occup p)) 0 $ bbToSquares $ queens p .&. white p + !twhBAtt = bbToSquaresBB (bAttacs ocp) $ bishops p .&. white p + !twhRAtt = bbToSquaresBB (rAttacs ocp) $ rooks p .&. white p + !twhQAtt = bbToSquaresBB (qAttacs ocp) $ queens p .&. white p + !twhKAtt = kAttacs $ firstOne $ kings p .&. white p + !tblPAtt = bbToSquaresBB (pAttacs Black) $ pawns p .&. black p + !tblNAtt = bbToSquaresBB nAttacs $ knights p .&. black p + -- !tblBAtt = foldl' (\w s -> w .|. bAttacs s (occup p)) 0 $ bbToSquares $ bishops p .&. black p + -- !tblRAtt = foldl' (\w s -> w .|. rAttacs s (occup p)) 0 $ bbToSquares $ rooks p .&. black p + -- !tblQAtt = foldl' (\w s -> w .|. qAttacs s (occup p)) 0 $ bbToSquares $ queens p .&. black p + !tblBAtt = bbToSquaresBB (bAttacs ocp) $ bishops p .&. black p + !tblRAtt = bbToSquaresBB (rAttacs ocp) $ rooks p .&. black p + !tblQAtt = bbToSquaresBB (qAttacs ocp) $ queens p .&. black p + !tblKAtt = kAttacs $ firstOne $ kings p .&. black p + !twhAttacs = twhPAtt .|. twhNAtt .|. twhBAtt .|. twhRAtt .|. twhQAtt .|. twhKAtt + !tblAttacs = tblPAtt .|. tblNAtt .|. tblBAtt .|. tblRAtt .|. tblQAtt .|. tblKAtt + ocp = occup p + +updatePosCheck :: MyPos -> MyPos +updatePosCheck p = p { + check = tcheck + -- pinned = calcPinned p wpind bpind, + -- wpindirs = wpind, bpindirs = bpind + } + where !whcheck = white p .&. kings p .&. blAttacs p + !blcheck = black p .&. kings p .&. whAttacs p + !tcheck = blcheck .|. whcheck + +-- compute the actually pinned pieces based on pining directions and occupancy +-- {-# INLINE calcPinned #-} +{- +calcPinned p wpind bpind = wpi .|. bpi + where wpi = foldl' (.|.) 0 $ filter ((/= 0) . (.&. white p)) + $ filter exactOne $ map ((.&. occup p) . snd) bpind + bpi = foldl' (.|.) 0 $ filter ((/= 0) . (.&. black p)) + $ filter exactOne $ map ((.&. occup p) . snd) wpind +-} + +-- Generate the castle moves +-- Here we could optimize a bit by defining constants separately for White and Black +-- and test anyway kingmoved first (or even a more general pattern for all moved) +genMoveCast :: MyPos -> Color -> [Move] +genMoveCast p c + | inCheck p || kingmoved = [] + | otherwise = kingside ++ queenside + where (ksq, cmidk, cmidq, opAtt) = + if c == White then (4, caRMKw, caRMQw, blAttacs p) + else (60, caRMKb, caRMQb, whAttacs p) + kingmoved = not (epcas p `testBit` ksq) + rookk = ksq + 3 + rookq = ksq - 4 + kingside = if (epcas p `testBit` rookk) && (occup p .&. cmidk == 0) && (opAtt .&. cmidk == 0) + then [caks] else [] + queenside = if (epcas p `testBit` rookq) && (occup p .&. cmidq == 0) && (opAtt .&. cmidq == 0) + then [caqs] else [] + caks = makeCastleFor c True + caqs = makeCastleFor c False + +-- Set a piece on a square of the table +setPiece :: Square -> Color -> Piece -> MyPos -> MyPos +setPiece sq c f p = p { basicPos = nbp, zobkey = nzob, mater = nmat } + where setCond cond = if cond then (.|. bsq) else (.&. nbsq) + nbp = (basicPos p) { + bpblack = setCond (c == Black) $ black p, + bpslide = setCond (isSlide f) $ slide p, + bpkkrq = setCond (isKkrq f) $ kkrq p, + bpdiag = setCond (isDiag f) $ diag p + } + nzob = zobkey p `xor` zold `xor` znew + nmat = mater p - mold + mnew + (!zold, !mold) = case tabla p sq of + Empty -> (0, 0) + Busy co fo -> (zobPiece co fo sq, matPiece co fo) + !znew = zobPiece c f sq + !mnew = matPiece c f + bsq = 1 `unsafeShiftL` sq + !nbsq = complement bsq + +kingsOk, checkOk :: MyPos -> Bool +{-# INLINE kingsOk #-} +{-# INLINE checkOk #-} +kingsOk p = exactOne (kings p .&. white p) + && exactOne (kings p .&. black p) +checkOk p = if nextmovewhite then blincheck == 0 else whincheck == 0 + where nextmovewhite = (epcas p .&. mvMask) == 0 + whincheck = white p .&. kings p .&. blAttacs p + blincheck = black p .&. kings p .&. whAttacs p + +data ChangeAccum = CA !ZKey !Int + +-- Accumulate a set of changes in MyPos (except BBoards) due to setting a piece on a square +accumSetPiece :: Square -> Color -> Piece -> MyPos -> ChangeAccum -> ChangeAccum +accumSetPiece sq c f p (CA z m) + = case tabla p sq of + Empty -> CA znew mnew + Busy co fo -> accumCapt sq co fo znew mnew + where !znew = z `xor` zobPiece c f sq + !mnew = m + matPiece c f + +-- Accumulate a set of changes in MyPos (except BBoards) due to clearing a square +accumClearSq :: Square -> MyPos -> ChangeAccum -> ChangeAccum +accumClearSq sq p i@(CA z m) + = case tabla p sq of + Empty -> i + Busy co fo -> accumCapt sq co fo z m + +accumCapt :: Square -> Color -> Piece -> ZKey -> Int -> ChangeAccum +accumCapt sq co fo z m = CA (z `xor` zco) (m - mco) + where !zco = zobPiece co fo sq + !mco = matPiece co fo + +accumMoving :: MyPos -> ChangeAccum -> ChangeAccum +accumMoving _ (CA z m) = CA (z `xor` zobMove) m + +-- Take an initial accumulation and a list of functions accum to accum +-- and compute the final accumulation +chainAccum :: ChangeAccum -> [ChangeAccum -> ChangeAccum] -> ChangeAccum +chainAccum = foldl (flip ($)) + +{- +changePining :: MyPos -> Square -> Square -> Bool +changePining p src dst = kings p `testBit` src -- king is moving + || slide p `testBit` src -- pining piece is moving + || slide p `testBit` dst -- pining piece is captured +-} + +{-# INLINE clearCast #-} +clearCast :: Square -> BBoard -> BBoard +clearCast sq bb + = case caRiMa .&. bsq of + 0 -> bb + _ -> bb .&. nbsq + where bsq = 1 `unsafeShiftL` sq + nbsq = complement bsq + +-- Just for a dumb debug: a quick check if two consecutive moves +-- can be part of a move sequence +alternateMoves :: MyPos -> Move -> Move -> Bool +alternateMoves p m1 m2 + | Busy c1 _ <- tabla p src1, + Busy c2 _ <- tabla p src2 = c1 /= c2 + | otherwise = True -- means: we cannot say... + where src1 = fromSquare m1 + src2 = fromSquare m2 + +-- This is used to filter the illegal moves coming from killers or hash table +-- but we must treat special moves (en-passant, castle and promotion) differently, +-- because they are more complex +legalMove :: MyPos -> Move -> Bool +legalMove p m + | Busy col fig <- tabla p src, + colp <- moving p = + let mtype = if moveIsNormal m + then not owndst && canMove fig p src dst + else not owndst && specialMoveIsLegal p m + owndst = myPieces p col `uTestBit` dst + in colp == col && mtype + | otherwise = False + where src = fromSquare m + dst = toSquare m + +-- currently we assume for simplicity that special moves coming from killers or hash +-- are illegal, so they will be tried after the regular generation, and not as killers +specialMoveIsLegal :: MyPos -> Move -> Bool +specialMoveIsLegal _ _ = False + +nonCapt :: MyPos -> Move -> Bool +nonCapt p m + | Busy _ _ <- tabla p (toSquare m) = False + | otherwise = True + +canMove :: Piece -> MyPos -> Square -> Square -> Bool +canMove Pawn p src dst + | (src - dst) .&. 0x7 == 0 = elem dst $ + map snd $ pAll1Moves col pw (occup p) ++ pAll2Moves col pw (occup p) + | otherwise = pAttacs col src `uTestBit` dst + where col = moving p + pw = bit src +canMove fig p src dst = fAttacs src fig (occup p) `uTestBit` dst + +mvBit :: Square -> Square -> BBoard -> BBoard +mvBit !src !dst !w -- = w `xor` ((w `xor` (shifted .&. nbsrc)) .&. mask) + | wsrc == 0 = case wdst of + 0 -> w + _ -> w .&. nbdst + | otherwise = case wdst of + 0 -> w .&. nbsrc .|. bdst + _ -> w .&. nbsrc + where bsrc = 1 `unsafeShiftL` src + !bdst = 1 `unsafeShiftL` dst + wsrc = w .&. bsrc + wdst = w .&. bdst + nbsrc = complement bsrc + nbdst = complement bdst + +-- Copy one square to another and clear the source square +-- doFromToMove :: Square -> Square -> MyPos -> Maybe MyPos +doFromToMove :: Move -> MyPos -> MyPos +doFromToMove m p | moveIsNormal m = updatePos p { + basicPos = nbp, zobkey = tzobkey, mater = tmater + } + where nbp = BPos { + bpblack = tblack, bpslide = tslide, bpkkrq = tkkrq, bpdiag = tdiag, + bpepcas = tepcas + } + src = fromSquare m + dst = toSquare m + tblack = mvBit src dst $ black p + tslide = mvBit src dst $ slide p + tkkrq = mvBit src dst $ kkrq p + tdiag = mvBit src dst $ diag p + pawnmoving = case tabla p src of + Busy _ fig -> fig == Pawn + _ -> False -- actually this is an error! + iscapture = case tabla p dst of + Empty -> False + _ -> True + irevers = pawnmoving || iscapture + -- Here: we have to xor with the zobrist keys for casts! Only when rights change! + tepcas' = clearCast src $ clearCast dst $ epcas p `xor` mvMask -- to do: ep + tepcas = if irevers then reset50Moves tepcas' else addHalfMove tepcas' + CA tzobkey tmater = case tabla p src of -- identify the moving piece + Busy col fig -> chainAccum (CA (zobkey p) (mater p)) [ + accumClearSq src p, + accumSetPiece dst col fig p, + accumMoving p + ] + _ -> error $ "Src field empty: " ++ show src ++ " dst " ++ show dst ++ " in pos\n" + ++ showTab (black p) (slide p) (kkrq p) (diag p) + ++ "resulting pos:\n" + ++ showTab tblack tslide tkkrq tdiag +doFromToMove m p | moveIsEnPas m = updatePos p { + basicPos = nbp, zobkey = tzobkey, mater = tmater + } + where nbp = BPos { + bpblack = tblack, bpslide = tslide, bpkkrq = tkkrq, bpdiag = tdiag, + bpepcas = tepcas + } + src = fromSquare m + dst = toSquare m + del = moveEnPasDel m + bdel = 1 `unsafeShiftL` del + nbdel = complement bdel + tblack = mvBit src dst (black p) .&. nbdel + tslide = mvBit src dst (slide p) .&. nbdel + tkkrq = mvBit src dst (kkrq p) .&. nbdel + tdiag = mvBit src dst (diag p) .&. nbdel + tepcas = reset50Moves $ epcas p `xor` mvMask -- to do: ep + Busy col fig = tabla p src -- identify the moving piece + Busy _ Pawn = tabla p del -- identify the captured piece (pawn) + CA tzobkey tmater = chainAccum (CA (zobkey p) (mater p)) [ + accumClearSq src p, + accumClearSq del p, + accumSetPiece dst col fig p, + accumMoving p + ] +doFromToMove m p | moveIsTransf m = updatePos p0 { + basicPos = nbp, zobkey = tzobkey, mater = tmater + } + where nbp = BPos { + bpblack = tblack, bpslide = tslide, bpkkrq = tkkrq, bpdiag = tdiag, + bpepcas = tepcas + } + src = fromSquare m + dst = toSquare m + Busy col Pawn = tabla p src -- identify the moving color (piece must be pawn) + pie = moveTransfPiece m + p0 = setPiece src (moving p) pie p + tblack = mvBit src dst $ black p0 + tslide = mvBit src dst $ slide p0 + tkkrq = mvBit src dst $ kkrq p0 + tdiag = mvBit src dst $ diag p0 + tepcas = reset50Moves $ epcas p `xor` mvMask -- to do: ep + CA tzobkey tmater = chainAccum (CA (zobkey p0) (mater p0)) [ + accumClearSq src p0, + accumSetPiece dst col pie p0, + accumMoving p0 + ] +doFromToMove m p | moveIsCastle m = updatePos p { + basicPos = nbp, zobkey = tzobkey, mater = tmater + } + where nbp = BPos { + bpblack = tblack, bpslide = tslide, bpkkrq = tkkrq, bpdiag = tdiag, + bpepcas = tepcas + } + src = fromSquare m + dst = toSquare m + (csr, cds) = case src of + 4 -> case dst of + 6 -> (7, 5) + 2 -> (0, 3) + _ -> error $ "Wrong destination for castle move " ++ show m + 60 -> case dst of + 62 -> (63, 61) + 58 -> (56, 59) + _ -> error $ "Wrong destination for castle move " ++ show m + _ -> error $ "Wrong source for castle move " ++ show m + tblack = mvBit csr cds $ mvBit src dst $ black p + tslide = mvBit csr cds $ mvBit src dst $ slide p + tkkrq = mvBit csr cds $ mvBit src dst $ kkrq p + tdiag = mvBit csr cds $ mvBit src dst $ diag p + -- Here: we have to xor with the zobrist keys for casts! Only when rights change! + tepcas = reset50Moves $ clearCast src $ epcas p `xor` mvMask -- to do: ep + Busy col King = tabla p src -- identify the moving piece (king) + Busy co1 Rook = tabla p csr -- identify the moving rook + CA tzobkey tmater = chainAccum (CA (zobkey p) (mater p)) [ + accumClearSq src p, + accumSetPiece dst col King p, + accumClearSq csr p, + accumSetPiece cds co1 Rook p, + accumMoving p + ] +doFromToMove _ _ = error "doFromToMove: wrong move type" + +reverseMoving :: MyPos -> MyPos +reverseMoving p = p { basicPos = nbp, zobkey = z } + where nbp = (basicPos p) { bpepcas = tepcas } + tepcas = epcas p `xor` mvMask + CA z _ = chainAccum (CA (zobkey p) (mater p)) [ + accumMoving p + ] +-- Here is not clear what to do with castle and en passant... diff --git a/Moves/GenMagics.hs b/Moves/GenMagics.hs new file mode 100644 index 00000000..b91b7eda --- /dev/null +++ b/Moves/GenMagics.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE BangPatterns #-} +module Moves.GenMagics ( + genDatabase, genBishop, genRook, + mskBishop, mskRook, + movKings, movKnights + ) where + +import Data.Array.Unboxed +import Data.Bits +import Data.List +import qualified Data.Set as S +import Data.Word + +import Struct.Struct +import Moves.Magics +import Moves.Muster + +-- Bring one configuration of the given length into a bitboard +-- according to a given pattern +-- The pattern is expressed as an offset from the square, where bit 0 of +-- the configuration will be placed, and a direction for every further bit: +-- 1 for right, -1 for left +-- The pattern will be shifted by the target square before beeing applied +confToBB :: Int -> Int -> Int -> Square -> Word8 -> BBoard +confToBB offs dir len sq conf + = foldl' setIf 0 $ zip (bitList conf len) $ repeat (sq+offs) + where setIf w ((_, False), _) = w + setIf w ((i, True), f) = w `setBit` (dir*i + f) + +bitList c l = zip [0..] [ c `testBit` i | i <- [0..l-1]] + +-- Bring the configuration to different positions relative to a square +toEast len = confToBB len (-1) len +toNorth len = confToBB (8*len) (-8) len +toWest len = confToBB (-len) 1 len +toSouth len = confToBB (-8*len) 8 len +toNoEa len = confToBB (9*len) (-9) len +toNoWe len = confToBB (7*len) (-7) len +toSoWe len = confToBB (-9*len) 9 len +toSoEa len = confToBB (-7*len) 7 len + +-- Generate the mask for sliding pieces per square +genSlMask :: Bool -> Square -> BBoard +genSlMask isrook sq = ma1 .|. ma2 .|. ma3 .|. ma4 + where (ql1, ql2) = quarterLen sq + (q1, q2, q3, q4) = if isrook then ql1 else ql2 + all1 = 0xFF + ma1 = if isrook then toEast q1 sq all1 + else toNoEa q1 sq all1 + ma2 = if isrook then toNorth q2 sq all1 + else toNoWe q2 sq all1 + ma3 = if isrook then toWest q3 sq all1 + else toSoWe q3 sq all1 + ma4 = if isrook then toSouth q4 sq all1 + else toSoEa q4 sq all1 + +-- Rook masks per square +mskRook :: MaArray +mskRook = listArray (0, 63) $ map (genSlMask True) [0..63] + +-- Bishop masks per square +mskBishop :: MaArray +mskBishop = listArray (0,63) $ map (genSlMask False) [0..63] + +movKnights :: MaArray +movKnights = array (0, 63) $ genArray 0x0000000A1100110A 18 + +movKings :: MaArray +movKings = array (0, 63) $ genArray 0x0000000000070507 9 + +-- Generate the list of bishop moves by occupancy for one square +genBishop :: Square -> [(Int, BBoard)] +genBishop sq = S.elems . S.fromList $ zip has rez + where inpr = genInpRez False sq + inps = map fst inpr + rez = map snd inpr + has = map (compHash sq bBits bMagic) inps + +-- Generate the list of rook moves by occupancy for one square +genRook :: Square -> [(Int, BBoard)] +genRook sq = S.elems . S.fromList $ zip has rez + where inpr = genInpRez True sq + inps = map fst inpr + rez = map snd inpr + has = map (compHash sq rBits rMagic) inps + +genDatabase :: (Square -> [(Int, BBoard)]) -> (DbArray, ShArray) +genDatabase f = (db, bg) + where lis = map f [0..63] + anf = scanl (+) 0 $ map ((+ 1) . maximum . map fst) lis + dba = concat $ zipWith (\a l -> map (offset a) l) anf lis + offset a (i, b) = (a+i, b) + db = accumArray repl 0 (0, last anf - 1) dba + bg = listArray (0, length anf - 1) anf + repl _ b = b + +-- This computes the hash of an input given the square, the shift and +-- magic arrays +compHash :: Square -> ShArray -> MaArray -> BBoard -> Int +compHash sq shfa mula inp = fromIntegral $ shiftR (ma * inp) sh + where ma = mula!sq + sh = shfa!sq + +-- Generate the relevant inputs and computes the corresponding attacs +genInpRez :: Bool -> Square -> [(BBoard, BBoard)] +genInpRez isrook sq = lis + where lelis = dlis isrook sq + lis = concatMap goutp lelis + goutp g = zip (inputs g) $ repeat (attacs g) + +data Group = Group { + leader :: !BBoard, + attacs :: !BBoard, + inputs :: [BBoard] + } + +-- Generate all group leaders and all inputs and attacs bitboards for every +-- group leader given a piece type (rook or bishop) and the square +dlis :: Bool -> Square -> [Group] +dlis rook sq = do + (le1, (at1, fo1)) <- src1 + (le2, (at2, fo2)) <- src2 + (le3, (at3, fo3)) <- src3 + (le4, (at4, fo4)) <- src4 + let fo = [f1 .|. f2 .|. f3 .|. f4 | f1 <- fo1, f2 <- fo2, + f3 <- fo3, f4 <- fo4] + return Group { leader = le1 .|. le2 .|. le3 .|. le4, + attacs = at1 .|. at2 .|. at3 .|. at4, + inputs = fo + } + where src1 = if rook then partLi toEast sq q1 a1 + else partLi toNoEa sq q1 a1 + src2 = if rook then partLi toNorth sq q2 a2 + else partLi toNoWe sq q2 a2 + src3 = if rook then partLi toWest sq q3 a3 + else partLi toSoWe sq q3 a3 + src4 = if rook then partLi toSouth sq q4 a4 + else partLi toSoEa sq q4 a4 + (q1, q2, q3, q4) = if rook then qqr else qqb + (qqr, qqb) = quarterLen sq + (a1, a2, a3, a4) = if rook then qar else qab + (qar, qab) = attacLen sq + +-- Return a list of partial input given a direction function, the square +-- the length of the quarter and the length of the attacs in that direction +partLi f sq 0 a = [(0, (f a sq 0xff, [0]))] +partLi f sq q a = do + ql <- qleader q + let fo = map (f q sq) $ qconfig ql + at = f a sq $ qattac ql + return (f q sq ql, (at, fo)) + +-- Compute the quarter lengths for a square +quarterLen :: Square -> ((Int, Int, Int, Int), (Int, Int, Int, Int)) +quarterLen !sq = ((e, n, w, s), (ne, nw, sw, se)) + where ho = sq `mod` 8 + ve = sq `div` 8 + e = if ho <= 6 then 6 - ho else 0 + w = if ho >= 1 then ho - 1 else 0 + n = if ve <= 6 then 6 - ve else 0 + s = if ve >= 1 then ve - 1 else 0 + ne = min n e + nw = min n w + se = min s e + sw = min s w + +-- Compute the attac lengths for a square +attacLen :: Square -> ((Int, Int, Int, Int), (Int, Int, Int, Int)) +attacLen !sq = ((e, n, w, s), (ne, nw, sw, se)) + where ho = sq `mod` 8 + ve = sq `div` 8 + e = 7 - ho + w = ho + n = 7 - ve + s = ve + ne = min n e + nw = min n w + se = min s e + sw = min s w + +-- Generate all possible quarter leaders for a given field witdh. +-- For example, in a quarter of length 2, we have 3 leaders: +-- 10, 01 and 00 +qleader :: Int -> [Word8] +qleader 0 = [] +qleader !x = 0 : take x (iterate (`shiftR` 1) $ 1 `shiftL` (x-1)) + +-- Generate all possible quarter configurations for one quarter leader +qconfig :: Word8 -> [Word8] +qconfig 0 = [0] +qconfig !b = [ b .|. x | x <- [0..b-1]] + +-- Generate the attac bitboard for one quarter leader +qattac :: Word8 -> Word8 +qattac 0 = 0xFF +qattac !b = foldl' (.|.) 0 $ take 8 $ drop 1 $ iterate (`shiftL` 1) b diff --git a/Moves/History.hs b/Moves/History.hs new file mode 100644 index 00000000..a6e3de7a --- /dev/null +++ b/Moves/History.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE BangPatterns #-} +module Moves.History ( + History, newHist, toHist, valHist + ) where + +import Control.Monad (when) +import Control.Arrow (first) + +import qualified Data.Vector.Unboxed.Mutable as V +import Data.Bits + +import Struct.Struct + +type History = V.IOVector Int + +rows, cols, depths, vsize :: Int +rows = 64 +cols = 64 +depths = 20 +vsize = rows * cols * depths + +adr :: Int -> Int -> Int -> Int +adr r c d = (r * rows + c) * depths + d + +newHist :: IO History +newHist = V.replicate vsize 0 + +ad00 = 8 -- 8 -- 1 +-- adp2 = 8 -- 16 -- 1 +-- adp4 = 8 -- 32 -- 1 +-- adp6 = 8 -- 64 -- 1 +-- adm2 = 4 -- 1 -- 4 +-- adm4 = 2 -- 1 -- 2 +-- adm6 = 1 + +pos = [16, 16, 16, 16] +neg = [8, 4, 2, 1] + +toHist :: History -> Bool -> Square -> Square -> Int -> IO () +toHist !h True !f !t !d = do + let ad = adr f t d + addHist h ad ad00 + mapM_ (uncurry (addHist h) . (first ((+) ad))) + (zip (takeWhile (< dd) [2, 4 ..]) pos) + mapM_ (uncurry (addHist h) . (first ((-) ad))) + -- $ takeWhile ((>= d) . fst) $ zip [2, 4 ..] neg + (zip (takeWhile (<= d) [2, 4 ..]) neg) + where dd = depths - d +toHist !h False !f !t !d = do + let ad = adr f t d + subHist h ad ad00 + mapM_ (uncurry (subHist h) . (first ((+) ad))) + (zip (takeWhile (< dd) [2, 4 ..]) pos) + mapM_ (uncurry (subHist h) . (first ((-) ad))) + (zip (takeWhile (<= d) [2, 4 ..]) neg) + where dd = depths - d + +valHist :: History -> Square -> Square -> Int -> IO Int +valHist !h !f !t !d = V.unsafeRead h $! adr f t d + +addHist :: History -> Int -> Int -> IO () +addHist h ad p = do + a <- V.unsafeRead h ad + V.unsafeWrite h ad (a - p) -- trick here: we subtract, so that the sort is big to small + +subHist :: History -> Int -> Int -> IO () +subHist h ad p = do + a <- V.unsafeRead h ad + V.unsafeWrite h ad (a + p) -- trick here: we add, so that the sort is big to small diff --git a/Moves/Magics.hs b/Moves/Magics.hs new file mode 100644 index 00000000..a8c7df25 --- /dev/null +++ b/Moves/Magics.hs @@ -0,0 +1,170 @@ +module Moves.Magics ( + rBits, bBits, rMagic, bMagic + ) where + +import Data.Array.Unboxed + +import Struct.Struct + +sixtyfour x = 64 - x + +-- The magics and shifts for every square and sliding type are +-- generated by a C programm + +rBits, bBits :: ShArray +rBits = listArray (0, 63) $ map sixtyfour [ + 12, 11, 11, 11, 11, 11, 11, 12, + 11, 10, 10, 10, 10, 10, 10, 11, + 11, 10, 10, 10, 10, 10, 10, 11, + 11, 10, 10, 10, 10, 10, 10, 11, + 11, 10, 10, 10, 10, 10, 10, 11, + 11, 10, 10, 10, 10, 10, 10, 11, + 11, 10, 10, 10, 10, 10, 10, 11, + 12, 11, 11, 11, 11, 11, 11, 12 + ] + +bBits = listArray (0, 63) $ map sixtyfour [ + 6, 5, 5, 5, 5, 5, 5, 6, + 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 7, 7, 7, 7, 5, 5, + 5, 5, 7, 9, 9, 7, 5, 5, + 5, 5, 7, 9, 9, 7, 5, 5, + 5, 5, 7, 7, 7, 7, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, + 6, 5, 5, 5, 5, 5, 5, 6 + ] + +rMagic, bMagic :: MaArray +rMagic = listArray (0, 63) [ + 0x80004000976080, + 0x1040400010002000, + 0x4880200210000980, + 0x5280080010000482, + 0x200040200081020, + 0x2100080100020400, + 0x4280008001000200, + 0x1000a4425820300, + 0x29002100800040, + 0x4503400040201004, + 0x209002001004018, + 0x1131000a10002100, + 0x9000800120500, + 0x10e001804820010, + 0x29000402000100, + 0x2002000d01c40292, + 0x80084000200c40, + 0x10004040002002, + 0x201030020004014, + 0x80012000a420020, + 0x129010008001204, + 0x6109010008040002, + 0x950010100020004, + 0x803a0000c50284, + 0x80004100210080, + 0x200240100140, + 0x20004040100800, + 0x4018090300201000, + 0x4802010a00102004, + 0x2001000900040002, + 0x4a02104001002a8, + 0x2188108200204401, + 0x40400020800080, + 0x880402000401004, + 0x10040800202000, + 0x604410a02001020, + 0x200200206a001410, + 0x86000400810080, + 0x428200040600080b, + 0x2001000041000082, + 0x80002000484000, + 0x210002002c24000, + 0x401a200100410014, + 0x5021000a30009, + 0x218000509010010, + 0x4000400410080120, + 0x20801040010, + 0x29040040820011, + 0x4080400024800280, + 0x500200040100440, + 0x2880142001004100, + 0x412020400a001200, + 0x18c028004080080, + 0x884001020080401, + 0x210810420400, + 0x801048745040200, + 0x4401002040120082, + 0x408200210012, + 0x110008200441, + 0x2010002004100901, + 0x801000800040211, + 0x480d000400820801, + 0x820104201280084, + 0x1001040311802142 + ] + +bMagic = listArray (0, 63) [ + 0x1024b002420160, + 0x1008080140420021, + 0x2012080041080024, + 0xc282601408c0802, + 0x2004042000000002, + 0x12021004022080, + 0x880414820100000, + 0x4501002211044000, + 0x20402222121600, + 0x1081088a28022020, + 0x1004c2810851064, + 0x2040080841004918, + 0x1448020210201017, + 0x4808110108400025, + 0x10504404054004, + 0x800010422092400, + 0x40000870450250, + 0x402040408080518, + 0x1000980a404108, + 0x1020804110080, + 0x8200c02082005, + 0x40802009a0800, + 0x1000201012100, + 0x111080200820180, + 0x904122104101024, + 0x4008200405244084, + 0x44040002182400, + 0x4804080004021002, + 0x6401004024004040, + 0x404010001300a20, + 0x428020200a20100, + 0x300460100420200, + 0x404200c062000, + 0x22101400510141, + 0x104044400180031, + 0x2040040400280211, + 0x8020400401010, + 0x20100110401a0040, + 0x100101005a2080, + 0x1a008300042411, + 0x120a025004504000, + 0x4001084242101000, + 0xa020202010a4200, + 0x4000002018000100, + 0x80104000044, + 0x1004009806004043, + 0x100401080a000112, + 0x1041012101000608, + 0x40400c250100140, + 0x80a10460a100002, + 0x2210030401240002, + 0x6040aa108481b20, + 0x4009004050410002, + 0x8106003420200e0, + 0x1410500a08206000, + 0x92548802004000, + 0x1040041241028, + 0x120042025011, + 0x8060104054400, + 0x20004404020a0a01, + 0x40008010020214, + 0x4000050209802c1, + 0x208244210400, + 0x10140848044010 + ] diff --git a/Moves/Moves.hs b/Moves/Moves.hs new file mode 100644 index 00000000..c042f9a7 --- /dev/null +++ b/Moves/Moves.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE BangPatterns #-} +module Moves.Moves ( + movesInit, pAttacs, + fAttacs, + pMovs, + kAttacs, qAttacs, rAttacs, bAttacs, nAttacs, + pAll1Moves, pAll2Moves + ) where + +import Data.Array.Base +import Data.Array.Unboxed +import Data.Bits + +import Struct.Struct +import Moves.GenMagics +import Moves.Magics +import Moves.BitBoard +import Moves.Muster + +-- Used to compute all the needed tables by initialiasation: +movesInit + | w == 0 = 0 + | otherwise = 1 + where r = rAttacs 0 0 + b = bAttacs 1 0 + k = kAttacs 2 + n = nAttacs 3 + w = r .|. b .|. k .|. n + +-- Move tables and hash function for sliding pieces +data SlMoves = SlMoves { + database :: DbArray, + dbbegins :: ShArray, + shifts :: ShArray, + masks :: MaArray, + magics :: MaArray + } + +(bdb, bdbb) = genDatabase genBishop +(rdb, rdbb) = genDatabase genRook + +bishopMoves = SlMoves { + database = bdb, dbbegins = bdbb, shifts = bBits, + masks = mskBishop, magics = bMagic + } + +rookMoves = SlMoves { + database = rdb, dbbegins = rdbb, shifts = rBits, + masks = mskRook, magics = rMagic + } + +{-# INLINE smoves #-} +smoves :: SlMoves -> BBoard -> Square -> BBoard +smoves bbmoves occup sq = database bbmoves `unsafeAt` idx + where idx = dbbegins bbmoves `unsafeAt` sq + off + off = fromIntegral + $ ((occup .&. masks bbmoves `unsafeAt` sq) * magics bbmoves `unsafeAt` sq) + `unsafeShiftR` (shifts bbmoves `unsafeAt` sq) + +{-# INLINE smoves2 #-} +smoves2 :: SlMoves -> SlMoves -> BBoard -> Square -> BBoard +smoves2 bbmoves1 bbmoves2 occup sq + = bb1 .|. bb2 + where bb1 = database bbmoves1 `unsafeAt` idx1 + bb2 = database bbmoves2 `unsafeAt` idx2 + idx1 = dbbegins bbmoves1 `unsafeAt` sq + off1 + idx2 = dbbegins bbmoves2 `unsafeAt` sq + off2 + off1 = fromIntegral + $ ((occup .&. masks bbmoves1 `unsafeAt` sq) * magics bbmoves1 `unsafeAt` sq) + `unsafeShiftR` (shifts bbmoves1 `unsafeAt` sq) + off2 = fromIntegral + $ ((occup .&. masks bbmoves2 `unsafeAt` sq) * magics bbmoves2 `unsafeAt` sq) + `unsafeShiftR` (shifts bbmoves2 `unsafeAt` sq) + +{-# INLINE fmoves #-} +fmoves :: MaArray -> Square -> BBoard +-- fmoves maarr sq = maarr `unsafeAt` sq +fmoves = unsafeAt + +{-# INLINE kAttacs #-} +{-# INLINE rAttacs #-} +{-# INLINE bAttacs #-} +{-# INLINE qAttacs #-} +{-# INLINE nAttacs #-} +kAttacs = fmoves movKings +rAttacs = smoves rookMoves +bAttacs = smoves bishopMoves +qAttacs = smoves2 bishopMoves rookMoves +nAttacs = fmoves movKnights + +-- The moves of a white pawn (no captures) +pawnSlideW :: Square -> BBoard -> BBoard +pawnSlideW !sq oc + | bb1 .&. oc /= 0 = 0 + | row /= sec || bb2 .&. oc /= 0 = bb1 + | otherwise = bb12 + where bb1 = 1 `unsafeShiftL` (sq + 8) + !bb2 = bb1 `unsafeShiftL` 8 + !bb12 = bb1 .|. bb2 + !row = sq `unsafeShiftR` 3 + sec = 1 + +-- The moves of a black pawn (no captures) +pawnSlideB :: Square -> BBoard -> BBoard +pawnSlideB !sq oc + | bb1 .&. oc /= 0 = 0 + | row /= sec || bb2 .&. oc /= 0 = bb1 + | otherwise = bb12 + where bb1 = 1 `unsafeShiftL` (sq - 8) -- here L is ok! Replaces a 'bit sq `shiftR` 8' + !bb2 = bb1 `unsafeShiftR` 8 + !bb12 = bb1 .|. bb2 + !row = sq `unsafeShiftR` 3 + sec = 6 + +-- Pawn attacs +whitePawnAtt, blackPawnAtt :: MaArray +whitePawnAtt = array (0, 63) $ genArray 0x00000050000 9 +blackPawnAtt = array (0, 63) $ genArray 0x50000000000 49 + +pAttacs :: Color -> Square -> BBoard +pAttacs White sq = whitePawnAtt `unsafeAt` sq +pAttacs Black sq = blackPawnAtt `unsafeAt` sq +{-# INLINE pAttacs #-} + +pMovs s White o = pawnSlideW s o +pMovs s Black o = pawnSlideB s o + +pAll1Moves :: Color -> BBoard -> BBoard -> [(Square, Square)] +pAll1Moves White !pawns !occup = map f $ bbToSquares $ (pawns `unsafeShiftL` 8) `less` occup + where f !x = (x - 8, x) +pAll1Moves Black !pawns !occup = map f $ bbToSquares $ (pawns `unsafeShiftR` 8) `less` occup + where f !x = (x + 8, x) + +pAll2Moves :: Color -> BBoard -> BBoard -> [(Square, Square)] +pAll2Moves White pawns occup = map f $ bbToSquares $ (pawns2 `unsafeShiftL` 16) `less` occ2 + where pawns2 = pawns .&. 0x000000000000FF00 + occ2 = occup .|. (occup `unsafeShiftL` 8) + f !x = (x - 16, x) +pAll2Moves Black pawns occup = map f $ bbToSquares $ (pawns2 `unsafeShiftR` 16) `less` occ2 + where pawns2 = pawns .&. 0x00FF000000000000 + occ2 = occup .|. (occup `unsafeShiftR` 8) + f !x = (x + 16, x) + +{-# INLINE fAttacs #-} +fAttacs :: Square -> Piece -> BBoard -> BBoard -- piece attacs except pawn +fAttacs sq King _ = kAttacs sq +fAttacs sq Knight _ = nAttacs sq +fAttacs sq Bishop oc = bAttacs oc sq +fAttacs sq Rook oc = rAttacs oc sq +fAttacs sq Queen oc = qAttacs oc sq +fAttacs _ _ _ = 0 -- this would be for pawn, which is calculated different diff --git a/Moves/Muster.hs b/Moves/Muster.hs new file mode 100644 index 00000000..2e456b77 --- /dev/null +++ b/Moves/Muster.hs @@ -0,0 +1,71 @@ +module Moves.Muster ( + genArray, + row1, row2, row3, row4, row5, row6, row7, row8, + fileA, fileB, fileC, fileD, fileE, fileF, fileG, fileH, + rowBB, colBB, + rookFiles, lightSquares, darkSquares + ) where + +import Data.Word +import Data.Bits +import Data.Array.Unboxed + +import Struct.Struct + +row1 = 0xFF :: BBoard +row2 = 0xFF00 :: BBoard +row3 = 0xFF0000 :: BBoard +row4 = 0xFF000000 :: BBoard +row5 = 0xFF00000000 :: BBoard +row6 = 0xFF0000000000 :: BBoard +row7 = 0xFF000000000000 :: BBoard +row8 = 0xFF00000000000000 :: BBoard + +fileA = 0x0101010101010101 :: BBoard +fileB = 0x0202020202020202 :: BBoard +fileC = 0x0404040404040404 :: BBoard +fileD = 0x0808080808080808 :: BBoard +fileE = 0x1010101010101010 :: BBoard +fileF = 0x2020202020202020 :: BBoard +fileG = 0x4040404040404040 :: BBoard +fileH = 0x8080808080808080 :: BBoard + +rookFiles = fileA .|. fileH + +lightSquares = 0xAA55AA55AA55AA55 :: BBoard +darkSquares = 0x55AA55AA55AA55AA :: BBoard + +-- Arrays of rows and files +rowArray, fileArray :: UArray Int BBoard +rowArray = listArray (0, 7) [row1, row2, row3, row4, row5, row6, row7, row8] +fileArray = listArray (0, 7) [fileA, fileB, fileC, fileD, fileE, fileF, fileG, fileH] + +rowBB, colBB :: Int -> BBoard +rowBB = (!) rowArray +colBB = (!) fileArray + +left = flip shiftR 1 . (.&.) (complement fileA) +right = flip shiftL 1 . (.&.) (complement fileH) +down = flip shiftR 8 +up = flip shiftL 8 + +type Elem = (Int, BBoard) + +genArray :: BBoard -> Int -> [Elem] +genArray b i = concatMap genRow $ genFile e + where e = (i, b) + +genDir :: (Elem -> Elem) -> (Elem -> Bool) -> Elem -> [Elem] +genDir g f e = drop 1 $ takeWhile f $ iterate g e + +genLeft ib@(i0, _) = genDir (\(i, b) -> (i-1, left b)) (\(i, _) -> i `div` 8 == i0 `div` 8) ib + +genRight ib@(i0, _) = genDir (\(i, b) -> (i+1, right b)) (\(i, _) -> i `div` 8 == i0 `div` 8) ib + +genDown = genDir (\(i, b) -> (i-8, down b)) (\(i, _) -> i >= 0) + +genUp = genDir (\(i, b) -> (i+8, up b)) (\(i, _) -> i <= 63) + +genFile e = e : genUp e ++ genDown e + +genRow e = e : genLeft e ++ genRight e diff --git a/Moves/SEE.hs b/Moves/SEE.hs new file mode 100644 index 00000000..7c3dc267 --- /dev/null +++ b/Moves/SEE.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, BangPatterns #-} +module Moves.SEE + ( + findLKA, + myPieces, yoPieces, thePieces, + genMoveCaptSEE, + genMoveCaptWL + -- valueSEE, figAttacking, allAttackingPawns + ) + where + +import Prelude hiding ((++), concatMap, concat, map, reverse, tail, take, foldr, + null, repeat, filter, head, takeWhile, zip, length) +import Data.Bits +import Data.List.Stream +import Data.Ord +import Data.Array + +import Struct.Struct +import Moves.Moves +import Moves.BitBoard +import Eval.BasicEval + +{-# INLINE srcDestsSEE #-} +srcDestsSEE :: Piece -> (Square -> BBoard) -> Square -> [((Piece, Square), Square)] +srcDestsSEE p f !s = zip (repeat (p, s)) $ bbToSquares $ f s + +-- find pinning lines for a piece type, given the king & piece squares +-- the queen is very hard, so we solve it as a composition of rook and bishop +-- and when we call findLKA we always know as which piece the queen checks +{-# INLINE findLKA #-} +findLKA Queen ksq psq + | rAttacs bpsq ksq .&. bpsq == 0 = findLKA Bishop ksq psq + | otherwise = findLKA Rook ksq psq + where bpsq = bit psq +findLKA pt ksq psq = (psq, kp .&. pk) + where kp = fAttacs ksq pt $ bit psq + pk = fAttacs psq pt $ bit ksq + +{-# INLINE myPieces #-} +myPieces :: MyPos -> Color -> BBoard +myPieces !p !c = if c == White then white p else black p + +{-# INLINE yoPieces #-} +yoPieces :: MyPos -> Color -> BBoard +yoPieces !p !c = if c == White then black p else white p + +{-# INLINE thePieces #-} +thePieces :: MyPos -> Color -> (BBoard, BBoard) +thePieces p c = if c == White then (white p, black p) else (black p, white p) + +-- The new SEE functions (swap-based) +-- Choose the cheapest of a set of pieces +chooseAttacker :: MyPos -> BBoard -> (BBoard, (Piece, Int)) +chooseAttacker pos frompieces = go funcPiecesAsc + where go [] = (0, (Pawn, 0)) -- should never happen + go ((p,f):fps) + | subset == 0 = go fps + | otherwise = (lsb subset, (p, value p)) + where subset = frompieces .&. f pos + +funcPiecesAsc = [ (Pawn, pawns), (Knight, knights), (Bishop, bishops), + (Rook, rooks), (Queen, queens), (King, kings) ] +-- funcPiecesDsc = reverse funcPiecesAsc -- will we need this? + +funcPiecesSli = [ (bAttacs, bishops), (rAttacs, rooks), (qAttacs, queens) ] + +allAttackingPawns :: MyPos -> Square -> BBoard -> BBoard +allAttackingPawns pos sq moved + = (pAttacs White sq .&. black pos .|. pAttacs Black sq .&. white pos) .&. (pawns pos `less` moved) + +newAttacs :: MyPos -> Square -> BBoard -> BBoard +newAttacs pos sq moved = foldl' go (allAttackingPawns pos sq moved) $ tail funcPiecesAsc + where go z (p, f) = z .|. (modi f .&. fAttacs sq p (occup pos `less` moved)) + modi f = f pos `less` moved + +-- unimax [] a = a +-- unimax (g:gs) a = unimax gs (min g (-a)) + +unimax gs a = foldl' (\a g -> min g (-a)) a gs + +value = matPiece White + +genMoveCaptSEE :: MyPos -> Color -> [(Square, Square)] +genMoveCaptSEE pos col = foldr (perCapt pos col mypc) [] $ bbToSquares capts + where (mypc, yopc) = thePieces pos col + myAtt = if col == White then whAttacs pos else blAttacs pos + capts = myAtt .&. yopc + +perCapt :: MyPos -> Color -> BBoard -> Square -> [(Square, Square)] -> [(Square, Square)] +perCapt pos col mypc sq sqs = if v >= 0 then (sqf, sq) : sqs else sqs + where attacs = newAttacs pos sq 0 + -- mymovp = attacs .&. (mypc `less` pinned pos) -- `less` myking -- kinv + Busy _ pcto = tabla pos sq + -- (v, sqf) = valueSEE pos col sq attacs (value pcto) + (v, sqf) = valueSEE pos col sq pcto + myking = mypc .&. kings pos + kinv = if attacs `less` mypc /= 0 then myking else 0 + +valueSEE :: MyPos -> Color -> Square -> Piece -> (Int, Square) +valueSEE pos col sqto pieceto = (v, firstOne initset) + where v = go gain0 attacs0 (occup pos) initset p valfrom 0 (mypc, yopc) [(p, pieceto, gain0)] + go :: Int -> BBoard -> BBoard -> BBoard -> Piece -> Int -> BBoard -> (BBoard, BBoard) -> [(Piece, Piece, Int)] -> Int + go gain attacs occ fromset pfrom val moved (fcolp, ocolp) acc = + let gain' = val - gain + occ' = occ `xor` fromset + moved' = moved .|. fromset + attacs'' = attacs `xor` fromset + attacs' = if fromset .&. mayXRay /= 0 then newAttacs pos sqto moved' else attacs'' + (fromset', (p, val')) = chooseAttacker pos (attacs'' .&. ocolp) + in if fromset' == 0 + then unimax (map (\(_,_,x) -> x) acc) (minBound+2) + else go gain' attacs' occ' fromset' p val' moved' (ocolp, fcolp) ((p, pfrom, gain'):acc) + gain0 = value pieceto + (mypc, yopc) = thePieces pos col + (initset, (p, valfrom)) = chooseAttacker pos (attacs0 .&. mypc) + mayXRay = pawns pos .|. bishops pos .|. rooks pos .|. queens pos + attacs0 = newAttacs pos sqto 0 + +seeMoveValue :: MyPos -> Color -> Square -> Square -> Int -> Int +seeMoveValue pos col sqfa sqto gain0 = v + where v = go gain0 attacs0 occup0 from0 valfrom moved0 (yopc, mypc) [gain0] + go :: Int -> BBoard -> BBoard -> BBoard -> Int -> BBoard -> (BBoard, BBoard) -> [Int] -> Int + go gain attacs occ from val moved (fcolp, ocolp) acc = + let gain' = val - gain + occ' = occ `xor` from + moved' = moved .|. from + attacs'' = attacs `xor` from + attacs' = if from .&. mayXRay /= 0 then newAttacs pos sqto moved' else attacs'' + (from', (_, val')) = chooseAttacker pos (attacs'' .&. ocolp) + in if from' == 0 + then unimax acc (minBound+2) + else go gain' attacs' occ' from' val' moved' (ocolp, fcolp) (gain':acc) + (mypc, yopc) = thePieces pos col + (from0, (_, valfrom)) = chooseAttacker pos (attacs0 .&. yopc) + mayXRay = pawns pos .|. bishops pos .|. rooks pos .|. queens pos + moved0 = bit sqfa + attacs0 = newAttacs pos sqto moved0 + occup0 = occup pos `xor` moved0 + +-- This function can produce illegal captures with the king! +genMoveCaptWL :: MyPos -> Color -> ([(Square, Square)], [(Square, Square)]) +genMoveCaptWL pos col = (swl, sll) + where (wl, ll) = foldr (perCaptFieldWL pos col mypc yoAtt) ([],[]) $ bbToSquares capts + (mypc, yopc) = thePieces pos col + (myAtt, yoAtt) = if col == White -- here: for yoAtts: X-Ray is not considered!!! + then (whAttacs pos, blAttacs pos) + else (blAttacs pos, whAttacs pos) + capts = myAtt .&. yopc + swl = map snd $ sortBy (comparing fst) wl + sll = map snd $ sortBy (comparing fst) ll + +perCaptFieldWL :: MyPos -> Color -> BBoard -> BBoard -> Square + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) +perCaptFieldWL pos col mypc advdefence sq mvlst + = if hanging + then foldr (addHanging valto sq) mvlst $ bbToSquares myattacs + else foldr (perCaptWL pos col valto sq) mvlst $ bbToSquares myattacs + where myattacs = mypc .&. newAttacs pos sq 0 + Busy _ pcto = tabla pos sq + valto = value pcto + hanging = not (advdefence `testBit` sq) + +approximateEasyCapts = True + +perCaptWL :: MyPos -> Color -> Int -> Square -> Square + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) +perCaptWL pos col gain0 sq sqfa (wsqs, lsqs) + = if approx || adv <= gain0 + -- then (inssort ss wsqs, lsqs) + -- else (wsqs, inssort ss lsqs) + then (ss:wsqs, lsqs) + else (wsqs, ss:lsqs) + where ss = (-win, (sqfa, sq)) + approx = approximateEasyCapts && gain1 >= 0 + win = if approx then gain1 else myv + Busy _ pcfa = tabla pos sqfa + v0 = value pcfa + gain1 = gain0 - v0 + adv = seeMoveValue pos col sqfa sq v0 + myv = gain0 - adv + +-- Captures of hanging pieces are always winning +addHanging :: Int -> Square -> Square + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) + -> ([(Int, (Square, Square))], [(Int, (Square, Square))]) +-- addHanging val to from (wsqs, lsqs) = (inssort (val, (from, to)) wsqs, lsqs) +addHanging val to from (wsqs, lsqs) = ((-val, (from, to)):wsqs, lsqs) + +inssort vp [] = [vp] +inssort vp@(v, _) vps@(vp1@(v1, _) : vp1s) + | v >= v1 = vp : vps + | otherwise = vp1 : inssort vp vp1s diff --git a/Moves/ShowMe.hs b/Moves/ShowMe.hs new file mode 100644 index 00000000..2a0b414a --- /dev/null +++ b/Moves/ShowMe.hs @@ -0,0 +1,44 @@ +module Moves.ShowMe where + +import Data.Array.Unboxed +import Data.Bits +import Data.List +import Data.Word + +-- Help functions (good for debug) +printBB :: Word64 -> IO () +printBB = putStr . showBB + +showBB b = unlines $ map showBin + $ reverse $ take 8 $ iterate (`shiftR` 8) b + where showBin w = intersperse ' ' $ map sb [ w `testBit` i | i <- [0..7]] + sb False = '0' + sb True = '1' + +showc :: UArray Int Char +-- showc = array (0, 15) $ zip [0..] $ ['0' .. '9'] ++ ['A' .. 'F'] +showc = array (0, 15) $ zip [0..] ".PNKxBRQ.pnkybrq" + +showLine :: Word8 -> Word8 -> Word8 -> Word8 -> String +showLine w1 w2 w3 w4 = go w1 w2 w3 w4 8 "" + where go :: Word8 -> Word8 -> Word8 -> Word8 -> Int -> String -> String + go _ _ _ _ 0 cs = cs + go x y z t n cs + = go (x `shift` 1) (y `shift` 1) (z `shift` 1) (t `shift` 1) (n-1) (c:' ':cs) + where c = showc ! cap x y z t + +cap x y z t = fromIntegral $ (x' .|. shiftR y' 1 .|. shiftR z' 2 .|. shiftR t' 3) `shiftR` 4 + where x' = x .&. 0x80 + y' = y .&. 0x80 + z' = z .&. 0x80 + t' = t .&. 0x80 + +showTab :: Word64 -> Word64 -> Word64 -> Word64 -> String +showTab w1 w2 w3 w4 = go w1 w2 w3 w4 8 + where go _ _ _ _ 0 = "" + go x y z t n = showLine (byte x) (byte y) (byte z) (byte t) ++ "\n" + ++ go (next x) (next y) (next z) (next t) (n-1) + byte u = fromIntegral $ u `shiftR` 56 + next u = u `shift` 8 + +printTab w1 w2 w3 w4 = putStr $ showTab w1 w2 w3 w4 diff --git a/Search/Albeta.hs b/Search/Albeta.hs new file mode 100644 index 00000000..79b5fb25 --- /dev/null +++ b/Search/Albeta.hs @@ -0,0 +1,1472 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +module Search.Albeta ( + alphaBeta, logmes +) where + +import Control.Monad +import Control.Monad.State hiding (gets, modify) +import Data.Bits ((.&.)) +import Data.List (delete, sortBy) +import Data.Ord (comparing) +import Data.Array.Base +import Data.Array.Unboxed +import Data.Maybe (fromMaybe) + +import Search.SearchMonad +import Search.AlbetaTypes +import Struct.Struct +import Moves.Base + +-- debug :: Bool +-- debug = False + +-- To generate info for tree vizualization +viztree :: Bool +#ifdef VIZTREE +viztree = True +#else +viztree = False +#endif + +-- Parameter for aspiration +useAspirWin :: Bool +useAspirWin = False +-- aspIncr :: UArray Int Int +-- aspIncr = array (1, 3) [ (1, 128), (2, 32), (3, 8) ] +-- aspTries = 3 +-- Aspiration parameter optimization - 300 games: +-- First digit: tries, second: version (see below) +-- a21 = 64, 8 -> elo -8 +- 59 +-- a22 = 64, 16 -> elo -2 +- 58 +-- a23 = 128, 16 -> elo -32 +- 60 +-- a31 = 64, 16, 4 -> elo -10 +- 57 +-- a32 = 128, 32, 8 -> elo +53 +- 60 --> this is it +-- a33 = 100, 20, 4 -> elo 0 +- 58 + +-- Some fix search parameter +scoreGrain, depthForCM, minToStore, minToRetr, maxDepthExt, negHistMNo :: Int +useNegHist, useTTinPv :: Bool +scoreGrain = 4 -- score granularity +depthForCM = 7 -- from this depth inform current move +minToStore = 1 -- minimum remaining depth to store the position in hash +minToRetr = 1 -- minimum remaining depth to retrieve +maxDepthExt = 3 -- maximum depth extension +useNegHist = False -- when not cutting - negative history +negHistMNo = 1 -- how many moves get negative history +useTTinPv = False -- retrieve from TT in PV? + +-- Parameters for late move reduction: +lmrActive :: Bool +lmrActive = True + +lmrMaxDepth, lmrMaxWidth :: Int +lmrMaxDepth = 15 +lmrMaxWidth = 63 +lmrPv, lmrRest :: Double +lmrPv = 13 +lmrRest = 8 +-- LMR parameter optimisation (lmrPv, lmrRest): +-- lm1 = 2, 1 -> elo -127 +- 58 +-- lm2 = 3, 2 -> elo -14 +- 52 +-- lm3 = 5, 3 -> elo 17 +- 55 +-- lm4 = 8, 5 -> elo 32 +- 53 +-- lm5 = 13, 8 -> elo 92 +- 54 --> this is it +lmrReducePv, lmrReduceArr :: UArray (Int, Int) Int +lmrReducePv = array ((1, 1), (lmrMaxDepth, lmrMaxWidth)) + [((i, j), ceiling $ logrd i j lmrPv) | i <- [1..lmrMaxDepth], j <- [1..lmrMaxWidth]] +lmrReduceArr = array ((1, 1), (lmrMaxDepth, lmrMaxWidth)) + [((i, j), ceiling $ logrd i j lmrRest) | i <- [1..lmrMaxDepth], j <- [1..lmrMaxWidth]] + +logrd :: Int -> Int -> Double -> Double +logrd i j f = log (fromIntegral i) * log (fromIntegral j) / f + +-- Parameters for futility pruning: +futilActive :: Bool +futilActive = True + +maxFutilDepth :: Int +maxFutilDepth = 3 + +-- This is a linear formula for futility margin +-- Should apply from 1 to maxFutilDepth (checked elsewehere) +-- Optimisation for futilMs: +-- A: 25 +-- B: 50 +-- C: 75 == n1ns +-- D: 100 +-- E: 125 +futilMs = 275 -- margin for depth 1 +futilMv = 150 -- suplementary margin for every further depth +futilMargins :: Int -> Int +futilMargins d = futilMs - futilMv + d*futilMv + +-- Parameters for quiescent search: +qsBetaCut, qsDeltaCut :: Bool +qsBetaCut = True -- use beta cut in QS? +qsDeltaCut = True -- use delta prune in QS? +qsMaxChess :: Int +qsMaxChess = 2 -- max number of chess for a quiet search path + +-- Parameters for null move pruning +nulActivate :: Bool +nulActivate = True -- activate null move reduction +nulRedux, nulMoves :: Int +nulRedux = 2 -- depth reduction for null move +nulMoves = 2 -- how many null moves in sequence are allowed (one or two) +nulMargin, nulSubmrg :: Int +nulMargin = 1 -- margin to search the null move (over beta) (in scoreGrain units!) +nulSubmrg = 2 -- improved margin (in scoreGrain units!) +nulSubAct :: Bool +nulSubAct = True + +-- Parameters for internal iterative deepening +useIID :: Bool +useIID = False + +minIIDPV, minIIDCut, maxIIDDepth :: Int +minIIDPV = 5 +minIIDCut = 7 +maxIIDDepth = 3 + +iidNewDepth :: Int -> Int +iidNewDepth = subtract 1 +-- iidNewDepth = `shiftR` 1 -- i.e. div 2 + +-- Parameter for quiescenst search +inEndlessCheck, qsDelta :: Int +inEndlessCheck = -scoreGrain -- there is a risk to be left in check +qsDelta = 1100 + +type Search m a = forall r. STPlus r PVState m a + +alpha0, beta0 :: Int +alpha0 = minBound + 2000 +beta0 = maxBound - 2000 + +data Pvsl = Pvsl { + pvPath :: Path, -- pv path + pvNodes :: !Int, -- number of nodes in the current search + pvGood :: !Bool -- beta cut or alpha improvement + } deriving Show + +data Killer = NoKiller | OneKiller Move Int | TwoKillers Move Int Move Int + deriving Show + +-- Read only parameters of the search, so that we can change them programatically +data PVReadOnly + = PVReadOnly { + draft :: !Int, -- root search depth + albest :: !Bool, -- always choose the best move (i.e. first) + timeli :: !Bool, -- do we have time limit? + abmili :: !Int -- abort when after this milisecond + } deriving Show + +data PVState + = PVState { + ronly :: !PVReadOnly, -- read only parameters + absdp :: !Int, -- absolute depth (root = 0) + usedext :: !Int, -- used extension + abort :: !Bool, -- search aborted (time) + short :: !Bool, -- for check path (shorter than depth in pv) + stats :: !SStats -- search statistics + } deriving Show + +-- This is a state which reflects the status of alpha beta in a node while going through the edges +data NodeState + = NSt { + crtnt :: !NodeType, -- parent node type (actually expected) + nxtnt :: !NodeType, -- expected child node type + forpv :: !Bool, -- still searching for PV? + cursc :: !Path, -- current alpha value (now plus path & depth) + movno :: !Int, -- current move number + pvsl :: [Pvsl], -- principal variation list (at root) with node statistics + killer :: !Killer, -- the current killer moves + pvcont :: Seq Move -- a pv continuation from the previous iteration, if available + } deriving Show + +data SStats = SStats { + sNodes, sNodesQS, sRetr, sRSuc :: !Int + } deriving Show + +-- The node type is the expected node type of the new (child) node, which +-- is obtained by making one move from the current (parent) node +data NodeType = PVNode | CutNode | AllNode deriving (Eq, Show) + +deepNodeType :: NodeType -> NodeType +deepNodeType PVNode = PVNode +deepNodeType CutNode = AllNode +deepNodeType AllNode = CutNode + +nextNodeType :: NodeType -> NodeType +nextNodeType PVNode = CutNode +nextNodeType t = t + +newtype Alt e = Alt { unalt :: [e] } deriving Show +newtype Seq e = Seq { unseq :: [e] } deriving Show + +firstMove :: Seq Move -> Move +firstMove = head . unseq + +data Path + = Path { + pathScore :: !Int, + pathDepth :: !Int, + pathMoves :: Seq Move, + pathOrig :: String + } deriving Show + +staleMate = Path { pathScore = 0, pathDepth = 0, pathMoves = Seq [], pathOrig = "stale mate" } +matedPath = Path { pathScore = -mateScore, pathDepth = 0, pathMoves = Seq [], pathOrig = "mated" } + +-- Making a path from a plain score: +pathFromScore :: String -> Int -> Path +pathFromScore ori s = Path { pathScore = s, pathDepth = 0, pathMoves = Seq [], pathOrig = ori } + +-- Add a move to a path: +addToPath :: Move -> Path -> Path +addToPath e p = p { pathDepth = pathDepth p + 1, pathMoves = Seq $ e : unseq (pathMoves p) } + +-- Take only the score from a path (to another), rest empty +onlyScore :: Path -> Path +onlyScore p = Path { pathScore = pathScore p, pathDepth = 0, pathMoves = Seq [], + pathOrig = "onlyScore from " ++ pathOrig p } + +-- Take all from the first path, except the score, which comes from the second (for fail hard) +combinePath :: Path -> Path -> Path +combinePath p1 p2 = p1 { pathScore = pathScore p2, + pathOrig = "(" ++ pathOrig p1 ++ ") <+> (" ++ pathOrig p2 ++ ")" } + +-- When we negate the path, we empty the moves, so the new path is adequate +-- for the adverse part; then we can use always bestPath to get the path with longer sequence +negatePath :: Path -> Path +negatePath p = p { pathScore = - pathScore p, pathDepth = 0, pathMoves = Seq [], + pathOrig = "negatePath (" ++ pathOrig p ++ ")" } + +-- This should be used only when scores are equal +-- Then it takes the longer path +bestPath :: Path -> Path -> Path +bestPath a b + | a == b = if pathDepth b > pathDepth a then b else a + | otherwise = error $ "bestPath on unequal scores: " ++ show a ++ " versus " ++ show b + +(-:) :: Path -> Int -> Path +p -: s = p { pathScore = pathScore p - s, pathOrig = pathOrig p ++ " <-:> " ++ show s } + +pnearmate :: Path -> Bool +pnearmate = nearmate . pathScore + +pnextlev :: Path -> Path +pnextlev p = p { pathScore = - pathScore p } + +-- If we compare depths when equal scores, then nothing works anymore! +instance Eq Path where + -- p1 == p2 = pathScore p1 == pathScore p2 && pathDepth p1 == pathDepth p2 + p1 == p2 = pathScore p1 == pathScore p2 + +instance Ord Path where + compare p1 p2 = ord + where !ord = if pathScore p1 < pathScore p2 + then LT + else if pathScore p1 > pathScore p2 + then GT + else EQ + +instance Bounded Path where + minBound = Path { pathScore = minBound, pathDepth = 0, pathMoves = Seq [], pathOrig = "" } + maxBound = Path { pathScore = maxBound, pathDepth = 0, pathMoves = Seq [], pathOrig = "" } + +noMove :: Alt Move -> Bool +noMove (Alt es) = null es + +nullSeq :: Seq Move -> Bool +nullSeq (Seq es) = null es + +emptySeq :: Seq Move +emptySeq = Seq [] + +pvsInit :: PVState +pvsInit = PVState { ronly = pvro00, absdp = 0, usedext = 0, + abort = False, short = False, stats = stt0 } +nst0 :: NodeState +nst0 = NSt { crtnt = PVNode, nxtnt = PVNode, forpv = True, cursc = pathFromScore "Zero" 0, + movno = 1, killer = NoKiller, pvsl = [], pvcont = emptySeq } + +stt0 :: SStats +stt0 = SStats { sNodes = 0, sNodesQS = 0, sRetr = 0, sRSuc = 0 } + +pvro00 :: PVReadOnly +pvro00 = PVReadOnly { draft = 0, albest = False, timeli = False, abmili = 0 } + +alphaBeta :: Node m => ABControl -> m (Int, [Move], [Move]) +alphaBeta abc = {-# SCC "alphaBeta" #-} do + let !d = maxdepth abc + rmvs = Alt $ rootmvs abc + lpv = Seq $ lastpv abc + searchReduced a b = pvRootSearch a b d lpv rmvs True + -- We have lastpath as a parameter here (can change after fail low or high) + searchFull lp = pvRootSearch alpha0 beta0 d lp rmvs False + pvro = PVReadOnly { draft = d, albest = best abc, + timeli = stoptime abc /= 0, abmili = stoptime abc } + pvs0 = pvsInit { ronly = pvro } :: PVState + r <- if useAspirWin + then case lastscore abc of + Just sp -> do + let !alpha1 = sp - window abc + !beta1 = sp + window abc + -- informStr $ "+++ Aspi search with d = " ++ show d + -- ++ " alpha = " ++ show alpha1 + -- ++ " beta = " ++ show beta1 + -- aspirWin alpha1 beta1 d lpv rmvs aspTries + r1@((s1, es1, _), pvsf) + <- {-# SCC "alphaBetaSearchReduced" #-} + runSearch (searchReduced alpha1 beta1) pvs0 + if abort pvsf || (s1 > alpha1 && s1 < beta1 && not (nullSeq es1)) + then return r1 + else {-# SCC "alphaBetaSearchFullRe" #-} if nullSeq es1 + then runSearch (searchFull lpv) pvs0 + else runSearch (searchFull es1) pvs0 + Nothing -> {-# SCC "alphaBetaSearchFullIn" #-} runSearch (searchFull lpv) pvs0 + else {-# SCC "alphaBetaSearchFull" #-} runSearch (searchFull lpv) pvs0 + -- when aborted, return the last found good move + -- we have to trust that abort is never done in draft 1! + -- if abort (snd r) + -- then return (fromMaybe 0 $ lastscore abc, lastpv abc, []) + -- else return $! case fst r of (s, Seq path, Alt rmvs') -> (s, path, rmvs') + case fst r of + (s, Seq path, Alt rmvs') -> if null path + then return (fromMaybe 0 $ lastscore abc, lastpv abc, []) + else return (s, path, rmvs') + +{-- +aspirWin :: Node m => Int -> Int -> Int -> Seq Move -> Alt Move -> Int -> m (Int, Seq Move, Alt Move) +aspirWin _ _ d lpv rmvs 0 = liftM fst $ runSearch (pvRootSearch alpha0 beta0 d lpv rmvs True) pvsInit +aspirWin a b d lpv rmvs t = do + r@(s, p, ms) <- liftM fst $ runSearch (pvRootSearch a b d lpv rmvs True) pvsInit + if s <= a + then aspirWin (a - incr) b d lpv rmvs (t-1) + else if s >= b + then aspirWin a (b + incr) d p ms (t-1) + else if nullSeq p + then aspirWin (a - incr) (b + incr) d lpv rmvs (t-1) + else return r + where incr = aspIncr!t +--} + +-- Root PV Search +pvRootSearch :: Node m => Int -> Int -> Int -> Seq Move -> Alt Move -> Bool + -> Search m (Int, Seq Move, Alt Move) +pvRootSearch a b d lastpath rmvs aspir = do + viztreeNew d + -- Root is pv node, cannot fail low, except when aspiration fails! + edges <- if null (unalt rmvs) + then genAndSort lastpath NoKiller d True + else if nullSeq lastpath + then return rmvs + else do + let !lm = firstMove lastpath + return $ Alt $ lm : delete lm (unalt rmvs) + -- lift $ informStr $ "Root moves: " ++ show edges + -- pvcont is the pv continuation from the last iteration + let !pvc = if nullSeq lastpath then lastpath else Seq $ tail $ unseq lastpath + !nsti = nst0 { cursc = pathFromScore "Alpha" a, pvcont = pvc } + nstf <- pvLoop (pvInnerRoot (pathFromScore "Beta" b) d) nsti edges + reportStats + let failedlow = (a, emptySeq, edges) -- just to permit aspiration to retry + let s' = pathScore (cursc nstf) + lift $ informStr $ "pvRootSearch: cursc = " ++ show (cursc nstf) ++ ", a = " ++ show a + if s' <= a -- failed low + then do + when (not aspir) $ lift $ informStr "Failed low at root!" + return failedlow + else do + -- lift $ mapM_ (\m -> informStr $ "Root move: " ++ show m) (pvsl nstf) + albest' <- gets (albest . ronly) + abrt <- gets abort + (s, p) <- if s' >= b || abrt + then return (s', unseq $ pathMoves (cursc nstf)) + else lift $ choose albest' + $ sortBy (comparing fstdesc) + $ map pvslToPair + $ filter pvGood $ pvsl nstf + when (d < depthForCM) $ informBest s d p + let (best':_) = p + allrmvs = if s' >= b then unalt edges else map pvslToMove (pvsl nstf) + xrmvs = Alt $ best' : delete best' allrmvs -- best on top + return (s, Seq p, xrmvs) + where fstdesc (a', _) = -a' + +pvslToPair :: Pvsl -> (Int, [Move]) +pvslToPair (Pvsl { pvPath = p }) = (score, pv) + where pv = unseq $ pathMoves p + de = pathDepth p + sc = pathScore p + score = scoreToExtern sc de + +pvslToMove :: Pvsl -> Move +pvslToMove (Pvsl { pvPath = Path { pathMoves = Seq (m:_)}}) = m +pvslToMove _ = undefined -- just for Wall + +-- The internal score is for weird for found mates (always mate) +-- Turn it to nicer score by considering path lenght to mate +scoreToExtern :: Int -> Int -> Int +scoreToExtern sc de + | nearmate sc = if sc > 0 then sc - de else sc + de + | otherwise = sc + +legalResult :: DoResult -> Bool +legalResult Illegal = False +legalResult _ = True + +-- This is the inner loop of the PV search of the root, executed at root once per possible move +-- See the parameter +-- Returns: ...flag if it was a beta cut and new status +pvInnerRoot :: Node m + => Path -- current beta + -> Int -- current search depth + -> NodeState -- node status + -> Move -- move to search + -> Search m (Bool, NodeState) +pvInnerRoot b d nst e = do + abrt <- timeToAbort + if abrt + then return (True, nst) + else do + old <- get + when (draft (ronly old) >= depthForCM) $ lift $ informCM e $ movno nst + pindent $ "-> " ++ show e + -- lift $ logmes $ "Search root move " ++ show e ++ " a = " ++ show a ++ " b = " ++ show b + -- do the move + exd <- {-# SCC "newNode" #-} lift $ doEdge e False + if legalResult exd + then do + nn <- newNode + viztreeDown nn e + modify $ \s -> s { absdp = absdp s + 1 } + s <- case exd of + Exten exd' -> pvInnerRootExten b d (special e) exd' nst + Final sco -> do + viztreeScore $ "Final: " ++ show sco + return $! pathFromScore "Final" (-sco) + -- undo the move + lift $ undoEdge + viztreeUp nn e (pathScore s) + modify $ \s' -> s' { absdp = absdp old, usedext = usedext old } + s' <- checkPath nst d "cpl 1" $ addToPath e s + pindent $ "<- " ++ show e ++ " (" ++ show s' ++ ")" + checkFailOrPVRoot (stats old) b d e s' nst + else return (False, nst) + +pvInnerRootExten :: Node m => Path -> Int -> Bool -> Int -> NodeState -> Search m Path +pvInnerRootExten b d spec !exd nst = {-# SCC "pvInnerRootExten" #-} do + pindent $ "depth = " ++ show d + old <- get + exd' <- reserveExtension (usedext old) exd + tact <- lift tactical + let !inPv = nxtnt nst == PVNode + !a = cursc nst + !pvs = forpv nst + !d1 = d + exd' - 1 -- this is the normal (unreduced) depth for the next search + d' <- reduceLmr d1 inPv False spec exd (movno nst) pvs + let !pvpath_ = pvcont nst + pindent $ "depth " ++ show d ++ " nt " ++ show (nxtnt nst) + ++ " exd' = " ++ show exd' + ++ " mvn " ++ show (movno nst) ++ " next depth " ++ show d' + ++ " forpv " ++ show (forpv nst) + -- We can have and try here as first move (in order of low to high cost): + -- 1: a continuation from a previous search (pvcont nst) (eventuell a previous IID) + -- 2: one move from hash + -- 3: a continuation from a new IID + -- 1 and 2 can be empty; then we will try 3 only in PV or Cut nodes, and only for higher d + -- But one can be empty only in non PV nodes, or when d=0, and this is too low, + -- so we dont bother to call check the other conditions for PV + pvpath' <- if nullSeq pvpath_ then {-# SCC "firstFromHashRoot" #-} bestMoveFromHash + else {-# SCC "firstFromContRoot" #-} return pvpath_ + -- when (nullSeq pvpath' && forpv nst) $ lift + -- $ logmes $ "pvpath is null: d=" ++ show d ++ ", nxtnt =" ++ show (nxtnt nst) + let nega = negatePath a + negb = negatePath b + if pvs -- search of principal variation + then {-# SCC "forpvSearchRoot" #-} do + viztreeABD (pathScore negb) (pathScore nega) d' + -- Why we don't do IID if we have no best continuation? + pvSearch nst negb nega d' pvpath' nulMoves >>= return . pnextlev + >>= checkPath nst d' "cpl 11" + else {-# SCC "nullWindowRoot" #-} do + let aGrain = nega -: scoreGrain + -- no futility pruning for root moves! + -- Only here we need IID, because previously, in PV, we had pvcont (from previous draft) + -- and only at draft 1 we have nothing, but then the depth is too low for IID + pvpath <- if useIID && nullSeq pvpath' + -- then {-# SCC "firstFromIIDRoot" #-} bestMoveFromIID nst aGrain nega d' nulMoves + then {-# SCC "firstFromIIDRoot" #-} bestMoveFromIID nst negb nega d' nulMoves + else {-# SCC "firstFromC&HRoot" #-} return pvpath' + -- Here we expect to fail low + viztreeABD (pathScore aGrain) (pathScore nega) d' + !s1 <- pvZeroW nst nega d' pvpath nulMoves + >>= return . pnextlev >>= checkPath nst d' "cpl 2" + abrt <- gets abort + if abrt || s1 <= a -- we failed low as expected + then return s1 + else {-# SCC "nullWinResRoot" #-} do + -- Here we didn't fail low and need re-search + -- Two re-searches must be considered: a: full depth, b: full window + pindent $ "Research! (" ++ show s1 ++ ")" + viztreeReSe + let pvc = if pathDepth s1 > 0 then pathMoves s1 else pvpath + if d' < d1 -- did we search with reduced depth? + then do -- yes: re-search with normal depth + viztreeABD (pathScore aGrain) (pathScore nega) d1 + !s2 <- {-# SCC "nullWinResRootDD" #-} pvZeroW nst nega d1 pvc nulMoves + >>= return . pnextlev >>= checkPath nst d1 "cpl 12" + abrt <- gets abort + if abrt || s2 <= a -- we failed low as expected + then return s2 + -- we must try full window + else do + viztreeReSe + viztreeABD (pathScore negb) (pathScore nega) d1 + let nst' = nst { nxtnt = PVNode, forpv = True } + pvc' = if pathDepth s2 > 0 then pathMoves s2 else pvc + pvSearch nst' negb nega d1 pvc' 0 + >>= return . pnextlev >>= checkPath nst d1 "cpl 12a" + else {-# SCC "nullWinResRootSD" #-} do + -- Depth was not reduced, so re-search full window + viztreeABD (pathScore negb) (pathScore nega) d1 + let nst' = nst { nxtnt = PVNode, forpv = True } + pvSearch nst' negb nega d1 pvc 0 + >>= return . pnextlev >>= checkPath nst d1 "cpl 13" + +checkFailOrPVRoot :: Node m => SStats -> Path -> Int -> Move -> Path + -> NodeState -> Search m (Bool, NodeState) +checkFailOrPVRoot xstats b d e s nst = {-# SCC "checkFailOrPVRoot" #-} do + abrt <- timeToAbort + if abrt + then return (True, nst) + else do + sst <- get + let !mn = movno nst + !a = cursc nst + -- !np = pathMoves s + !nodes0 = sNodes xstats + sRSuc xstats + !nodes1 = sNodes (stats sst) + sRSuc (stats sst) + !nodes' = nodes1 - nodes0 + pvg = Pvsl s nodes' True -- the good + pvb = Pvsl s nodes' False -- the bad + -- xpvslg = insertToPvs d pvg (pvsl nst) -- the good + -- xpvslb = insertToPvs d pvb (pvsl nst) -- the bad + de = max d $ pathDepth s + if d == 1 -- for draft 1 we search all root moves exact + then {-# SCC "allExactRoot" #-} do + let typ = 2 + when (de >= minToStore) $ lift $ {-# SCC "hashStore" #-} store de typ (pathScore s) e nodes' + let nst1 = if s > a -- we should probably even go with PVNode for all root moves here + -- then nst { cursc = s, nxtnt = nextNodeType (nxtnt nst), forpv = False } + then nst { nxtnt = nextNodeType (nxtnt nst) } + else nst + xpvslg <- insertToPvs d pvg (pvsl nst) -- the good + return (False, nst1 {movno = mn + 1, pvsl = xpvslg, pvcont = emptySeq}) + else if s <= a + then {-# SCC "scoreWorseAtRoot" #-} do -- failed low + -- when in a cut node and the move dissapointed - negative history + -- when (useNegHist && forpv nst && a == b - 1 && mn <= negHistMNo) -- Check this! + -- $ lift $ betaMove False d (absdp sst) e + if forpv nst + then return (True, nst { cursc = s }) -- i.e we failed low in aspiration + else do + kill1 <- newKiller d s nst + xpvslb <- insertToPvs d pvb (pvsl nst) -- the bad + -- should we set here cursc on combinePath s a if s == a, so that we have always some sequence? + let nst1 = nst { movno = mn + 1, pvsl = xpvslb, killer = kill1, pvcont = emptySeq } + return (False, nst1) + else if s >= b + then {-# SCC "scoreBetaCutRoot" #-} do + -- what when a root move fails high? We are in aspiration + let typ = 1 -- best move is e and is beta cut (score is lower limit) + when (de >= minToStore) $ lift $ {-# SCC "hashStore" #-} store de typ (pathScore b) e nodes' + lift $ betaMove True d (absdp sst) e + xpvslg <- insertToPvs d pvg (pvsl nst) -- the good + !csc <- checkPath nst d "cpl 3" $ if s > b then combinePath s b else bestPath s b + pindent $ "beta cut: " ++ show csc + let nst1 = nst { cursc = csc, pvsl = xpvslg, pvcont = emptySeq } + -- lift $ logmes $ "Root move " ++ show e ++ " failed high: " ++ show s + -- lift $ informStr $ "Cut (" ++ show b ++ "): " ++ show np + return (True, nst1) + else {-# SCC "scoreBetterAtRoot" #-} do -- means: > a && < b + let sc = pathScore s + pa = unseq $ pathMoves s + -- le = pathDepth s + informBest (scoreToExtern sc de) (draft $ ronly sst) pa + let typ = 2 -- best move so far (score is exact) + when (de >= minToStore) $ lift $ {-# SCC "hashStore" #-} store de typ sc e nodes' + xpvslg <- insertToPvs d pvg (pvsl nst) -- the good + let nst1 = nst { cursc = s, nxtnt = nextNodeType (nxtnt nst), + forpv = False, movno = mn + 1, + pvsl = xpvslg, pvcont = emptySeq } + -- lift $ logmes $ "Root move " ++ show e ++ " improves alpha: " ++ show s + -- lift $ informStr $ "Better (" ++ show s ++ "):" ++ show np + return (False, nst1) + +insertToPvs :: Node m => Int -> Pvsl -> [Pvsl] -> Search m [Pvsl] +insertToPvs _ p [] = return [p] +insertToPvs d p ps@(q:qs) + | d == 1 && (betters || equals) = return $ p : ps + | pmate && not qmate = return $ p : ps + | not pmate && qmate = do ir <- insertToPvs d p qs + return $ q : ir + | pmate && betters = return $ p : ps + | bettern || equaln && betters = return $ p : ps + | otherwise = do ir <- insertToPvs d p qs + return $ q : ir + where betters = pvPath p > pvPath q + equals = pvPath p == pvPath q + equaln = pvNodes p == pvNodes q + bettern = pvNodes p > pvNodes q + pmate = pnearmate $ pvPath p + qmate = pnearmate $ pvPath q + +{-# INLINE mustQSearch #-} +mustQSearch :: Node m => Int -> Int -> Search m (Int, Int) +mustQSearch !a !b = do + nodes0 <- gets (sNodes . stats) + v <- pvQSearch a b 0 + nodes1 <- gets (sNodes . stats) + let deltan = nodes1 - nodes0 + return (v, deltan) + +-- PV Search +pvSearch :: Node m => NodeState -> Path -> Path -> Int -> Seq Move -> Int + -> Search m Path +pvSearch _ !a !b !d _ _ | d <= 0 = do + (v, ns) <- if minToRetr == 0 + then do + (hdeep, tp, hscore, _, nodes') + <- {-# SCC "hashRetrieveScore" #-} reTrieve >> lift retrieve + let sca = pathScore a + if hdeep >= 0 && (tp == 2 || tp == 1 && hscore > sca || tp == 0 && hscore <= sca) + then {-# SCC "hashRetrieveScoreOk" #-} reSucc nodes' >> return (hscore, 0) + else mustQSearch (pathScore a) (pathScore b) + else mustQSearch (pathScore a) (pathScore b) + when (minToStore == 0 && ns > 0) + $ lift $ {-# SCC "hashStore" #-} store 0 2 v (Move 0) ns + let !esc = pathFromScore ("pvQSearch 1:" ++ show v) v + pindent $ "<> " ++ show esc + return esc +pvSearch nst !a !b !d lastpath lastnull = do + pindent $ "=> " ++ show a ++ ", " ++ show b + nmhigh <- if not nulActivate || lastnull < 1 || nxtnt nst == PVNode + then return False + else nullEdgeFailsHigh nst b d lastnull + abrt <- gets abort + if abrt || nmhigh + then do + let !s = onlyScore b + pindent $ "<= " ++ show s + viztreeScore $ "nmhigh: " ++ show (pathScore s) + return s + else do + -- edges <- genAndSort lastpath (killer nst) d (forpv nst) + edges <- genAndSort lastpath (killer nst) d (crtnt nst /= AllNode) + if noMove edges + then do + v <- lift staticVal + viztreeScore $ "noMove: " ++ show v + let !s = pathFromScore ("static: " ++ show v) v + pindent $ "<= " ++ show s + return s + else do + nodes0 <- gets (sNodes . stats) + -- futility pruning? + prune <- if not futilActive || nxtnt nst == PVNode + then return False + else isPruneFutil d a + -- Loop thru the moves + let !pvpath = if nullSeq lastpath then emptySeq else Seq $ tail $ unseq lastpath + !nsti = nst0 { crtnt = nxtnt nst, nxtnt = deepNodeType (nxtnt nst), + cursc = a, pvcont = pvpath } + nstf <- pvSLoop b d prune nsti edges + let s = cursc nstf + pindent $ "<= " ++ show s + -- After pvSLoop ... we expect always that s >= a - this must be checked if it is so + -- then it makes sense below to take bestPath when failed low (s == a) + abrt' <- gets abort + if abrt' || s > a + then checkPath nst d "cpl 6b" s + else do + -- here we failed low + let de = max d $ pathDepth s + es = unalt edges + -- when (de >= minToStore && not (null es)) $ do -- cannot be null here! + when (de >= minToStore) $ do + nodes1 <- gets (sNodes . stats) + let typ = 0 + !deltan = nodes1 - nodes0 + -- store as upper score, and as move, the first one (generated) + lift $ {-# SCC "hashStore" #-} + store de typ (pathScore a) (head es) deltan -- should be d or de? + if movno nstf > 1 + then checkPath nst d "cpl 6a" $! bestPath s a + else do + chk <- lift tactical + let s' = if chk then matedPath else staleMate + return $! trimaxPath a b s' + +-- PV Zero Window +pvZeroW :: Node m => NodeState -> Path -> Int -> Seq Move -> Int + -> Search m Path +pvZeroW _ !b !d _ _ | d <= 0 = do + (v, ns) <- if minToRetr == 0 + then do + (hdeep, tp, hscore, _, nodes') + <- {-# SCC "hashRetrieveScore" #-} reTrieve >> lift retrieve + let scb = pathScore b + if hdeep >= 0 && (tp == 2 || tp == 1 && hscore >= scb || tp == 0 && hscore < scb) + then {-# SCC "hashRetrieveScoreOk" #-} reSucc nodes' >> return (hscore, 0) + else mustQSearch (pathScore bGrain) (pathScore b) + else mustQSearch (pathScore bGrain) (pathScore b) + when (minToStore == 0 && ns > 0) + $ lift $ {-# SCC "hashStore" #-} store 0 2 v (Move 0) ns + let !esc = pathFromScore ("pvQSearch 21:" ++ show v) v + pindent $ "<> " ++ show esc + return esc + where bGrain = b -: scoreGrain +pvZeroW nst b !d lastpath lastnull = do + pindent $ ":> " ++ show b + nmhigh <- if not nulActivate || lastnull < 1 -- || nxtnt nst == PVNode + then return False + else nullEdgeFailsHigh nst b d lastnull + abrt <- gets abort + if abrt || nmhigh + then do + let !s = onlyScore b + pindent $ "<= " ++ show s + viztreeScore $ "nmhigh: " ++ show (pathScore s) + return s + else do + edges <- genAndSort lastpath (killer nst) d (crtnt nst /= AllNode) + if noMove edges + then do + v <- lift staticVal + viztreeScore $ "noMove: " ++ show v + let !s = pathFromScore ("static: " ++ show v) v + pindent $ "<= " ++ show s + return s + else do + nodes0 <- gets (sNodes . stats) + -- futility pruning? + prune <- if not futilActive -- || nxtnt nst == PVNode -- can't be PVNode + then return False + else isPruneFutil d bGrain -- was a + -- Loop thru the moves + let !pvpath = if nullSeq lastpath then emptySeq else Seq $ tail $ unseq lastpath + !nsti = nst0 { crtnt = nxtnt nst, nxtnt = deepNodeType (nxtnt nst), + cursc = bGrain, pvcont = pvpath } + nstf <- pvZLoop b d prune nsti edges + let s = cursc nstf + -- Here we expect bGrain <= s < b -- this must be checked + pindent $ "<: " ++ show s + let de = max d $ pathDepth s + es = unalt edges + when (de >= minToStore && s < b) $ do + nodes1 <- gets (sNodes . stats) + let typ = 0 + !deltan = nodes1 - nodes0 + -- store as upper score, and as move the first one (generated) + lift $ {-# SCC "hashStore" #-} + store de typ (pathScore b) (head es) deltan + if s > bGrain || movno nstf > 1 + then return s + else do + chk <- lift tactical + let s' = if chk then matedPath else staleMate + return $! trimaxPath bGrain b s' + where bGrain = b -: scoreGrain + +nullEdgeFailsHigh :: Node m => NodeState -> Path -> Int -> Int -> Search m Bool +nullEdgeFailsHigh nst b d lastnull + | d1 <= 0 = return False + | otherwise = do + tact <- lift tactical + if tact + then return False + else do + lift nullEdge -- do null move + nn <- newNode + viztreeDown0 nn + viztreeABD (pathScore negnmb) (pathScore negnma) d1 + val <- liftM pnextlev $ pvSearch nst negnmb negnma d1 emptySeq lastnull1 + lift undoEdge -- undo null move + viztreeUp0 nn (pathScore val) + return $! val >= nmb + where d1 = d - (1 + nulRedux) + nmb = if nulSubAct then b -: (nulSubmrg * scoreGrain) else b + nma = nmb -: (nulMargin * scoreGrain) + negnmb = negatePath nmb + negnma = negatePath nma + lastnull1 = lastnull - 1 + +pvSLoop :: Node m => Path -> Int -> Bool -> NodeState -> Alt Move -> Search m NodeState +pvSLoop b d p s es = go s es + where go !s (Alt []) = return s + go !s (Alt (e:es)) = do + (!cut, !s') <- pvInnerLoop b d p s e + if cut then return s' + else go s' $ Alt es + +pvZLoop :: Node m => Path -> Int -> Bool -> NodeState -> Alt Move -> Search m NodeState +pvZLoop b d p s es = go s es + where go !s (Alt []) = return s + go !s (Alt (e:es)) = do + (!cut, !s') <- pvInnerLoopZ b d p s e + if cut then return s' + else go s' $ Alt es + +-- This is the inner loop of the PV search, executed at every level (except root) once per possible move +-- See the parameter +-- Returns: flag if it was a beta cut and new status +pvInnerLoop :: Node m + => Path -- current beta + -> Int -- current search depth + -> Bool -- prune? + -> NodeState -- node status + -> Move -- move to search + -> Search m (Bool, NodeState) +pvInnerLoop b d prune nst e = do + abrt <- timeToAbort + if abrt + then return (True, nst) + else do + old <- get + pindent $ "-> " ++ show e + exd <- {-# SCC "newNode" #-} lift $ doEdge e False -- do the move + if legalResult exd + then do + nn <- newNode + viztreeDown nn e + modify $ \s -> s { absdp = absdp s + 1 } + s <- case exd of + Exten exd' -> do + let speci = special e + if prune && exd' == 0 && not speci -- don't prune special or extended + then return $! onlyScore $! cursc nst -- prune, return a + else pvInnerLoopExten b d speci exd' nst + Final sco -> do + viztreeScore $ "Final: " ++ show sco + return $! pathFromScore "Final" (-sco) + lift undoEdge -- undo the move + viztreeUp nn e (pathScore s) + modify $ \s' -> s' { absdp = absdp old, usedext = usedext old } + s' <- checkPath nst d "cpl 8" $ addToPath e s + pindent $ "<- " ++ show e ++ " (" ++ show s' ++ ")" + checkFailOrPVLoop (stats old) b d e s' nst + else return (False, nst) + +-- This part for the zero window search +pvInnerLoopZ :: Node m + => Path -- current beta + -> Int -- current search depth + -> Bool -- prune? + -> NodeState -- node status + -> Move -- move to search + -> Search m (Bool, NodeState) +pvInnerLoopZ b d prune nst e = do + abrt <- timeToAbort + if abrt + then return (True, nst) + else do + old <- get + pindent $ "-> " ++ show e + exd <- {-# SCC "newNode" #-} lift $ doEdge e False -- do the move + if legalResult exd + then do + nn <- newNode + viztreeDown nn e + modify $ \s -> s { absdp = absdp s + 1 } + s <- case exd of + Exten exd' -> do + let speci = special e + if prune && exd' == 0 && not speci -- don't prune special or extended + then return $! onlyScore $! cursc nst -- prune, return a + else pvInnerLoopExtenZ b d speci exd' nst + Final sco -> do + viztreeScore $ "Final: " ++ show sco + return $! pathFromScore "Final" (-sco) + lift undoEdge -- undo the move + viztreeUp nn e (pathScore s) + modify $ \s' -> s' { absdp = absdp old, usedext = usedext old } + s' <- checkPath nst d "cpl 8" $ addToPath e s + pindent $ "<- " ++ show e ++ " (" ++ show s' ++ ")" + checkFailOrPVLoopZ (stats old) b d e s' nst + else return (False, nst) + +reserveExtension :: Node m => Int -> Int -> Search m Int +reserveExtension !uex !exd + | uex >= maxDepthExt || exd == 0 = return 0 + | otherwise = do + modify $ \s -> s { usedext = usedext s + exd } + return exd + +pvInnerLoopExten :: Node m => Path -> Int -> Bool -> Int -> NodeState + -> Search m Path +pvInnerLoopExten b d spec !exd nst = do + old <- get + exd' <- reserveExtension (usedext old) exd + -- late move reduction + let !inPv = nxtnt nst == PVNode + pvs = forpv nst + a = cursc nst + !d1 = d + exd' - 1 -- this is the normal (unreduced) depth for next search + d' <- reduceLmr d1 inPv (pnearmate a) spec exd (movno nst) pvs + pindent $ "depth " ++ show d ++ " nt " ++ show (nxtnt nst) + ++ " exd' = " ++ show exd' + ++ " mvn " ++ show (movno nst) ++ " next depth " ++ show d' + ++ " forpv " ++ show (forpv nst) + (hdeep, tp, hscore, e', nodes') + <- if (useTTinPv || not inPv) && d' >= minToRetr + then {-# SCC "hashRetrieveScore" #-} reTrieve >> lift retrieve + else return (-1, 0, 0, undefined, 0) + -- TT score is for the opponent (we just made our move), + -- so we have to invert the score and the inequality (tp: 2->2, 1->0, 0->1) + let asco = pathScore a + !hsco = - hscore + !tp' = if tp == 2 then 2 else 1-tp + -- This logic could be done depending on node type? + if hdeep >= d' && (tp' == 2 || tp' == 1 && hsco > asco || tp' == 0 && hsco <= asco) + then {-# SCC "hashRetrieveScoreOk" #-} do + let ttpath = Path { pathScore = hsco, pathDepth = hdeep, pathMoves = Seq [e'], pathOrig = "TT" } + reSucc nodes' >> return ttpath + else do + let pvpath_ = pvcont nst + nega = negatePath a + negb = negatePath b + if pvs + then do + viztreeABD (pathScore negb) (pathScore nega) d' + pvpath <- if nullSeq pvpath_ then bestMoveFromHash else return pvpath_ + -- Why we don't do here IID when no move from hash? + pvSearch nst negb nega d' pvpath nulMoves >>= return . pnextlev >>= checkPath nst d' "cpl 14" + else do + -- let pvpath = if null lastpath + -- then if hdeep > 0 && tp > 0 then [e'] else [] + -- else lastpath + -- let pvpath' = if hdeep > 0 && tp > 0 then Seq [e'] else pvpath_ + -- Use a best move from hash if available + let pvpath' = if nullSeq pvpath_ && hdeep > 0 && tp' > 0 then Seq [e'] else pvpath_ + aGrain = nega -: scoreGrain + --1-- let !pvpath = if hdeep > 0 && tp > 0 then Seq [] else (pvcont nst) + pvpath <- if useIID && nullSeq pvpath' + -- then bestMoveFromIID nst aGrain nega d' nulMoves + then bestMoveFromIID nst negb nega d' nulMoves -- which is here better? + else return pvpath' + -- Here we expect to fail low + viztreeABD (pathScore aGrain) (pathScore nega) d' + !s1 <- pvZeroW nst nega d' pvpath nulMoves + >>= return . pnextlev >>= checkPath nst d' "cpl 9" + abrt <- gets abort + if abrt || s1 <= a + then return s1 -- failed low (as expected) or aborted + else do + -- we didn't fail low and need re-search, 2 kinds: full depth, full window + pindent $ "Research! (" ++ show s1 ++ ")" + viztreeReSe + let pvc = if pathDepth s1 > 0 then pathMoves s1 else pvpath + if d' < d1 -- did we search with reduced depth? + then do -- yes: re-search with with normal depth + viztreeABD (pathScore aGrain) (pathScore nega) d1 + !s2 <- pvZeroW nst nega d1 pvc nulMoves + >>= return . pnextlev >>= checkPath nst d1 "cpl 9a" + abrt <- gets abort + if abrt || s2 <= a + then return s2 -- failed low (as expected) or aborted + else do + viztreeReSe + viztreeABD (pathScore negb) (pathScore nega) d1 + let nst' = if crtnt nst == PVNode + then nst { nxtnt = PVNode, forpv = True } + else nst { forpv = True } + pvc' = if pathDepth s2 > 0 then pathMoves s2 else pvc + pvSearch nst' negb nega d1 pvc' 0 + >>= return . pnextlev >>= checkPath nst d1 "cpl 15" + else do + -- was not reduced, try full window + viztreeABD (pathScore negb) (pathScore nega) d1 + let nst' = if crtnt nst == PVNode + then nst { nxtnt = PVNode, forpv = True } + else nst { forpv = True } + pvSearch nst' negb nega d1 pvc 0 + >>= return . pnextlev >>= checkPath nst d1 "cpl 16" + +-- For zero window +pvInnerLoopExtenZ :: Node m => Path -> Int -> Bool -> Int -> NodeState + -> Search m Path +pvInnerLoopExtenZ b d spec !exd nst = do + old <- get + exd' <- reserveExtension (usedext old) exd + -- late move reduction + let !d1 = d + exd' - 1 -- this is the normal (unreduced) depth for next search + d' <- reduceLmr d1 False (pnearmate b) spec exd (movno nst) False + pindent $ "depth " ++ show d ++ " nt " ++ show (nxtnt nst) + ++ " exd' = " ++ show exd' + ++ " mvn " ++ show (movno nst) ++ " next depth " ++ show d' + ++ " forpv " ++ show False + (hdeep, tp, hscore, e', nodes') + <- if d' >= minToRetr + then {-# SCC "hashRetrieveScore" #-} reTrieve >> lift retrieve + else return (-1, 0, 0, undefined, 0) + -- Score and inequality must be inverted + let bsco = pathScore b + !hsco = - hscore + !tp' = if tp == 2 then 2 else 1-tp + if hdeep >= d' && (tp' == 2 || tp' == 1 && hsco >= bsco || tp' == 0 && hsco < bsco) + then {-# SCC "hashRetrieveScoreOk" #-} do + let ttpath = Path { pathScore = hsco, pathDepth = hdeep, pathMoves = Seq [e'], pathOrig = "TT" } + reSucc nodes' >> return ttpath -- !!! + else do + -- Very probable we don't have pvpath, so don't bother - why not? + let pvpath_ = pvcont nst + let pvpath' = if nullSeq pvpath_ && hdeep > 0 && tp' > 0 then Seq [e'] else pvpath_ + --1-- let !pvpath = if hdeep > 0 && tp > 0 then Seq [] else (pvcont nst) + -- But for sure no IID! + -- pvpath <- if useIID && nullSeq pvpath' + -- -- then bestMoveFromIID nst (-a-pathGrain) (-a) d' nulMoves + -- then bestMoveFromIID nst (-b) (-a) d' nulMoves + -- else return pvpath' + -- Here we expect to fail low + viztreeABD (pathScore negb) (pathScore onemB) d' + pvZeroW nst onemB d' pvpath' nulMoves + >>= return . pnextlev >>= checkPath nst d' "cpl 9" + where onemB = negatePath $ b -: scoreGrain + negb = negatePath b + +checkFailOrPVLoop :: Node m => SStats -> Path -> Int -> Move -> Path + -> NodeState -> Search m (Bool, NodeState) +checkFailOrPVLoop xstats b d e s nst = do + sst <- get + let mn = movno nst + if s <= cursc nst + then do + -- when in a cut node and the move dissapointed - negative history + !kill1 <- newKiller d s nst + let !nst1 = nst { movno = mn+1, killer = kill1, pvcont = emptySeq } + return (False, nst1) + else do + let nodes0 = sNodes xstats + nodes1 = sNodes $ stats sst + nodes' = nodes1 - nodes0 + !de = max d $ pathDepth s + if s >= b + then do + let typ = 1 -- best move is e and is beta cut (score is lower limit) + when (de >= minToStore) $ + lift $ {-# SCC "hashStore" #-} store de typ (pathScore b) e nodes' + lift $ betaMove True d (absdp sst) e -- anounce a beta move (for example, update history) + -- when debug $ logmes $ "<-- pvInner: beta cut: " ++ show s ++ ", return " ++ show b + !csc <- checkPath nst d "cpl 10" $ if s > b then combinePath s b else bestPath s b + pindent $ "beta cut: " ++ show csc + let !nst1 = nst { cursc = csc, pvcont = emptySeq } + -- lift $ informStr $ "Cut (" ++ show b ++ "): " ++ show np + return (True, nst1) + else do -- means: > a && < b + let typ = 2 -- score is exact + when (nxtnt nst == PVNode || de >= minToStore) $ -- why this || with node type? + lift $ {-# SCC "hashStore" #-} store de typ (pathScore s) e nodes' + -- when debug $ logmes $ "<-- pvInner - new a: " ++ show s + let !nst1 = nst { cursc = s, nxtnt = nextNodeType (nxtnt nst), + forpv = False, movno = mn+1, pvcont = emptySeq } + -- lift $ informStr $ "Better (" ++ show s ++ "): " ++ show np + return (False, nst1) + +-- For zero window +checkFailOrPVLoopZ :: Node m => SStats -> Path -> Int -> Move -> Path + -> NodeState -> Search m (Bool, NodeState) +checkFailOrPVLoopZ xstats b d e s nst = do + sst <- get + let mn = movno nst + -- a = cursc nst + if s <= cursc nst -- see below by "else" + then do + -- when in a cut node and the move dissapointed - negative history - ??? + when (useNegHist && mn <= negHistMNo) + $ lift $ betaMove False d (absdp sst) e + !kill1 <- newKiller d s nst + let !nst1 = nst { movno = mn+1, killer = kill1, pvcont = emptySeq } + return (False, nst1) + else do -- here is s >= b: why cursc nst and now b??? + let nodes0 = sNodes xstats + nodes1 = sNodes $ stats sst + nodes' = nodes1 - nodes0 + !de = max d $ pathDepth s + let typ = 1 -- best move is e and is beta cut (score is lower limit) + when (de >= minToStore) $ lift $ {-# SCC "hashStore" #-} store de typ (pathScore b) e nodes' + lift $ betaMove True d (absdp sst) e -- anounce a beta move (for example, update history) + -- when debug $ logmes $ "<-- pvInner: beta cut: " ++ show s ++ ", return " ++ show b + !csc <- checkPath nst d "cpl 10" $ if s > b then combinePath s b else bestPath s b + pindent $ "beta cut: " ++ show csc + let !nst1 = nst { cursc = csc, pvcont = emptySeq } + -- lift $ informStr $ "Cut (" ++ show b ++ "): " ++ show np + return (True, nst1) + +newKiller :: Node m => Int -> Path -> NodeState -> Search m Killer +newKiller d s nst + | d >= 2, (mm:km:_) <- unseq $ pathMoves s = do + iskm <- lift $ killCandEdge mm km + if iskm then return $! pushKiller km (- pathScore s) (killer nst) + else return $ killer nst + | otherwise = return $ killer nst + +-- We don't sort the moves here, they have to come sorted from genEdges +-- But we consider the best moves first (best from previous iteration, killers) +genAndSort :: Node m => Seq Move -> Killer -> Int -> Bool -> Search m (Alt Move) +genAndSort lastpath kill d pv = do + adp <- gets absdp + kl <- lift $ filterM legalEdge $ killerToList kill + esp <- lift $ genEdges d adp pv' + let es = bestFirst (unseq lastpath) kl esp + return $ Alt es + where pv' = pv || not (nullSeq lastpath) -- why this? We would sort most of the time... + +-- Late Move Reduction +-- This part (including lmrIndex) seems well optimized +{-# INLINE reduceLmr #-} +reduceLmr :: Node m => Int -> Bool -> Bool -> Bool -> Int -> Int -> Bool -> Search m Int +reduceLmr d inPv nearmatea spec exd w pvs + = if not lmrActive || d < lmrMinDRed || inPv || spec || exd > 0 || nearmatea + then return d + else do + !tact <- lift tactical + let !rd = reduceDepth d w pvs + return $! if tact then d else rd + where lmrMinDRed = 2 :: Int -- minimum reduced depth + +reduceDepth :: Int -> Int -> Bool -> Int +reduceDepth !d !w !pvs = m0n + where nd = d - k + !m0n = max 0 nd + k = if pvs then lmrReducePv `unsafeAt` lmrIndex d w + else lmrReduceArr `unsafeAt` lmrIndex d w + +-- Here we know the index is correct, but unsafeIndex (from Data.Ix) +-- is unfortunately not exported... +-- The trick: define an UnsafeIx class to calculate direct unsafeIndex +lmrIndex :: Int -> Int -> Int +lmrIndex d w = unsafeIndex ((1, 1), (lmrMaxDepth, lmrMaxWidth)) (d1, w1) + where d1 = min lmrMaxDepth $ max 1 d + w1 = min lmrMaxWidth $ max 1 w + +-- The UnsafeIx inspired from GHC.Arr (class Ix) +class Ord a => UnsafeIx a where + unsafeIndex :: (a, a) -> a -> Int + unsafeRangeSize :: (a, a) -> Int + unsafeRangeSize b@(_, h) = unsafeIndex b h + 1 + +instance UnsafeIx Int where + {-# INLINE unsafeIndex #-} + unsafeIndex (m, _) i = i - m + +instance (UnsafeIx a, UnsafeIx b) => UnsafeIx (a, b) where -- as derived + {-# SPECIALISE instance UnsafeIx (Int,Int) #-} + {-# INLINE unsafeIndex #-} + unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 + +-- This is a kind of monadic fold optimized for (beta) cut +-- {-# INLINE pvLoop #-} +pvLoop :: Monad m => (s -> e -> m (Bool, s)) -> s -> Alt e -> m s +pvLoop _ s (Alt []) = return s +pvLoop f s (Alt (e:es)) = do + (cut, s') <- f s e + if cut then return s' + else pvLoop f s' $ Alt es + +isPruneFutil :: Node m => Int -> Path -> Search m Bool +isPruneFutil d a + | d <= 0 || d > maxFutilDepth || nearmate (pathScore a) = return False + | otherwise = do + tact <- lift tactical + if tact then return False else do + -- let !margin = futilMargins ! d + v <- lift staticVal -- E1 + -- v <- lift materVal -- can we do here direct static evaluation? + -- v <- pvQSearch a' b' 0 -- E2 + let margin = futilMargins d + a' = pathScore a + if v + margin <= a' + then return True + else return False + +{-# INLINE checkPath #-} +-- checkPath _ _ _ s = return s +checkPath :: Node m => NodeState -> Int -> String -> Path -> Search m Path +checkPath nst d mes s = do + when (nxtnt nst == PVNode) $ do + iss <- gets short + when (not iss) $ do + abrt <- gets abort + when (not abrt && length (unseq $ pathMoves s) < d) $ do + lift $ informStr $ "Short - " ++ mes ++ " : d = " ++ show d + ++ ", path = " ++ show s + modify $ \s' -> s' { short = True } + return s + +trimaxPath :: Path -> Path -> Path -> Path +trimaxPath a b x = if x < a then a else if x > b then b else x + +trimax :: Int -> Int -> Int -> Int +trimax a b x = if x < a then a else if x > b then b else x + +-- PV Quiescent Search +pvQSearch :: Node m => Int -> Int -> Int -> Search m Int +pvQSearch !a !b c = do -- to avoid endless loops + -- qindent $ "=> " ++ show a ++ ", " ++ show b + !stp <- lift staticVal -- until we can recognize repetition + viztreeScore $ "Static: " ++ show stp + tact <- lift tactical + if tact + then do + (es1, es2) <- lift $ genEdges 0 0 False + let edges = Alt $ es1 ++ es2 + if noMove edges + -- then qindent ("<= " ++ show stp) >> return stp + then return $! trimax a b stp + else if c >= qsMaxChess + -- then qindent ("<= -1") >> return inEndlessCheck + then do + viztreeScore $ "endless check: " ++ show inEndlessCheck + return $! trimax a b inEndlessCheck + else do + -- for check extensions in case of very few moves (1 or 2): + -- if 1 move: search even deeper + -- if 2 moves: same depth + -- if 3 or more: no extension + let !esc = lenmax3 $ unalt edges + !nc = c + esc - 2 + !a' = if stp > a then stp else a + !s <- pvQLoop b nc a' edges + -- qindent $ "<= " ++ show s + return s + else if qsBetaCut && stp >= b + -- then qindent ("<= " ++ show b) >> return b + then return b + else do + let delta = a - qsDelta + if qsDeltaCut && delta < a && stp < delta + -- then qindent ("<= " ++ show a) >> return a + then return a + else do + edges <- liftM Alt $ lift genTactEdges + if noMove edges + -- then qindent ("<= " ++ show stp) >> return stp + then return $! trimax a b stp + else do + let !a' = if stp > a then stp else a + !s <- pvQLoop b c a' edges + -- qindent $ "<= " ++ show s + return s + where lenmax3 as = lenmax3' 0 as + lenmax3' !n _ | n == 3 = 3 + lenmax3' !n [] = n + lenmax3' !n (_:as) = lenmax3' (n+1) as + +pvQLoop :: Node m => Int -> Int -> Int -> Alt Move -> Search m Int +pvQLoop b c s es = go s es + where go !s (Alt []) = return s + go !s (Alt (e:es)) = do + (!cut, !s') <- pvQInnerLoop b c s e + if cut then return s' + else go s' $ Alt es + +pvQInnerLoop :: Node m => Int -> Int -> Int -> Move -> Search m (Bool, Int) +pvQInnerLoop !b c !a e = do + abrt <- timeToAbort + if abrt + then return (True, b) -- it doesn't matter which score we return + else do + -- here: delta pruning: captured piece + 200 > a? then go on, else return + -- qindent $ "-> " ++ show e + r <- {-# SCC "newNodeQS" #-} lift $ doEdge e True + if legalResult r + then do + nn <- newNodeQS + viztreeDown nn e + !sc <- case r of + Final sc -> do + viztreeScore $ "Final: " ++ show sc + return (-sc) + _ -> do + modify $ \s -> s { absdp = absdp s + 1 } + !s <- pvQSearch (-b) (-a) c + modify $ \s -> s { absdp = absdp s - 1 } -- don't care about usedext here + return (-s) + lift $ undoEdge + viztreeUp nn e sc + -- qindent $ "<- " ++ show e ++ " (" ++ show s ++ ")" + if sc >= b + then return (True, b) + else do + !abrt' <- gets abort + if sc > a + then return (abrt', sc) + else return (abrt', a) + else return (False, a) + +bestMoveFromHash :: Node m => Search m (Seq Move) +bestMoveFromHash = do + reTrieve + (hdeep, tp, _, e, _) <- {-# SCC "hashRetrieveMove" #-} lift retrieve + when (hdeep > 0) $ reSucc 1 -- here we save just move generation + return $! if hdeep > 0 && tp > 0 then {-# SCC "hashRetrieveMoveOk" #-} Seq [e] else emptySeq + -- return $! Seq [ e | hdeep > 0 && tp > 0 ] + --3-- return $! Seq [] + +{-# INLINE bestMoveFromIID #-} +bestMoveFromIID :: Node m => NodeState -> Path -> Path -> Int -> Int -> Search m (Seq Move) +bestMoveFromIID nst a b d lastnull + | nt == PVNode && d >= minIIDPV || + nt == CutNode && d >= minIIDCut + = {-# SCC "iidExecutedYes" #-} pathMoves `liftM` pvSearch nst a b d' emptySeq lastnull + | otherwise = {-# SCC "iidExecutedNo" #-} return emptySeq + where d' = min maxIIDDepth (iidNewDepth d) + nt = nxtnt nst + +{-# INLINE timeToAbort #-} +timeToAbort :: Node m => Search m Bool +timeToAbort = do + s <- get + let ro = ronly s + if draft ro > 1 && timeli ro + then if timeNodes .&. (sNodes $ stats s) /= 0 + then return False + else do + abrt <- lift $ timeout $ abmili ro + if not abrt + then return False + else do + lift $ informStr "Albeta: search abort!" + put s { abort = True } + return True + else return False + where timeNodes = 4 * 1024 - 1 -- check time every so many nodes + +{-# INLINE reportStats #-} +reportStats :: Node m => Search m () +reportStats = do + s <- get + let !xst = stats s + lift $ logmes $ "Search statistics after draft " ++ show (draft $ ronly s) ++ ":" + lift $ logmes $ "Nodes: " ++ show (sNodes xst) ++ ", in QS: " ++ show (sNodesQS xst) + ++ ", retrieve: " ++ show (sRetr xst) ++ ", succes: " ++ show (sRSuc xst) + +-- Functions to keep statistics +modStat :: Node m => (SStats -> SStats) -> Search m () +modStat f = modify $ \s -> case f (stats s) of st -> s { stats = st } + +modRetStat :: Node m => (SStats -> SStats) -> (SStats -> Int) -> Search m Int +modRetStat f g = do + s <- get + let ss = f $ stats s + put s { stats = ss } + return $! g ss + +incNodes, incNodesQS :: SStats -> SStats +incNodes s = case sNodes s + 1 of n1 -> s { sNodes = n1 } +incNodesQS s = case sNodes s + 1 of + n1 -> case sNodesQS s + 1 of n2 -> s { sNodes = n1, sNodesQS = n2 } + +incReTrieve :: SStats -> SStats +incReTrieve s = case sRetr s + 1 of n1 -> s { sRetr = n1 } + +addReSucc :: Int -> SStats -> SStats +addReSucc n s = case sRSuc s + n of n1 -> s { sRSuc = n1 } + +newNode :: Node m => Search m Int +newNode = modRetStat incNodes sNodes + +newNodeQS :: Node m => Search m Int +newNodeQS = modRetStat incNodesQS sNodes + +reTrieve :: Node m => Search m () +reTrieve = modStat incReTrieve + +reSucc :: Node m => Int -> Search m () +reSucc n = modStat (addReSucc n) + +indentActive :: Node m => String -> Search m () +indentActive s = do + ad <- gets absdp + lift $ informStr $ take ad (repeat ' ') ++ s + +indentPassive :: Node m => String -> Search m () +indentPassive _ = return () + +pindent, qindent :: Node m => String -> Search m () +pindent = indentPassive +qindent = indentPassive + +viztreeDown :: Node m => Int -> Move -> Search m () +viztreeDown n e = when viztree $ lift $ logmes $ "***DOWN " ++ show n ++ " " ++ show e + +viztreeDown0 :: Node m => Int -> Search m () +viztreeDown0 n = when viztree $ lift $ logmes $ "***DOWN " ++ show n ++ " null" + +viztreeUp :: Node m => Int -> Move -> Int -> Search m () +viztreeUp n e s = when viztree $ lift $ logmes $ "***UP " ++ show n ++ " " ++ show e ++ " " ++ show s + +viztreeUp0 :: Node m => Int -> Int -> Search m () +viztreeUp0 n s = when viztree $ lift $ logmes $ "***UP " ++ show n ++ " null " ++ show s + +viztreeNew :: Node m => Int -> Search m () +viztreeNew d = when viztree $ lift $ logmes $ "***NEW " ++ show d + +viztreeABD :: Node m => Int -> Int -> Int -> Search m () +viztreeABD a b d = when viztree $ lift $ logmes $ "***ABD " ++ show a ++ " " ++ show b ++ " " ++ show d + +viztreeReSe :: Node m => Search m () +viztreeReSe = when viztree $ lift $ logmes "***RESE" + +viztreeScore :: Node m => String -> Search m () +viztreeScore s = when viztree $ lift $ logmes $ "***SCO " ++ s + +bestFirst :: Eq e => [e] -> [e] -> ([e], [e]) -> [e] +bestFirst path kl (es1, es2) + | null path = es1 ++ kl ++ delall es2 kl + | otherwise = e : delete e es1 ++ kl ++ delall es2 (e : kl) + where delall = foldr delete + (e:_) = path + +pushKiller :: Move -> Int -> Killer -> Killer +pushKiller !e s NoKiller = OneKiller e s +pushKiller !e s ok@(OneKiller e1 s1) + = if e == e1 + then ok + else TwoKillers e s e1 s1 +pushKiller !e s tk@(TwoKillers e1 s1 e2 _) + | e == e1 || e == e2 = tk + | otherwise = TwoKillers e s e1 s1 + +killerToList :: Killer -> [Move] +killerToList NoKiller = [] +killerToList (OneKiller e _) = [e] +killerToList (TwoKillers e1 _ e2 _) = [e1, e2] + +--- Communication to the outside - some convenience functions --- + +informBM :: Node m => Int -> Int -> Int -> [Move] -> m () +informBM a b c d = inform (BestMv a b c d) + +informCM :: Node m => Move -> Int -> m () +informCM a b = inform (CurrMv a b) + +informStr :: Node m => String -> m () +informStr s = inform (InfoStr s) + +logmes :: Node m => String -> m () +logmes s = inform (LogMes s) + +informBest :: Node m => Int -> Int -> [Move] -> Search m () +informBest s d es = do + n <- lift curNodes + lift $ informBM s d n es diff --git a/Search/AlbetaTypes.hs b/Search/AlbetaTypes.hs new file mode 100644 index 00000000..f4b88715 --- /dev/null +++ b/Search/AlbetaTypes.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} + +module Search.AlbetaTypes ( + Node(..), + DoResult(..), + Comm(..), + ABControl(..) +) where + +import Control.Monad + +import Struct.Struct + +data ABControl = ABC { + maxdepth :: Int, + lastpv :: [Move], + lastscore :: Maybe Int, + rootmvs :: [Move], + window :: Int, + best :: Bool, + stoptime :: Int + } deriving Show + +-- The node class, dependent on a game monad m +class Monad m => Node m where + staticVal :: m Int -- static evaluation of a node + materVal :: m Int -- material evaluation (for prune purpose) + genEdges :: Int -> Int -> Bool -> m ([Move], [Move]) -- generate all legal edges + genTactEdges :: m [Move] -- generate all edges in tactical positions + legalEdge :: Move -> m Bool -- is the move legal? + killCandEdge :: Move -> Move -> m Bool -- is the move killer candidate? + inSeq :: Move -> Move -> m Bool -- can 2 moves be in sequence? + tactical :: m Bool -- if a position is tactical, search further + doEdge :: Move -> Bool -> m DoResult + undoEdge :: m () + betaMove :: Bool -> Int -> Int -> Move -> m () -- called for beta-cut moves + nullEdge :: m () -- do null move (and also undo) + retrieve :: m (Int, Int, Int, Move, Int) -- retrieve the position in hash + store :: Int -> Int -> Int -> Move -> Int -> m () -- store the position in hash + curNodes :: m Int + inform :: Comm -> m () -- communicate to the world (log, current and best move) + choose :: Bool -> [(Int, [Move])] -> m (Int, [Move]) + timeout :: Int -> m Bool -- check if we have to abort because of time + +data DoResult = Exten !Int -- return mit extension (evtl 0) + | Final !Int -- return with a final score (probably draw) + | Illegal -- illegal move + +data Comm = LogMes String + | BestMv Int Int Int [Move] + | CurrMv Move Int + | InfoStr String diff --git a/Search/SearchMonad.hs b/Search/SearchMonad.hs new file mode 100644 index 00000000..c5d9141d --- /dev/null +++ b/Search/SearchMonad.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +-- The search monad (which is actually a state monad transformer in +-- continuation passing style) can be compiled strict if you +-- define the symbol SMSTRICT +-- otherwise it will be compiled lazy +module Search.SearchMonad ( + STPlus, + -- return, (>>=), + -- get, put, + gets, modify, + -- lift, + -- liftIO, + runSearch, execSearch + ) where + +import Control.Monad +import Control.Monad.State hiding (gets, modify) + +newtype STPlus r s m a = STPlus { runSTPlus :: s -> (a -> s -> m r) -> m r } +-- {-# INLINE runSTPlus #-} + +-- At least with GHC 7.4.1, we have: +-- the construct f a of fa -> ... is lazy, to make it strict, do +-- case f a of !fa -> ... +-- So we keep the simpler for for the lazy variant +instance Monad (STPlus r s m) where + return a = STPlus $ \s k -> k a s + {-# INLINE return #-} +#ifdef SMSTRICT + c >>= f = STPlus $ \s0 k -> runSTPlus c s0 $ \a s1 -> case f a of !fa -> runSTPlus fa s1 k +#else + c >>= f = STPlus $ \s0 k -> runSTPlus c s0 $ \a s1 -> runSTPlus (f a) s1 k +#endif + {-# INLINE (>>=) #-} + +instance MonadState s (STPlus r s m) where + get = STPlus $ \s k -> k s s + {-# INLINE get #-} + put s = STPlus $ \_ k -> k () s + {-# INLINE put #-} + +instance MonadTrans (STPlus r s) where + {-# INLINE lift #-} + -- lift :: Monad m => m a -> STPlus r s m a + lift m = STPlus $ \s k -> m >>= \a -> k a s + + +instance MonadIO m => MonadIO (STPlus r s m) where + {-# INLINE liftIO #-} + liftIO = lift . liftIO + +runSearch :: Monad m => STPlus (a, s) s m a -> s -> m (a, s) +runSearch c s = runSTPlus c s $ \a s0 -> return (a, s0) +{-# INLINE runSearch #-} + +execSearch ms s = liftM snd $ runSearch ms s +{-# INLINE execSearch #-} + +{-# INLINE gets #-} +gets :: Monad m => (s -> a) -> STPlus r s m a +#ifdef SMSTRICT +gets f = STPlus $ \s k -> case f s of !fs -> k fs s +#else +gets f = STPlus $ \s k -> k (f s) s +#endif + +{-# INLINE modify #-} +modify :: Monad m => (s -> s) -> STPlus r s m () +#ifdef SMSTRICT +modify f = STPlus $ \s k -> case f s of !fs -> k () fs +#else +modify f = STPlus $ \s k -> k () (f s) +#endif diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 00000000..833b4c60 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Struct/Context.hs b/Struct/Context.hs index 065834f0..c4eb00a3 100644 --- a/Struct/Context.hs +++ b/Struct/Context.hs @@ -9,7 +9,6 @@ import System.Time import Struct.Struct import Struct.Status -import Config.ConfigClass import Search.SearchMonad data InfoToGui = Info { @@ -34,6 +33,14 @@ data InfoToGui = Info { data LogLevel = DebugSearch | DebugUci | LogInfo | LogWarning | LogError | LogNever deriving (Eq, Ord) +levToPrf :: LogLevel -> String +levToPrf DebugSearch = "DebugS" +levToPrf DebugUci = "DebugU" +levToPrf LogInfo = "Info" +levToPrf LogWarning = "Warning" +levToPrf LogError = "Error" +levToPrf LogNever = "Never" + -- This is the context in which the other components run -- it has a fix part, established at the start of the programm, -- and a variable part (type Changing) which is kept in an MVar @@ -49,7 +56,6 @@ data Context = Ctx { -- This is the variable context part (global mutable context) data Changing = Chg { - config :: GConfig, -- the configuration component working :: Bool, -- are we in tree search? compThread :: Maybe ThreadId, -- the search thread id crtStatus :: MyState, -- current state @@ -73,48 +79,31 @@ modifyChanging f = do ctx <- ask liftIO $ modifyMVar_ (change ctx) (return . f) -getCfg :: CtxIO GConfig -getCfg = do - chg <- readChanging - return $ config chg - -getIParamDef :: String -> Int -> CtxIO Int -getIParamDef pn d = do - GConfig cfg <- getCfg - return $ getIParamDefault cfg pn d - ctxLog :: LogLevel -> String -> CtxIO () ctxLog lev mes = do ctx <- ask - when (lev >= loglev ctx) $ liftIO $ logging (logger ctx) prf mes - -logging mlchan prf mes = - case mlchan of - Just lchan -> do - -- TOD s ps <- liftIO getClockTime - -- let cms = fromIntegral $ s*1000 + ps `div` 1000000000 - cms <- currMilli - writeChan lchan $ show cms ++ " [" ++ prf ++ "]: " ++ mes - Nothing -> return () + when (lev >= loglev ctx) $ liftIO $ logging (logger ctx) (startSecond ctx) (levToPrf lev) mes -currentSecs = do - TOD s _ <- getClockTime - return s +startSecond :: Context -> Integer +startSecond ctx = s + where TOD s _ = strttm ctx -secondZero = 1365100000 -- the reference second - has to be increased by 1 mio every about 3 years +logging lchan refs prf mes = do + cms <- currMilli refs + writeChan lchan $ show cms ++ " [" ++ prf ++ "]: " ++ mes -- Current time in ms since program start -currMilli :: IO Int -currMilli = do +currMilli :: Integer -> IO Int +currMilli ref = do TOD s ps <- liftIO getClockTime - return $ fromIntegral $ (s-secondZero)*1000 + ps `div` 1000000000 + return $ fromIntegral $ (s-ref)*1000 + ps `div` 1000000000 -- Communicate the best path so far informGui :: Int -> Int -> Int -> [Move] -> CtxIO () informGui sc tief nds path = do ctx <- ask chg <- readChanging - currt <- lift currMilli + currt <- lift $ currMilli $ startSecond ctx let gi = Info { infoDepth = tief, infoTime = currt - srchStrtMs chg, diff --git a/Uci/UCI.hs b/Uci/UCI.hs new file mode 100644 index 00000000..d9a5ba3b --- /dev/null +++ b/Uci/UCI.hs @@ -0,0 +1,266 @@ +module Uci.UCI ( + UCIMess(..), Pos(..), GoCmds(..), ExpCommand(..), + parseUciStr, parseMoveStr, parseExploreStr, + findDepth, findTInc, findTime, findMovesToGo + ) where + +import Data.Char +import Data.Array.Unboxed +import qualified Text.ParserCombinators.Parsec as P +import Text.ParserCombinators.Parsec ((<|>)) + +import Struct.Struct +import Moves.Base + +data UCIMess + = Uci + | Debug Bool + | IsReady + | SetOption Option + | UciNewGame + | Position Pos [Move] + | Go [GoCmds] + | Stop + | Ponderhit + | Quit + deriving Show + +data Option + = Name String + | NameValue String String + deriving Show + +data Pos + = StartPos + | Pos String + deriving Show + +data GoCmds + = SearchMoves [Move] + | Ponder + | Time Color Int + | TInc Color Int + | MovesToGo Int + | Depth Int + | Nodes Int + | Mate Int + | MoveTime Int + | Infinite + deriving (Eq, Show) + +data ExpCommand = Fen String -- new game, position from fen + | Init -- new game, initial position + | Moves -- print all moves + | QMoves -- print quiescent moves + | Down Move -- one level deep with the move + | Up -- one level up with the Int as score + | Eval -- evaluate the position + | QEval -- evaluate the position after quiescent search + | Help -- print some help + | Exit -- exit program + +parseUciStr = P.parse parseUCIMess "" + +parseMoveStr = P.parse parseMove "" + +parseExploreStr = P.parse parseExplore "" + +literal s = P.spaces >> P.string s + +untilP s = go s "" + where go s acc = (P.string s >> return (reverse acc)) + `orElse` do + c <- P.anyChar + go s (c:acc) + +orElse a b = P.try a <|> b + +parseUCIMess = P.choice $ map P.try [ + parseUciNewGame, + parseUci, + parseDebug, + parseIsReady, + parseStop, + parseSetOption, + parsePosition, + -- parsePonderhit, + parseGo, + parseQuit + ] + +parseUci = literal "uci" >> return Uci + +parseUciNewGame = literal "ucinewgame" >> return UciNewGame + +parseIsReady = literal "isready" >> return IsReady + +parseStop = literal "stop" >> return Stop + +-- parsePonderhit = literal "ponderhit" >> return Ponderhit + +parseQuit = literal "quit" >> return Quit + +parseDebug = do + literal "debug" + P.spaces + P.char 'o' + t <- P.try (P.char 'n' >> return True) <|> (P.string "ff" >> return False) + return (Debug t) + +parseSetOption = do + literal "setoption" + literal "name" + P.spaces + o <- (do + nm <- untilP "value" + vl <- P.many P.alphaNum + return (NameValue nm vl) + ) `orElse` (do + nm <- P.many P.alphaNum + return (Name nm) + ) + return $ SetOption o + +parsePosition = do + literal "position" + P.spaces + parseStartPos `orElse` parseFen + +parseFenPosition = do + s <- P.many1 $ P.oneOf "/12345678rnbqkpRNBQKP" + P.space + c <- P.oneOf "wb" + P.space + cr <- P.many1 $ P.oneOf "-QKqk" + P.space + ep <- P.many1 (P.oneOf "-abcdefgh36") + P.space + h <- P.many1 P.digit + P.space + P.anyChar + return $ s ++ " " ++ [c] ++ " " ++ cr ++ " " ++ ep ++ " " ++ h + +parseStartPos = do + literal "startpos" + P.spaces + ms <- (literal "moves" >> P.spaces >> parseMoves) + `orElse` return [] + return $ Position StartPos ms + +parseFen = do + literal "fen" + P.spaces + fenp <- parseFenPosition + P.spaces + ms <- (literal "moves" >> P.spaces >> parseMoves) + `orElse` return [] + return $ Position (Pos fenp) ms + +parseMoves = P.sepBy parseMove P.spaces + +parseMove = do + sf <- parseFeld + ef <- parseFeld + pr <- parsePromo `orElse` return Nothing + let m = moveFromTo sf ef + case pr of + Just b -> return $ activateTransf b m + Nothing -> return m + +parseFeld = do + lit <- P.oneOf ['a'..'h'] + cif <- P.oneOf ['1'..'8'] + return $ fromColRow (ord lit - ord 'a' + 1) (ord cif - ord '0') + +parsePromo = do + pro <- P.oneOf "qrbn" + return $ Just pro + +parseGo = do + literal "go" + P.spaces + -- gcs <- P.sepBy parseGoCmd P.spaces + gcs <- P.many parseGoCmd + return $ Go gcs + +parseGoCmd = P.choice $ map P.try [ + parsePonder, + parseTime, + parseTInc, + parseMovesToGo, + parseDepth, + parseNodes, + parseMate, + parseMoveTime, + parseInfinite, + parseSearchMoves + ] + +parseSearchMoves = do + literal "searchmoves" + P.spaces + mvs <- parseMoves + return $ SearchMoves mvs + +parsePonder = literal "ponder" >> return Ponder + +parseWithInt :: String -> (Int -> a) -> P.Parser a +parseWithInt s con = do + literal s + P.spaces + num <- P.many P.digit + return $ con (read num) + +parseTime = parseWithInt "wtime" (Time White) + `orElse` parseWithInt "btime" (Time Black) +parseTInc = parseWithInt "winc" (TInc White) + `orElse` parseWithInt "binc" (TInc Black) +parseMovesToGo = parseWithInt "movestogo" MovesToGo +parseDepth = parseWithInt "depth" Depth +parseNodes = parseWithInt "nodes" Nodes +parseMate = parseWithInt "mate" Mate +parseMoveTime = parseWithInt "movetime" MoveTime + +parseInfinite = literal "infinite" >> return Infinite + +-- Parsing the explore commands: +parseExplore = parseExpFen <|> parseExpInit <|> parseExpMoves <|> parseExpQMoves + <|> parseExpDown <|> parseExpUp <|> parseExpHelp <|> parseExpExit + <|> parseExpEval <|> parseExpQEval + +parseExpFen = P.char 'f' >> P.spaces >> parseFenPosition >>= return . Fen +parseExpInit = P.char 'i' >> return Init +parseExpMoves = P.char 'm' >> return Moves +parseExpQMoves = P.char 'q' >> return QMoves +parseExpDown = P.char 'd' >> parseMove >>= return . Down +parseExpUp = P.char 'u' >> return Up +parseExpEval = P.char 'e' >> return Eval +parseExpQEval = P.char 'v' >> return QEval +parseExpHelp = P.char 'h' >> return Help +parseExpExit = P.char 'x' >> return Exit + +-- Some utilities to find information in the uci go commands: + +findDepth :: [GoCmds] -> Maybe Int +findDepth [] = Nothing +findDepth (Depth d : _) = Just d +findDepth (_ : cms) = findDepth cms + +findTime :: Color -> [GoCmds] -> Maybe Int +findTime _ [] = Nothing +findTime c (Time c1 ms : cms) + | c == c1 = Just ms + | otherwise = findTime c cms +findTime c (_ : cms) = findTime c cms + +findTInc :: Color -> [GoCmds] -> Maybe Int +findTInc _ [] = Nothing +findTInc c (TInc c1 ms : cms) + | c == c1 = Just ms + | otherwise = findTInc c cms +findTInc c (_ : cms) = findTInc c cms + +findMovesToGo :: [GoCmds] -> Maybe Int +findMovesToGo [] = Nothing +findMovesToGo (MovesToGo m : _) = Just m +findMovesToGo (_ : cms) = findMovesToGo cms diff --git a/Uci/UciGlue.hs b/Uci/UciGlue.hs new file mode 100644 index 00000000..38659bdd --- /dev/null +++ b/Uci/UciGlue.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, BangPatterns, + FlexibleInstances + #-} +module Uci.UciGlue ( + bestMoveCont +) where + +import Data.Array.IArray +import Control.Monad.State.Lazy +import Control.Monad.Reader + +import qualified Search.SearchMonad as SM +import Search.AlbetaTypes +import Search.Albeta +import Struct.Struct +import Struct.Status +import Struct.Context +import Moves.Base +import Eval.Eval + +instance CtxMon CtxIO where + tellCtx = talkToContext + timeCtx = do + ctx <- ask + let refs = startSecond ctx + lift $ currMilli refs + +-- Parameter of the search at this level: +aspirWindow :: Int +aspirWindow = 24 -- initial aspiration window + +showEvalStats :: Bool +showEvalStats = False -- show eval statistics in logfile + +-- One iteration in the search for the best move +bestMoveCont :: Int -> Int -> MyState -> Maybe Int -> [Move] -> [Move] -> CtxIO IterResult +bestMoveCont tiefe sttime stati lastsc lpv rmvs = do + -- ctx <- ask + informGuiDepth tiefe + ctxLog LogInfo $ "start search for depth " ++ show tiefe + let abc = ABC { + maxdepth = tiefe, + lastpv = lpv, + lastscore = lastsc, + rootmvs = rmvs, + window = aspirWindow, + best = False, + stoptime = sttime + } + ((sc, path, rmvsf), statf) <- SM.runSearch (alphaBeta abc) stati + when (sc == 0) $ return () + let n = nodes . stats $ statf + informGui sc tiefe n path + ctxLog LogInfo $ "score " ++ show sc ++ " path " ++ show path + return (path, sc, rmvsf, statf) + +talkToContext :: Comm -> CtxIO () +talkToContext (LogMes s) = ctxLog LogInfo s +talkToContext (BestMv a b c d) = informGui a b c d +talkToContext (CurrMv a b) = informGuiCM a b +talkToContext (InfoStr s) = informGuiString s