diff --git a/Barbarossa.cabal b/Barbarossa.cabal new file mode 100644 index 00000000..5ef9cedc --- /dev/null +++ b/Barbarossa.cabal @@ -0,0 +1,74 @@ +-- Initial Barbarossa.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +Name: Barbarossa +Version: 0.1 +Synopsis: Chess engine in Haskell +-- description: +License: BSD3 +License-file: LICENSE +Author: Nicu Ionita +Maintainer: nicu.ionita@acons.at +Copyright: Nicu Ionita 2013 +Category: Game +Build-type: Simple +Cabal-version: >=1.8 + +Flag Profile + Description: Enables profile support + Default: False + +Executable Barbarossa + Main-is: Main/Barbarossa.hs + Build-depends: base >= 4.5, array, old-time, containers, mtl, parsec, vector, + random, stream-fusion, directory, transformers + 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 + if flag(profile) + -- GHC-Options: -auto-all -with-rtsopts="-p -hc -smemop.txt" + 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/LICENSE b/LICENSE new file mode 100644 index 00000000..03401607 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Nicu Ionita + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nicu Ionita nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main/Barbarossa.hs b/Main/Barbarossa.hs new file mode 100644 index 00000000..8a098408 --- /dev/null +++ b/Main/Barbarossa.hs @@ -0,0 +1,592 @@ +{-# LANGUAGE PatternGuards #-} +module Main where +import Control.Monad +import Control.Monad.Reader +import Data.Array.Unboxed +import Data.Maybe +import Control.Concurrent +import qualified Control.Exception as CE +import System.Environment (getArgs) +import System.IO +import System.Time + +import Struct.Struct +import Struct.Status +import Struct.Context +import Config.ConfigClass +import Hash.TransTab +import Uci.UCI +import Uci.UciGlue +import Moves.Base +import Moves.Moves (movesInit) +import Moves.Board (posFromFen) +import Moves.History +import Search.SearchMonad (execSearch) +import Eval.Eval (paramNames) +import Eval.FileParams (makeEvalState) + +-- Name, authos, version and suffix: +progName, progVersion, progVerSuff, progAuthor :: String +progName = "Barbarossa" +progAuthor = "Nicu Ionita" +progVersion = "0.01" +progVerSuff = "" + +data Options = Options { + optConfFile :: Maybe String, -- config file + optParams :: [String], -- list of eval parameter assignements + optLogging :: LogLevel -- logging level + } + +defaultOptions :: Options +defaultOptions = Options { + optConfFile = Nothing, + optParams = [], + optLogging = LogError + } + +setConfFile :: String -> Options -> Options +setConfFile cf opt = opt { optConfFile = Just sc } + +addParam :: String -> Options -> Options +addParam pa opt = opt { optParams = pa : optParams opt } + +setLogging :: Int -> Options -> Options +setLogging lev opt = opt { optLogging = llev } + where llev = case lev of + 0 -> DebugSearch + 1 -> DebugUci + 2 -> LogInfo + 3 -> LogWarning + 4 -> LogError + _ -> if llev < 0 then DebugSearch else LogNever + +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,..." + ] + +theOptions :: IO (Options, [String]) +theOptions argv = do + args <- getArgs + case getOpt Permute options args of + (o, n, []) -> return (foldr ($) defaultOptions o, n) + (_, _, es) -> ioError (userError (concat es ++ usageInfo header options)) + where header = "Usage: " ++ idName ++ " [-c CONF] [-l LEV] [-p name=val[,...]]" + +initContext :: Options -> IO Context +initContext opts = do + clktm <- getClockTime + let llev = getIParamDefault cfg "logLevel" 0 + mlchan <- newChan + wchan <- newChan + ichan <- newChan + ha <- newCache cfg + hi <- newHist + (parc, evs) <- makeEvalState (optConfFile opts) progVersion progVerSuff + let chg = Chg { + config = cf, + working = False, + compThread = Nothing, + crtStatus = posToState initPos ha hi evs, + forGui = Nothing, + srchStrtMs = 0, + myColor = White + } + ctxVar <- newMVar chg + let context = Ctx { + logger = mlchan, + writer = wchan, + inform = ichan, + strttm = clktm, + change = ctxVar, + loglev = llev, + evpid = parc + } + return context + +main :: IO () +main = do + opts <- theOptions + ctx <- initContext opts + runReaderT startTheMachine ctx + +startTheMachine :: CtxIO () +startTheMachine = do + ctx <- ask + let TOD crts _ = strttm ctx + logFileName = progLogName ++ show crtt ++ ".log" + startLogger logFileName + startWriter + startInformer + beforeReadLoop + ctxCatch theReader + $ \e -> ctxLog LogError $ "Reader error: " ++ show e + -- whatever to do when ending: + beforeProgExit + +-- The logger will be startet anyway, but will open a file +-- only when it has to write the first message +-- When it cannot open that file, it should at least consume the messages +-- so that the channel does not get stuck +data LoggerState = LoggerFile String + | LoggerHandle Handle + | LoggerError + +startLogger :: String -> CtxIO () +startLogger file = do + ctx <- ask + _ <- liftIO $ forkIO $ CE.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 + hPutStrLn h s + hFlush h + theLogger lchan (LoggerHandle h) + LoggerHandle h -> do + hPutStrLn h s + hFlush h + theLogger lchan lst + +-- The writer just writes to standard output +-- But it is necessary to write from a single thread, as this is a shared resource +startWriter :: CtxIO () +startWriter = do + ctx <- ask + _ <- liftIO $ forkIO $ theWriter (writer ctx) (logger ctx) + return () + +theWriter :: Chan String -> Chan String -> Bool -> IO () +theWriter wchan lchan log = forever $ do + s <- readChan wchan + hPutStrLn stdout s + hFlush stdout + when log $ logging lchan $ "Output: " ++ s + +-- The informer is getting structured data +-- and formats it to a string which is set to the writer +-- It ignores messages which come while we are not searching +startInformer :: CtxIO () +startInformer = do + ctx <- ask + _ <- newThread (theInformer (inform ctx)) + return () + +theInformer :: Chan InfoToGui -> CtxIO () +theInformer ichan = forever $ do + s <- liftIO $ readChan ichan + chg <- readChanging + when (working chg) $ toGui s + +toGui :: InfoToGui -> CtxIO () +toGui s = case s of + InfoS s' -> answer $ infos s' + InfoD _ -> answer $ formInfoDepth s + InfoCM _ _ -> answer $ formInfoCM s + _ -> answer $ formInfo s + +-- The reader is executed by the main thread +-- It reads commands from the GUI and interprets them +theReader :: CtxIO () +theReader = do + line <- liftIO getLine + let euci = parseUciStr line + stop <- case euci of + Left _ -> do + ctxLog DebugUci $ "Input: " ++ line + ctxLog DebugUci $ "Parse: " ++ show euci + return False + Right uci -> interpret uci + unless stop theReader + +interpret :: UCIMess -> CtxIO Bool +interpret uci = + case uci of + Quit -> do doQuit + let ms = 500 -- sleep 0.5 second + liftIO $ threadDelay $ ms * 1000 + return True + Uci -> goOn doUci + IsReady -> goOn doIsReady + UciNewGame -> goOn doUciNewGame + Position p mvs -> goOn (doPosition p mvs) + Go cmds -> goOn (doGo cmds) + Stop -> goOn $ doStop True + Ponderhit -> goOn doPonderhit + _ -> goOn ignore + +doQuit :: CtxIO () +doQuit = ctxLog LogInfo "Normal exit" + +goOn :: CtxIO () -> CtxIO Bool +goOn action = action >> return False + +doUci :: CtxIO () +doUci = do + evid <- asks evpid + answer (idName ++ " " ++ evid) >> answer idAuthor >> answer uciOk + +doIsReady :: CtxIO () +doIsReady = when (movesInit == 0) $ answer readyOk + +ignore :: CtxIO () +ignore = notImplemented "ignored" + +notImplemented :: String -> CtxIO () +notImplemented s = ctxLog LogWarning $ "not implemented: " ++ s + +doUciNewGame :: CtxIO () +doUciNewGame = notImplemented "doUciNewGame" + +doPosition :: Pos -> [Move] -> CtxIO () +doPosition fen mvs = do + -- ctxLog DebugUci $ "Position: " ++ show fen ++ " moves " ++ show mvs + chg <- readChanging + if working chg + then ctxLog DebugUci "GUI sent Position while I'm working..." + else do + hi <- liftIO newHist + let es = evalst $ crtStatus chg + ns <- newState fen mvs (hash . crtStatus $ chg) hi es + -- ns <- newState fen mvs + modifyChanging (\c -> c { crtStatus = ns, myColor = myCol }) + where newState fpos ms c h es = foldM execMove (stateFromFen fpos c h es) ms + -- execMove p m = execStateT (doMove True m False) p + execMove p m = execSearch (doMove True m False) p + fenColor = movingColor fen + myCol = if even (length mvs) then fenColor else other fenColor + +stateFromFen :: Pos -> Cache -> History -> EvalState -> MyState +stateFromFen StartPos c h es = posToState initPos c h es +stateFromFen (Pos fen) c h es = posToState (posFromFen fen) c h es + +movingColor :: Pos -> Color +movingColor fen + | Pos str <- fen + = case words str of + _ : (c:_) : _ -> case c of + 'w' -> White + 'b' -> Black + _ -> error $ "Wrong fen: " ++ str + _ -> error $ "Wrong fen: " ++ str + | otherwise = White -- startposition + +doGo :: [GoCmds] -> CtxIO () +doGo cmds = do + ctxLog DebugUci $ "Go: " ++ show cmds + chg <- readChanging + if working chg + then ctxLog DebugUci "GUI sent Go while I'm working..." + 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 + dpt = fromMaybe md (findDepth cmds) + lastsc = case forGui chg of + Just InfoB { infoScore = sc } -> sc + _ -> 0 + startWorking tim tpm mtg dpt + +getTimeParams :: [GoCmds] -> Int -> Color -> (Int, Int, Int) +getTimeParams cs _ c -- unused: lastsc + = if tpm == 0 && tim == 0 + then (0, 0, 0) + else (tim, tpm, mtg) + where tpm = fromMaybe 0 $ findTInc c cs + tim = fromMaybe 0 $ findTime c cs + mtg = fromMaybe 0 $ findMovesToGo cs + +timeReserved :: Int +timeReserved = 20 -- milliseconds reserved for move communication + +remTimeFracIni, remTimeFracFin, remTimeFracDev :: Double +remTimeFracIni = 0.01 -- fraction of remaining time which we can consume at once - initial value +remTimeFracFin = 0.5 -- same at final (when remaining time is near zero) +remTimeFracDev = remTimeFracFin - remTimeFracIni + +compTime :: Int -> Int -> Int -> Int -> (Int, Int) +compTime tim tpm fixmtg lastsc + = if tpm == 0 && tim == 0 then (0, 0) else (ctm, tmx) + where ctn = tpm + tim `div` mtg + ctm = if tim > 0 && tim < 8000 || tim == 0 && tpm < 1500 then 200 else ctn + mtg = if fixmtg > 0 then fixmtg else estimateMovesToGo lastsc + frtim = fromIntegral $ max 0 $ tim - ctm -- rest time after this move + fctm = fromIntegral ctm :: Double + rtimprc = fctm / max frtim fctm + rtimfrc = remTimeFracIni + remTimeFracDev * rtimprc + tmxt = round $ fctm + rtimfrc * frtim + tmx = min (tim - timeReserved) tmxt + +estMvsToGo :: Array Int Int +estMvsToGo = listArray (0, 8) [30, 28, 24, 18, 12, 10, 8, 6, 3] + +estimateMovesToGo :: Int -> Int +estimateMovesToGo sc = estMvsToGo ! mvidx + where mvidx = min 8 $ abs sc `div` 100 + +-- Some parameters (until we have a good solution) +clearHash :: Bool +clearHash = False + +newThread :: CtxIO () -> CtxIO ThreadId +newThread a = do + ctx <- ask + liftIO $ forkIO $ runReaderT a ctx + +startWorking :: Int -> Int -> Int -> Int -> CtxIO () +startWorking tim tpm mtg dpt = do + currms <- lift currMilli + ctxLog DebugUci $ "Start at " ++ show currms + ++ " to search: " ++ show tim ++ " / " ++ show tpm ++ " / " ++ show mtg + ++ " - maximal " ++ show dpt ++ " plys" + modifyChanging $ \c -> c { working = True, srchStrtMs = currms, + crtStatus = posNewSearch (crtStatus c) } + tid <- newThread (startSearchThread tim tpm mtg dpt) + modifyChanging (\c -> c { compThread = Just tid }) + return () + +-- We use modifyChanging in at least 2 threads: in the reader and +-- in the search thread (here in giveBestMove) +-- 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 [] []) + $ \e -> do + chg <- readChanging + let mes = "searchTheTree terminated by exception: " ++ show e + answer $ infos mes + 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 + -- Why? liftIO $ threadDelay $ 50*1000 -- give time to send the ans + +ctxCatch :: CtxIO a -> (CE.SomeException -> CtxIO a) -> CtxIO a +ctxCatch a f = do + ctx <- ask + liftIO $ CE.catch (runReaderT a ctx) + (\e -> runReaderT (f e) ctx) + +internalStop :: Int -> CtxIO () +internalStop ms = do + let sleep = ms * 1000 + ctxLog DebugUci $ "Internal stop clock started for " ++ show ms ++ " ms" + liftIO $ threadDelay sleep + ctxLog DebugUci "Internal stop clock ended" + doStop False + +betterSc :: Int +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 + 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 + let (ms', mx) = compTime tim tpm mtg sc + ms = if sc > betterSc + then ms' * 4 `div` 5 + else if sc < -betterSc + then ms' * 6 `div` 5 + else ms' + strtms = srchStrtMs chg + delta = strtms + ms - currms + ms2 = ms `div` 2 + onlyone = ms > 0 && length rmvsf == 1 && tief >= 4 -- only in normal play + timeover = ms > 0 && delta <= ms2 -- time is half over + depthmax = tief >= mtief -- or maximal depth + mes = "Depth " ++ show tief ++ " Score " ++ show sc ++ " in ms " + ++ show currms ++ " remaining " ++ show delta + ++ " path " ++ show path + -- answer $ infos $ "currms = " ++ show currms + -- answer $ infos $ "ms = " ++ show ms + -- answer $ infos $ "mx = " ++ show mx + -- answer $ infos $ "cr+mx = " ++ show (currms + mx) + ctxLog LogInfo mes + ctxLog LogInfo $ "compTime: " ++ show ms' ++ " / " ++ show mx + -- if ms > 0 && (delta <= 0 || tief >= mtief) -- time is over or maximal depth + if depthmax || timeover || onlyone + then do + -- answer $ infos $ "End of search" + -- answer $ infos $ "depthmax = " ++ show depthmax + -- answer $ infos $ "timeover = " ++ show timeover + -- answer $ infos $ "onlyone = " ++ show onlyone + when depthmax $ ctxLog LogInfo "in searchTheTree: max depth reached" + giveBestMove path + else do + chg' <- readChanging + if working chg' + then searchTheTree (tief + 1) mtief (currms + mx) tim tpm mtg (Just sc) path rmvsf + else do + ctxLog DebugUci "in searchTheTree: not working" + giveBestMove path -- was stopped + +storeBestMove :: [Move] -> Int -> CtxIO () +storeBestMove mvs sc = do + let s = InfoB { infoPv = mvs, infoScore = sc } + modifyChanging (\c -> c { forGui = Just s }) + +giveBestMove :: [Move] -> CtxIO () +giveBestMove mvs = do + -- ctxLog "Info" $ "The moves: " ++ show mvs + modifyChanging $ \c -> c { + working = False, compThread = Nothing, forGui = Nothing } + if null mvs + then answer $ infos "empty pv" + else answer $ bestMove (head mvs) Nothing + +beforeReadLoop :: CtxIO () +beforeReadLoop = do + chg <- readChanging + let evst = evalst $ crtStatus chg + ctxLog LogInfo "Initial eval parameters:" + forM_ (zip paramNames (esDParams evst)) $ \(n, v) -> ctxLog LogInfo $! n ++ "\t" ++ show v + +beforeProgExit :: CtxIO () +beforeProgExit = return () + +doStop :: Bool -> CtxIO () +doStop extern = do + chg <- readChanging + modifyChanging (\c -> c { working = False, compThread = Nothing }) + case compThread chg of + Just tid -> do + -- when extern $ liftIO $ threadDelay 500000 -- warte 0.5 Sec. + when extern $ liftIO $ threadDelay 100000 -- warte 0.1 Sec. + liftIO $ killThread tid + case forGui chg of + Just ifg -> giveBestMove $ infoPv ifg + Nothing -> return () + _ -> return () + +doPonderhit :: CtxIO () +doPonderhit = notImplemented "doPonderhit" + +-- Helper: Answers the GUI with a string +answer :: String -> CtxIO () +answer s = do + ctx <- ask + liftIO $ writeChan (writer ctx) s + +-- Name of the log file +progLogName :: String +progLogName = "abulafia" ++ "-" ++ progVersion + ++ if null progVerSuff then "" + else "-" ++ progVerSuff + +-- These are the possible answers from engine to GUI: +idName, idAuthor, uciOk, readyOk :: String +idName = "id name " ++ progName ++ " " ++ progVersion + ++ if null progVerSuff then "" else " " ++ progVerSuff +idAuthor = "id author " ++ progAuthor +uciOk = "uciok" +readyOk = "readyok" + +bestMove :: Move -> Maybe Move -> String +bestMove m mp = s + where s = "bestmove " ++ toString m ++ sp + sp = maybe "" (\v -> " ponder " ++ toString v) mp + +-- Info answers: +-- sel.depth nicht implementiert +formInfo :: InfoToGui -> String +formInfo itg = "info" + -- ++ " score cp " ++ show isc + ++ formScore isc + ++ " depth " ++ show (infoDepth itg) + -- ++ " seldepth " ++ show idp + ++ " time " ++ show (infoTime itg) + ++ " nodes " ++ show (infoNodes itg) + ++ nps' + ++ " pv" ++ concatMap (\m -> ' ' : toString m) (infoPv itg) + where nps' = case infoTime itg of + 0 -> "" + x -> " nps " ++ show (infoNodes itg `div` x * 1000) + isc = infoScore itg + +formInfoB :: InfoToGui -> String +formInfoB itg = "info" + -- ++ " score cp " ++ show isc + ++ formScore isc + ++ " pv" ++ concatMap (\m -> ' ' : toString m) (infoPv itg) + where isc = infoScore itg + +formScore :: Int -> String +formScore i + | i >= mateScore - 255 = " score mate " ++ show ((mateScore - i + 1) `div` 2) + | i <= (-mateScore) + 255 = " score mate " ++ show ((-mateScore - i) `div` 2) + | otherwise = " score cp " ++ show i + +-- sel.depth nicht implementiert +formInfo2 :: InfoToGui -> String +formInfo2 itg = "info" + ++ " depth " ++ show (infoDepth itg) + ++ " time " ++ show (infoTime itg) + ++ " nodes " ++ show (infoNodes itg) + ++ nps' + -- ++ " pv" ++ concatMap (\m -> ' ' : toString m) (infoPv itg) + where nps' = case infoTime itg of + 0 -> "" + x -> " nps " ++ show (infoNodes itg * 1000 `div` x) + +formInfoNps :: InfoToGui -> Maybe String +formInfoNps itg + = case infoTime itg of + 0 -> Nothing + x -> Just $ "info nps " ++ show (infoNodes itg `div` x * 1000) + +formInfoDepth :: InfoToGui -> String +formInfoDepth itg + = "info depth " ++ show (infoDepth itg) + -- ++ " seldepth " ++ show (infoDepth itg) + +formInfoCM :: InfoToGui -> String +formInfoCM itg + = "info currmove " ++ toString (infoMove itg) + ++ " currmovenumber " ++ show (infoCurMove itg) + +depth :: Int -> Int -> String +depth d _ = "info depth " ++ show d + +inodes :: Int -> String +inodes n = "info nodes " ++ show n + +pv :: Int -> [Move] -> String +pv t mvs = "info time " ++ show t ++ " pv" + ++ concatMap (\m -> ' ' : toString m) mvs + +nps :: Int -> String +nps n = "info nps " ++ show n + +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 + ef <- openFile efname AppendMode + hPutStrLn ef $ show tm ++ " " ++ idName ++ ": " ++ show e + hClose ef + ) $ \_ -> return () diff --git a/Struct/Context.hs b/Struct/Context.hs new file mode 100644 index 00000000..065834f0 --- /dev/null +++ b/Struct/Context.hs @@ -0,0 +1,145 @@ +module Struct.Context where + +import Control.Concurrent.Chan +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Monad.State.Strict +import Control.Monad.Reader +import System.Time + +import Struct.Struct +import Struct.Status +import Config.ConfigClass +import Search.SearchMonad + +data InfoToGui = Info { + infoDepth :: Int, + -- infoSelDepth :: Int, + infoTime :: Int, + infoNodes :: Int, + infoPv :: [Move], + infoScore :: Int + } + | InfoB { + infoPv :: [Move], + infoScore :: Int + } + | InfoD { infoDepth :: Int } + | InfoCM { + infoMove :: Move, + infoCurMove :: Int + } + | InfoS { infoString :: String } + +data LogLevel = DebugSearch | DebugUci | LogInfo | LogWarning | LogError | LogNever + deriving (Eq, Ord) + +-- 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 +data Context = Ctx { + logger :: Chan String, -- the logger channel + writer :: Chan String, -- the writer channel + inform :: Chan InfoToGui, -- the gui informer channel + strttm :: ClockTime, -- the program start time + loglev :: LogLevel, -- loglevel, only higher messages will be logged + evpid :: String, -- identifier for the eval parameter config + change :: MVar Changing -- the changing context + } + +-- 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 + forGui :: Maybe InfoToGui, -- info for gui + srchStrtMs :: Int, -- search start time (milliseconds) + myColor :: Color -- our play color + } + +type CtxIO = ReaderT Context IO + +-- Result of a search +type IterResult = ([Move], Int, [Move], MyState) + +readChanging :: CtxIO Changing +readChanging = do + ctx <- ask + liftIO $ readMVar $ change ctx + +modifyChanging :: (Changing -> Changing) -> CtxIO () +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 () + +currentSecs = do + TOD s _ <- getClockTime + return s + +secondZero = 1365100000 -- the reference second - has to be increased by 1 mio every about 3 years + +-- Current time in ms since program start +currMilli :: IO Int +currMilli = do + TOD s ps <- liftIO getClockTime + return $ fromIntegral $ (s-secondZero)*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 + let gi = Info { + infoDepth = tief, + infoTime = currt - srchStrtMs chg, + infoNodes = nds, + infoPv = path, + infoScore = sc + } + liftIO $ writeChan (inform ctx) gi + +-- Communicate the current move +informGuiCM :: Move -> Int -> CtxIO () +informGuiCM m cm = do + ctx <- ask + let gi = InfoCM { infoMove = m, infoCurMove = cm } + liftIO $ writeChan (inform ctx) gi + +-- Communicate the current depth +informGuiDepth :: Int -> CtxIO () +informGuiDepth tief = do + ctx <- ask + let gi = InfoD { infoDepth = tief } + liftIO $ writeChan (inform ctx) gi + +informGuiString :: String -> CtxIO () +informGuiString s = do + ctx <- ask + let gi = InfoS { infoString = s } + liftIO $ writeChan (inform ctx) gi diff --git a/Struct/Status.hs b/Struct/Status.hs new file mode 100644 index 00000000..50eb2922 --- /dev/null +++ b/Struct/Status.hs @@ -0,0 +1,30 @@ +module Struct.Status ( + Stats(..), + MyState(..), + EvalState(..) +) where + +import Data.Array.Unboxed +import Data.Word + +import Struct.Struct +import Moves.History +import Hash.TransTab + +data Stats = Stats { + nodes :: !Int, + maxmvs :: !Int + } deriving Show + +data MyState = MyState { + stack :: [MyPos], -- stack of played positions + hash :: !Cache, -- transposition table + hist :: History, -- history table + stats :: !Stats, -- statistics + evalst :: EvalState -- eval status (parameter & statistics) + } + +data EvalState = EvalState { + esDParams :: [Double], + esIParams :: [Int] + } deriving Show diff --git a/Struct/Struct.hs b/Struct/Struct.hs new file mode 100644 index 00000000..f2f0d9c9 --- /dev/null +++ b/Struct/Struct.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE BangPatterns #-} +module Struct.Struct ( + BBoard, Square, ZKey, ShArray, MaArray, DbArray, Move(..), + Piece(..), Color(..), BasicPos(..), TabCont(..), MyPos(..), + black, slide, kkrq, diag, epcas, other, moving, + epMask, fyMask, fyIncr, fyZero, mvMask, caRiMa, + caRKiw, caRQuw, caRMKw, caRMQw, caRKib, caRQub, caRMKb, caRMQb, + tabla, emptyPos, isReversible, remis50Moves, set50Moves, reset50Moves, addHalfMove, + fromSquare, toSquare, isSlide, isDiag, isKkrq, + moveIsNormal, moveIsCastle, moveIsTransf, moveIsEnPas, + moveColor, moveTransfPiece, moveEnPasDel, makeEnPas, + makeCastleFor, makeTransf, makeSpecial, moveIsSpecial, moveFromTo, + activateTransf, fromColRow, checkCastle, checkEnPas, toString + -- isPawnMoving, isKingMoving + ) where + +import Data.Array.Unboxed +import Data.Array.Base +import Data.Char (ord, chr) +import Data.Word +import Data.Bits +import Data.Ix +import qualified Data.Vector.Storable as V +import Foreign + +-- The very basic data types used in the modules +type BBoard = Word64 +type Square = Int +type ZKey = Word64 + +type ShArray = UArray Square Int +type MaArray = UArray Square BBoard +type DbArray = UArray Int BBoard + +data Piece = Pawn | Knight | Bishop | Rook | Queen | King + deriving (Eq, Ord, Enum, Ix, Show) + +data Color = White | Black deriving (Eq, Show, Ord, Enum, Ix) + +-- This is the complete representation of a position, no redundant fields +data BasicPos = BPos { + bpblack, bpslide, bpkkrq, bpdiag, bpepcas :: !BBoard + } + deriving (Eq, Show) + +-- Storable is needed for the hash (transposition) table +instance Storable BasicPos where + sizeOf _ = 5 * sizeOf (undefined :: BBoard) + alignment _ = alignment (undefined :: BBoard) + + {-# INLINE peek #-} + peek p = let q = castPtr p + in do b <- peekElemOff q 0 + s <- peekElemOff q 1 + k <- peekElemOff q 2 + d <- peekElemOff q 3 + e <- peekElemOff q 4 + return $ BPos b s k d e + + {-# INLINE poke #-} + poke p (BPos b s k d e) + = let q = castPtr p + in do pokeElemOff q 0 b + pokeElemOff q 1 s + pokeElemOff q 2 k + pokeElemOff q 3 d + pokeElemOff q 4 e + +data TabCont = Empty + | Busy !Color !Piece + deriving (Eq, Show) + +data MyPos = MyPos { + basicPos :: !BasicPos, -- should not be strict here + zobkey :: !ZKey, -- hash key + mater :: !Int, -- material balance + white, occup, kings, pawns :: !BBoard, -- further heavy used bitboards computed for efficiency + queens, rooks, bishops, knights :: !BBoard, + whAttacs, blAttacs, check :: BBoard, -- white & black attacs + whPAttacs, whNAttacs, whBAttacs, whRAttacs, whQAttacs, whKAttacs :: BBoard, + blPAttacs, blNAttacs, blBAttacs, blRAttacs, blQAttacs, blKAttacs :: BBoard, + pinned :: !BBoard, + wpindirs :: [(Square, BBoard)], -- white pining directions + bpindirs :: [(Square, BBoard)], -- black pining directions + staticScore :: Int, -- this is not really ok, then the score must not be int! + staticFeats :: [Int], + realMove :: !Bool + } + deriving (Eq, Show) + +-- These functions are defined for convenience and of course inlined: +{-# INLINE black #-} +black = bpblack . basicPos +{-# INLINE slide #-} +slide = bpslide . basicPos +{-# INLINE kkrq #-} +kkrq = bpkkrq . basicPos +{-# INLINE diag #-} +diag = bpdiag . basicPos +{-# INLINE epcas #-} +epcas = bpepcas . basicPos + +{- +Piece coding in MyPos (vertical over slide, kkrq and diag): +Piece slide kkrq diag +Pawn = 0 0 1 +Knight = 0 1 0 +King = 0 1 1 +Bishop = 1 0 1 +Rook = 1 1 0 +Queen = 1 1 1 +-} + +{-# INLINE pieceAt #-} +pieceAt :: MyPos -> BBoard -> Piece +pieceAt !p bsq + = case bsq .&. diag p of + 0 -> case bsq .&. slide p of + 0 -> Knight + _ -> Rook + _ -> case bsq .&. kkrq p of + 0 -> case bsq .&. slide p of + 0 -> Pawn + _ -> Bishop + _ -> case bsq .&. slide p of + 0 -> King + _ -> Queen + +{-# INLINE tabla #-} +tabla :: MyPos -> Square -> TabCont +tabla p sq + | occup p .&. bsq == 0 = Empty + | otherwise = Busy c f + where c = if white p .&. bsq /= 0 then White else Black + f = pieceAt p bsq + bsq = 1 `unsafeShiftL` sq + +newtype Move = Move Word32 deriving Eq + +instance Show Move where + show = toString + +-- some constant bitboards for additional conditions like +-- en-passant, castle rights and 50 moves rule +epMask, fyMask, fyIncr, fyZero, mvMask, caRiMa :: BBoard +caRKiw, caRQuw, caRMKw, caRMQw :: BBoard +caRKib, caRQub, caRMKb, caRMQb :: BBoard +epMask = 0x0000FF0000FF0000 -- en passant mask +fyMask = 0x000000000000FF00 -- mask for 50 moves rules +fyIncr = 0x0000000000000100 -- 50 moves rule increment +fyZero = complement fyMask -- to reset the 50 moves count +fyMaxi = 0x0000000000006400 -- to compare if we reaches 100 halfmoves +mvMask = 0x0080000000000000 -- Moving mask (1 in that bit means black moves) +caRiMa = 0x9100000000000091 -- Mask for castle rights +caRKiw = 0x0000000000000090 -- white: king & rook position for kingside castle +caRQuw = 0x0000000000000011 -- white: king & rook pisition for queenside castle +caRMKw = 0x0000000000000060 -- white: empty fields for kingside castle +caRMQw = 0x000000000000000E -- white: empty fields for queenside castle +caRKib = 0x9000000000000000 -- black: king & rook position for kingside castle +caRQub = 0x1100000000000000 -- black: king & rook position for queenside castle +caRMKb = 0x6000000000000000 -- black: empty fields for kingside castle +caRMQb = 0x0E00000000000000 -- black: empty fields for queenside castle + +emptyBPos = BPos { + bpblack = 0, bpslide = 0, bpkkrq = 0, bpdiag = 0, bpepcas = 0 + } +emptyPos = MyPos { + basicPos = emptyBPos, zobkey = 0, mater = 0, + white = 0, occup = 0, kings = 0, pawns = 0, + queens = 0, rooks = 0, bishops = 0, knights = 0, + pinned = 0, whAttacs = 0, blAttacs = 0, check = 0, + whPAttacs = 0, whNAttacs = 0, whBAttacs = 0, whRAttacs = 0, whQAttacs = 0, whKAttacs = 0, + blPAttacs = 0, blNAttacs = 0, blBAttacs = 0, blRAttacs = 0, blQAttacs = 0, blKAttacs = 0, + wpindirs = [], bpindirs = [], staticScore = 0, staticFeats = [], realMove = False + } + +-- Stuff related to 50 moves rule +{-# INLINE isReversible #-} +isReversible :: MyPos -> Bool +isReversible p = fyMask .&. bpepcas (basicPos p) /= 0 + +{-# INLINE remis50Moves #-} +remis50Moves :: MyPos -> Bool +remis50Moves p = bpepcas (basicPos p) .&. fyMask >= fyMaxi + +{-# INLINE reset50Moves #-} +reset50Moves :: BBoard -> BBoard +reset50Moves b = b .&. fyZero + +{-# INLINE set50Moves #-} +set50Moves :: Int -> BBoard -> BBoard +set50Moves i b = reset50Moves b .|. (fromIntegral i `shift` 8 .&. fyMask) + +{-# INLINE addHalfMove #-} +addHalfMove :: BBoard -> BBoard +addHalfMove b = b + fyIncr + +{-# INLINE linco #-} +-- Gives all pieces with line/column move (rooks, queens) +linco :: MyPos -> BBoard +linco !p = slide p .&. kkrq p + +{-# INLINE isSlide #-} +isSlide :: Piece -> Bool +isSlide Bishop = True +isSlide Rook = True +isSlide Queen = True +isSlide _ = False + +{-# INLINE isKkrq #-} +isKkrq :: Piece -> Bool +isKkrq Pawn = False +isKkrq Bishop = False +isKkrq _ = True + +{-# INLINE isDiag #-} +isDiag :: Piece -> Bool +isDiag Knight = False +isDiag Rook = False +isDiag _ = True + +{-# INLINE pieceBB #-} +pieceBB :: Piece -> MyPos -> BBoard +pieceBB Pawn !p = diag p .&. complement (slide p .|. kkrq p) +pieceBB Knight !p = kkrq p .&. complement (slide p .|. diag p) +pieceBB Bishop !p = slide p .&. diag p .&. complement (kkrq p) +pieceBB Rook !p = slide p .&. kkrq p .&. complement (diag p) +pieceBB Queen !p = slide p .&. kkrq p .&. diag p +pieceBB King !p = kkrq p .&. diag p .&. complement (slide p) + +isKingAt :: Square -> MyPos -> Bool +isKingAt !sq !p = kkrq p `testBit` sq + && diag p `testBit` sq + && not (slide p `testBit` sq) + +isKingMoving :: Move -> MyPos -> Bool +isKingMoving m !p = isKingAt src p + where src = fromSquare m + +isPawnAt :: Square -> MyPos -> Bool +isPawnAt !sq !p = diag p `testBit` sq + && not (kkrq p `testBit` sq) + && not (slide p `testBit` sq) + +isPawnMoving :: Move -> MyPos -> Bool +isPawnMoving m !p = isPawnAt src p + where src = fromSquare m + +moveFromTo :: Square -> Square -> Move +moveFromTo f t = Move $ encodeFromTo f t + +fromColRow :: Int -> Int -> Square +fromColRow c r = r * 8 + c - 9 + +{-# INLINE other #-} +other :: Color -> Color +other White = Black +other Black = White + +{-# INLINE moving #-} +moving :: MyPos -> Color +moving !p = case epcas p .&. mvMask of + 0 -> White + _ -> Black + +-- The move is coded in currently 19 bits (the lower of a Word32) +-- So we need a few functions to handle them +-- With the new coding we actually need only 16 bits, but +-- the "special" attribute does not fit it, so we keep it +-- (on the same place, bit 18) +-- It can be replaced in the future with some function + +-- Normal move (from - to) +moveIsNormal :: Move -> Bool +moveIsNormal (Move m) = m .&. 0xE000 == 0 + +-- For which color is the move: +-- But, as for now, we don't set the move color! (And don't use it too) +moveColor :: Move -> Color +moveColor (Move m) = case testBit m 12 of + False -> White + _ -> Black + +-- Castles +moveIsCastle :: Move -> Bool +moveIsCastle (Move w) = w .&. 0xE000 == 0x8000 + +makeCastleFor :: Color -> Bool -> Move +makeCastleFor White True = makeCastle 0 +makeCastleFor White False = makeCastle 1 +makeCastleFor Black True = makeCastle 2 +makeCastleFor Black False = makeCastle 3 + +-- Codes are: 0 - kingside, white, 1 - queenside, white, +-- 2 - kingside, black, 3 - queenside, black +castleKing :: UArray Int Word32 +castleKing = listArray (0, 3) + [uncurry encodeFromTo ft `setBit` 15 | ft <- [(4, 6), (4, 2), (60, 62), (60, 58)]] + +{-# INLINE makeCastle #-} +makeCastle :: Int -> Move +makeCastle = Move . unsafeAt castleKing + +-- En passant: +moveIsEnPas :: Move -> Bool +moveIsEnPas (Move w) = w .&. 0x6000 == 0x4000 + +-- The location of the adverse pawn to delete: +moveEnPasDel :: Move -> Square +moveEnPasDel m@(Move w) = if testBit w 15 then src + 1 else src - 1 + where src = fromSquare m + +makeEnPas f t del = Move w2 + where w1 = encodeFromTo f t `setBit` 14 + w2 = if del == f - 1 then w1 else w1 `setBit` 15 + +-- Promotions: +transfCodes :: Array Int Piece +transfCodes = listArray (0, 3) [Knight, Bishop, Rook, Queen] +-- transfRev :: Array Piece Word32 +-- transfRev = array (Knight, Queen) +-- [(Knight, 0), (Bishop, 0x4000), (Rook, 0x8000), (Queen, 0xC000)] + +moveIsTransf :: Move -> Bool +moveIsTransf (Move w) = testBit w 13 + +moveTransfPiece (Move w) = transfCodes `unsafeAt` fromIntegral x + where x = (w `shiftR` 14) .&. 0x03 + +{-# INLINE makeTransf #-} +makeTransf :: Piece -> Square -> Square -> Move +makeTransf p f t = Move w + where !w = tc p .|. encodeFromTo f t .|. b13 + b13 = 1 `unsafeShiftL` 13 -- bit 13 + tc Queen = 0xC000 + tc Rook = 0x8000 + tc Bishop = 0x4000 + tc _ = 0 + +-- General functions for move encoding / decoding +encodeFromTo :: Square -> Square -> Word32 +encodeFromTo f t = fromIntegral t .|. (fromIntegral f `shiftL` 6) + +-- The type have to be only 2 bits (i.e. 0 to 3) +movetype :: Int -> Word32 -> Word32 +movetype t w = fromIntegral (t `shiftL` 12) .|. w + +-- code :: Word32 -> Word32 -> Word32 +-- code c w = (c `shiftL` 14) .|. w + +makeSpecial :: Move -> Move +makeSpecial (Move m) = Move $ m `setBit` 18 + +moveIsSpecial :: Move -> Bool +moveIsSpecial (Move m) = m `testBit` 18 + +fromSquare :: Move -> Square +fromSquare (Move m) = fromIntegral (m `shiftR` 6) .&. 0x3F + +toSquare :: Move -> Square +toSquare (Move m) = fromIntegral (m .&. 0x3F) + +checkCastle :: Move -> MyPos -> Move +checkCastle m p + | moveIsNormal m && isKingMoving m p + = if ds == 2 + then makeCastleFor c True + else if ds == -2 + then makeCastleFor c False + else m + | otherwise = m + where s = fromSquare m + d = toSquare m + ds = d - s + c = moving p + +checkEnPas :: Move -> MyPos -> Move +checkEnPas m p + | moveIsNormal m && isPawnMoving m p + = if (epcas p .&. epMask) `testBit` t then makeEnPas f t del else m + | otherwise = m + where f = fromSquare m + t = toSquare m + del = t + if moving p == White then -8 else 8 + +activateTransf :: Char -> Move -> Move +activateTransf b m = makeTransf p f t + where f = fromSquare m + t = toSquare m + p = chToPc b + chToPc 'q' = Queen + chToPc 'r' = Rook + chToPc 'b' = Bishop + chToPc 'n' = Knight + +toString :: Move -> String +toString m = col sc : row sr : col dc : row dr : transf + where s = fromSquare m + d = toSquare m + (sr, sc) = s `divMod` 8 + (dr, dc) = d `divMod` 8 + orda = ord 'a' + ord1 = ord '1' + col x = chr (orda + x) + row x = chr (ord1 + x) + transf = if moveIsTransf m then [pcToCh (moveTransfPiece m)] else [] + pcToCh Queen = 'q' + pcToCh Rook = 'r' + pcToCh Bishop = 'b' + pcToCh Knight = 'n'