{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields -fno-ignore-asserts -cpp -DGOGUI #-} {- A simple (no tree, no game-specific heuristics) Monte Carlo Go program. (snapshot of 18/03/2009) Claus Reinke Specification is that of the simplest computer Go mailing list reference bot, as outlined at the end of this message: http://computer-go.org/pipermail/computer-go/2008-October/016680.html Interface is a subset of the Go Text Protocol (GTP, version 2): http://www.lysator.liu.se/~gunnar/gtp/ (GoGui provides a nice set of tools for working with GTP-compatible programs, including graphical interface, bot-vs-bot, bot-vs-human, testing, statistics, ..) This is an all-in-one source file (to avoid getting lost, use your editor's fold mechanism (fold markers: {{{ and }}} ) and an extra wide window;-) To build: ghc --make SimpleGo.hs -funfolding-keeness-factor=4 -funfolding-creation-threshold=150 -funfolding-use-threshold=100 To bench (parameter is number of simulation runs): time (echo "genmove b" | ./SimpleGo.exe 10000 +RTS -s) On my laptop, I currently get ~3k/s simulation runs, which isn't bad but not good either (the Java refbot from the specification email gets ~7k/s, and Simon Marlow's Haskell implementation gets ~17k/s without mercy rule). Which explains why all of this code is still in flux, sometimes halfway between two experiments.. At least, SimpleGo gets about 50% wins against Jrefbot, over 200 games, so it seems to implement the spec more or less correctly whenever I do not mess it up.. (Jrefbot itself seems to have an issue with superko, which it runs into in about 3 out of 200 games). -} module Main(main) where import System.Random import System.IO import System.Environment import Text.Printf import Debug.Trace import Control.Exception import Data.Ord import Data.List import Data.Maybe import Data.Bits import qualified Data.IntSet as IS import qualified Data.Set as Set import qualified Data.IntMap as IM import qualified Data.Map as Map import Control.Monad import Control.Monad.ST import Data.Array.IArray import qualified Data.Array as A import qualified Data.Array.MArray as MA import qualified Data.Array.ST as ST import qualified Data.Array.IO as IOA import qualified GHC.Arr import qualified Data.Array.Base import qualified Data.Array.Vector as AV import Data.Word import Data.Int import System.Random.Mersenne.Pure64 import Data.Function import Data.Char import System.Exit import Control.OldException(assertions,errorCalls) ------------------------------------------------------ {{{ output displayMoves :: Int -> MoveMap s -> M s [String] displayMoves boardSize mvs = do mvs_elems <- getMoves mvs return $ map (concatMap showMove) $ segments boardSize $ mvs_elems where showMove m = printf "%4d" m displayMarks :: Int -> MoveMap s -> M s [String] displayMarks boardSize mvs = do mvs_marks <- getMarks mvs return $ map (concatMap (\m->if m then "#" else ".")) $ segments boardSize $ mvs_marks displayAvailableMoves :: Int -> Counts -> AvailableMoves s -> M s [String] displayAvailableMoves boardSize (Counts possible tried) availableMoves = do mvs <- MA.getElems availableMoves let (p,r) = splitAt possible mvs (t,_) = splitAt tried r mark pos | pos `elem` p = '.' | pos `elem` t = '?' | otherwise = 'X' return $ segments boardSize $ map mark [1..maxPos boardSize] displayBitMap :: Int -> Bitmap -> M s [String] displayBitMap boardSize bm = do let mark pos | bm `testBit` (2*pos+1) = '#' | bm `testBit` (2*pos) = 'o' | otherwise = '.' return $ segments boardSize $ map mark [1..maxPos boardSize] segments :: Int -> [t] -> [[t]] segments boardSize [] = [] segments boardSize ps = segment:segments boardSize rest where (segment,rest) = splitAt boardSize ps -- }}} ------------------------------------------------------ {{{ board & move representation type M s result = ST s result -- Monad for inplace array updates (IO or ST s) -- type MoveMap s = ST.STUArray s Pos MarkMove -- pos->last move on pos (+mark visited bit) type MoveMap s = AV.MUArr MarkMove s -- pos->last move on pos (+mark visited bit) type FlagMap s = AV.MUArr Flags s -- pos->flags type Move = Int -- 1..maxMoves type Pos = Int -- 1..maxPos type Flags = Word8 -- border | visited type Bitmap = Integer type History = Set.Set Bitmap type MarkMove = Int -- Word32 (movemask,highbit) = (2^31-1::MarkMove,31::Int) -- TODO: try separating move and bit maps update :: AvailableMoves s -> (Pos, Move) -> M s () map `update` (k,v) = MA.writeArray map k v updates :: AvailableMoves s -> [(Pos, Move)] -> M s () map `updates` list = mapM_ upd list where upd (k,v) = MA.writeArray map k v updateMove :: MoveMap s -> (Pos, Move) -> M s () map `updateMove` (k,v) = AV.writeMU map k v updateMoves :: MoveMap s -> [(Pos, Move)] -> M s () map `updateMoves` list = (mapM_ upd list) where upd (k,v) = AV.writeMU map k v setMark :: MoveMap s -> Pos -> M s () map `setMark` pos = do v <- AV.readMU map pos AV.writeMU map pos $! (v .|. bit highbit) clearMark :: MoveMap s -> Pos -> M s () map `clearMark` pos = do v <- AV.readMU map pos AV.writeMU map pos $! (v .&. movemask) clearMarks :: MoveMap s -> [Pos] -> M s () map `clearMarks` list = mapM_ (map `clearMark`) list testMark :: MarkMove -> Bool testMark mv = mv `testBit` highbit oddB :: Move -> Bool oddB m = m `testBit` 0 evenB :: Move -> Bool evenB m = not (m `testBit` 0) clearMoves :: MoveMap s -> [Pos] -> M s () map `clearMoves` list = mapM_ upd list where upd k = AV.writeMU map k 0 select :: AvailableMoves s -> Pos -> M s Move (!map) `select` (!elem) = MA.readArray map elem selectMove :: MoveMap s -> Pos -> M s Move (!map) `selectMove` (!elem) = liftM extractMove $ AV.readMU map elem selectMarkMove :: MoveMap s -> Pos -> M s MarkMove (!map) `selectMarkMove` (!elem) = AV.readMU map elem extractMove :: MarkMove -> Move extractMove mm = mm .&. movemask getAssocs :: MoveMap s -> M s [(Pos, Move)] getAssocs map = -- MA.getAssocs map >>= mapM (\(k,v)->return (k,extractMove v)) mapM (\p->AV.readMU map p >>= \m->return (p,extractMove m)) [1..AV.lengthMU map-1] getMoves :: MoveMap s -> M s [Move] getMoves map = -- MA.getElems map >>= mapM (return . extractMove) mapM (\p->AV.readMU map p >>= \m->return (extractMove m)) [1..AV.lengthMU map-1] getMarks :: MoveMap s -> M s [Bool] getMarks map = -- MA.getElems map >>= mapM (return . testMark) mapM (\p->AV.readMU map p >>= \m->return (testMark m)) [1..AV.lengthMU map-1] mkMoveMap :: Int -> M s (MoveMap s) mkMoveMap boardSize = do m <- AV.newMU (1+boardSize*boardSize) AV.unstreamMU m (emptyMovesS boardSize) return m -- emptyMovesS :: Int -> AV.Stream Move emptyMovesS = memo empty where empty s = AV.streamU $ AV.toU $ 0:[ 0 |i<-[0..s-1],j<-[0..s-1]] emptyMoves :: Int -> [(Pos,Move)] emptyMoves = memo empty where empty s = [(1+i+j*s,0)|i<-[0..s-1],j<-[0..s-1]] decodeMove :: Int -> Move -> (Int, Int) decodeMove boardSize mv = (ver+1,hor+1) where (ver,hor) = quotRem (mv-1) boardSize emptyBoard :: Int -> M s (MoveMap s) emptyBoard boardSize = do mvs <- mkMoveMap boardSize return $! mvs -- }}} ------------------------------------------------------{{{ move logic -- using memo seems a tick slower than hand-inlining it -- (4.7s -> 4.8/10k) check later whether that is real or noise -- hardcoding the size to 9 here (instead of everywhere) would get us from 3s->2.7s/10k {-# INLINE memo #-} memo :: (Int->a)->(Int->a) memo f = \boardSize ->IM.findWithDefault (f boardSize) boardSize fs where {-# NOINLINE fs #-} fs = IM.fromList [(s,f s)|s<-[9,13,19]] data Neighbours = Neighbours { orthogonal :: ! [(Pos,Neighbours)] , diagonal :: ! [Pos] , border :: ! Bool } -- cyclic, to represent state machine neighbourIndex = memo indices where indices boardSize = this where this = A.array (1,maxPos boardSize) [ init orth i j | i<-[0..boardSize-1], j<-[0..boardSize-1] ] init orth i j = (1+i+j*boardSize ,Neighbours { orthogonal = orth i j , diagonal = diag i j , border = i==0 || j==0 || i==(boardSize-1) || j==(boardSize-1) }) orth i j = [ (pos,dir!pos) | (i',j',dir) <- [(i,j-1,this),(i,j+1,this),(i-1,j,this),(i+1,j,this)] -- orth i j = [ (pos,dir!pos) | (i',j',dir) <- [(i,j-1,up),(i,j+1,down),(i-1,j,left),(i+1,j,right)] , i'>=0, i'=0, j'=0, i'=0, j'=0, i'=0, j'=0, i'=0, j'=0, i'=0, j'=0, i'=0, j' Bool -> Pos -> (Bool, [Pos]) -> MoveMap s -> M s Bool noEye :: EyeTest s noEye _ _ _ _ _ = return False -- only playouts need to avoid eyes -- Bruegmann; Monte Carlo Go; 1993 -- a field whose direct neighbours are all of the same color and whose diagonal -- neighbours contain no more than 1 stone of the opposite color (0 for border -- and corner fields) gobble :: EyeTest s gobble boardSize oddn pos directNbs@(free,opStrs) mvs = do let sameColour = null opStrs && not free Neighbours{diagonal=dnbs,border=border} = neighbourIndex boardSize `selectIndex` pos fewDiagOps0 [] = return True fewDiagOps0 (dnbp:dnbps) = do diagNb <- mvs `selectMove` dnbp if (diagNb/=0) && (oddB diagNb/=oddn) then fewDiagOps1 dnbps else fewDiagOps0 dnbps fewDiagOps1 [] = return True fewDiagOps1 (dnbp:dnbps) = do diagNb <- mvs `selectMove` dnbp if (diagNb/=0) && (oddB diagNb/=oddn) then return False else fewDiagOps1 dnbps if sameColour then if border then fewDiagOps1 dnbs else fewDiagOps0 dnbs else return False -- if all but one-point eyes have been filled in, scoring is easy; -- otherwise, result will be wrong! simpleScoreChinese :: Int -> MoveMap s -> M s (Int,Int) simpleScoreChinese boardSize board = do mvs_assocs <- getAssocs board let (eyes,stones) = partition ((==0).snd) mvs_assocs (blackS,whiteS) = partition (oddB . snd) stones eyeNbsPos = [ map fst $ orthogonal $ neighbourIndex boardSize `selectIndex` p | (p,_) <- eyes ] nbsList <- loop eyeNbsPos [] [] let (blackE,whiteE) = partition oddB [ nb | nbs@(nb:_) <- nbsList , assert (all (>0) nbs && (all oddB nbs || all evenB nbs)) True ] !sB = length blackE+length blackS !sW = length whiteE+length whiteS return (sB,sW) where loop [] [] enbs = return enbs loop (enbp:enbps) [] enbs = loop enbps enbp ([]:enbs) loop enbps (p:ps) (enb:enbs) = do x <- board `selectMove` p loop enbps ps ((x:enb):enbs) superko :: Bitmap -> History -> Bool superko pos history = pos `Set.member` history -- classify neighbouring positions: free - is there an empty field; opPos - opponent positions classify :: Move -> MoveMap s -> Bool -> [(Pos,Neighbours)] -> Bool-> [Pos] -> M s (Bool, [Pos]) classify !mv !mvs !oddn nbs free opPos = loop nbs free opPos where loop [] free opPos = return (free,opPos) loop ((p,_):ps) free opPos = do mvsp <- mvs `selectMove` p case mvsp of 0 -> loop ps True opPos str | oddn==oddB str -> loop ps free opPos str | otherwise -> loop ps free (p:opPos) -- follow string of same colour: Nothing - string has at least one liberty; Just ps - maximal string, no liberties follow :: Bool-> [Neighbours]-> Int -> MoveMap s-> [Pos]-> M s (Maybe [Pos]) -- follow oddmv nbs boardSize !mvs strPs | trace (show ("follow",oddmv,map (map fst . orthogonal) nbs,strPs)) False = undefined follow oddmv [] boardSize !mvs strPs = return (Just strPs) follow oddmv (nbs:ps) boardSize !mvs strPs = loop (orthogonal nbs) ps strPs where -- loop nbps ps strPs | trace (show ("loop",map fst nbps,map (map fst . orthogonal) ps,strPs)) False = undefined loop ((nbp,nbs):nbps) !ps !strPs = {-# CORE "follow_loop" #-} do nb <- mvs `selectMarkMove` nbp case () of _ | testMark nb -> loop nbps ps strPs _ | extractMove nb==0 -> mvs `clearMarks` strPs >> return Nothing _ | oddmv==oddB nb -> mvs `setMark` nbp >> loop nbps (nbs:ps) (nbp:strPs) _ | otherwise -> loop nbps ps strPs loop [] !ps !strPs = follow oddmv ps boardSize mvs strPs -- collect positions of non-safe opponent strings touching mv capture :: Move -> Bool -> [Pos] -> Int -> MoveMap s -> M s [Pos] -- capture mv evenn opPos boardSize board | trace (show ("capture",mv,evenn,opPos)) False = undefined capture mv evenn opPos boardSize board = do board `setMark` mv pos <- loop opPos [] board `clearMark` mv board `clearMoves` pos -- board `clearMarks` pos return pos where -- loop nbs opPos | trace (show ("loop",nbs,opPos)) False = undefined loop [] opPos = return opPos loop (nb:nbs) opPos | nb `elem` opPos = loop nbs opPos | otherwise = do board `setMark` nb opstr <- follow evenn [neighbourIndex boardSize `selectIndex` nb] boardSize board (nb:opPos) loop nbs $! maybe opPos id opstr nextBoardPosGobble = nextBoardPos gobble nextBoardPosNoEyeTest = nextBoardPos noEye {-# INLINE nextBoardPos #-} nextBoardPos :: EyeTest s -> Int -> Int -> Move -> MoveMap s -> M s (Either String [Pos]) nextBoardPos eyeTest = \boardSize !n !mv !board -> do let !oddn = oddB n !evenn = evenB n directNbs@(free,opPos) <- classify mv board oddn (orthogonal $ neighbourIndex boardSize `selectIndex` mv) False [] eye <- eyeTest boardSize oddn mv directNbs board if eye then return $ Left "gobble-style eye" else do board `updateMove` (mv,n) dead_opponent_positions <- capture mv evenn opPos boardSize board suicide <- if null dead_opponent_positions then do board `setMark` mv pos <- follow oddn [neighbourIndex boardSize `selectIndex` mv] boardSize board [mv] maybe (return False) (\pos->board `clearMarks` pos >> return True) pos else return False case () of _ | suicide -> board `updateMove` (mv,0) >> return (Left "suicide") _ | otherwise -> return (Right dead_opponent_positions) -- }}} ------------------------------------------------------{{{ move sequences type AvailableMoves s = ST.STUArray s Pos Move -- layout: |possible|tried|occupied| data Counts = Counts{possible :: !Int, tried :: !Int} deriving Show -- fill in empty board positions via random legal moves genMoveSequence :: forall s. Int -> Int -> PureMT -> Int -> Counts -> AvailableMoves s -> MoveMap s -> M s (Int, PureMT, [Move]) genMoveSequence !nmax !nstart !gen !boardSize !counts !availableMoves !board = do {-# CORE "genMoves" #-} genMoves nstart 0 [] gen counts where genMoves :: Int -> Int -> [Move] -> PureMT -> Counts -> M s (Int,PureMT,[Move]) genMoves !n !j done@(0:0:_) !gen !counts = return (n-1,gen,reverse done) genMoves !n !j done !gen !counts@(Counts possible _) | possible==0 = do counts <- recycle counts availableMoves [] genMoves (n+1) 0 (0:done) gen counts | n<=nmax = do (mv,gen,counts) <- getMoveCandidate gen counts availableMoves result <- nextBoardPosGobble boardSize n mv board either (\reason -> do genMoves n (j+1) done gen counts) (\captured -> do counts <- commitMove counts availableMoves counts <- recycle counts availableMoves captured genMoves (n+1) 0 (mv:done) gen counts) result | otherwise = trace ("WARNING: game length limit("++show nmax++") exceeded!") $ return (n-1,gen,reverse done) -- |..mv..p|..| -> |..p..|mv..| : move random candidate from possible to tried getMoveCandidate :: PureMT -> Counts -> AvailableMoves s -> M s (Move, PureMT, Counts) getMoveCandidate !gen !counts@(Counts possible tried) !availableMoves = do -- let !(!m,!gen') = {-# SCC "randomR" #-} {-# CORE "randomR" #-} randomR (1,possible) gen -- replacing randomR with randomInt gets us from 4.4s -> 2.9s /10k -- TODO: watch out for any ill effects of modulo on randomization let !(!m',!gen') = {-# SCC "randomR" #-} {-# CORE "randomR" #-} randomInt gen !m = (m' `mod` possible)+1 (mv,counts) <- setMoveCandidate m counts availableMoves return (mv,gen',counts) -- |..mv..p|..| -> |..p..|mv..| : move given candidate from possible to tried setMoveCandidate :: Move -> Counts -> AvailableMoves s -> M s (Move,Counts) setMoveCandidate !m !counts@(Counts possible tried) !availableMoves = do let !counts = Counts (possible-1) (tried+1) !mv <- availableMoves `select` m !p <- availableMoves `select` possible availableMoves `update` (m,p) availableMoves `update` (possible,mv) return (mv,counts) -- |..|mv..i| -> |..|i..|mv : move candidate from tried to occupied commitMove :: Counts -> AvailableMoves s -> M s Counts commitMove (Counts possible 1) availableMoves = return $! Counts possible 0 commitMove (Counts possible tried) availableMoves = do let !start = possible+1 !end = possible+tried mv <- availableMoves `select` start i <- availableMoves `select` end availableMoves `update` (start,i) -- no need to store occupied positions return $! (Counts possible (tried-1)) -- |..|..| -> |....captured|| : move all tried moves to possible, add in captured recycle :: Counts -> AvailableMoves s -> [Move] -> M s Counts recycle (Counts possible tried) availableMoves [] = return $! (Counts (possible+tried) 0) recycle (Counts possible tried) availableMoves captured = do let !n = length captured !all = possible+tried availableMoves `updates` (zip [all+1..all+n] captured) if n==1 -- ko candidate (ko or suicide) then return $! (Counts all 1) else return $! (Counts (all+n) 0) --}}} ------------------------------------------------------ {{{ playouts type Amaf s = ST.STUArray s Pos Int -- 3*p: scorecount, 3*p+1: hits, 3*p+2: scorediff displayAmaf :: Int -> Int -> Amaf s -> M s [String] displayAmaf boardSize games amaf = do amaf_elems <- MA.getElems amaf return $ map (concatMap showScore) $ segments (fromIntegral boardSize) $ scores amaf_elems where showScore 0 = " ......" showScore s = printf " %+.3f" ((fromIntegral s/fromIntegral games)::Float) scores [] = [] scores (s:h:shs) = s:scores shs data Score s = Score{gamesB:: !Int,gamesW:: !Int ,scoreB:: !Int,scoreW:: !Int ,games :: !Int,gameLength:: !Int ,amaf:: !(Amaf s) } mkAmaf :: Int -> M s (Amaf s) mkAmaf boardSize = do amaf <- MA.newArray (0,high) 0 loop 0 amaf where !high = 6*(boardSize*boardSize)+5 loop !i !amaf | i>high = return amaf | otherwise = do MA.writeArray amaf (i+3) $! minBound MA.writeArray amaf (i+4) $! maxBound loop (i+6) amaf modifyAmaf :: Move -> Amaf s -> Pos -> (Int->Int) -> Int -> M s () modifyAmaf !n !amaf (!elem) f !d = do MA.readArray amaf scorecount >>= \a->MA.writeArray amaf scorecount $! f a MA.readArray amaf hits >>= \a->MA.writeArray amaf hits $! succ a MA.readArray amaf scorediff >>= \a->MA.writeArray amaf scorediff $! d+a MA.readArray amaf scoremax >>= \a->MA.writeArray amaf scoremax $! d `max` a MA.readArray amaf scoremin >>= \a->MA.writeArray amaf scoremin $! d `min` a MA.readArray amaf movenr >>= \a->MA.writeArray amaf movenr $! n+a where index = 6*elem scorecount = index hits = index+1 scorediff = index+2 scoremax = index+3 scoremin = index+4 movenr = index+5 mkEmptyScore boardSize = do amaf <- mkAmaf boardSize return Score{games=0,gamesB=0,gamesW=0,scoreB=0,scoreW=0,gameLength=0,amaf=amaf} playouts :: Float -> Int -> Int -> Score s -> PureMT -> Int -> Int -> [(Pos,Move)] -> IS.IntSet -> [(Pos,Move)] -> Counts -> AvailableMoves s -> MoveMap s -> M s (Score s) playouts !komi !maxGames !n !score !gen boardSize nstart assocsBoard !occupied assocsAvailable !initCounts !availableMoves !board = loop n score gen availableMoves board where loop :: Int -> Score s -> PureMT -> AvailableMoves s -> MoveMap s -> M s (Score s) loop !n !score@Score{amaf=amaf} !gen !availableMoves !board | n>maxGames = return score | otherwise = do board `updateMoves` assocsBoard availableMoves `updates` assocsAvailable (sB,sW,len,gen,moves) <- playout gen boardSize nstart initCounts availableMoves board if null moves then return score -- no need to keep playing zero-length playouts; -- TODO: stop even earlier, no need to play >n playouts of n possible move sequences else do let !scoreDiff = sB-sW !scoreDiffF= fromIntegral (sB-sW) !blackWin = scoreDiffF > komi !whiteWin = scoreDiffF < komi {- !scoreGames | blackWin = score{gamesB=gamesB score+1} | whiteWin = score{gamesW=gamesW score+1} | otherwise = score !score' = scoreGames{scoreB=scoreB score+sB ,scoreW=scoreW score+sW ,gameLength=len+gameLength score ,games=1+games score } -} -- neutral black/white view of the game; we adjust for player later, when interpreting amaf results upd | blackWin = 1 | whiteWin = -1 | otherwise = 0 scoreAmaf !n !amaf done [] = return () scoreAmaf !n !amaf done [m] = do unless (m `IS.member` done) $ modifyAmaf n amaf m (upd+) (upd*scoreDiff) scoreAmaf !n !amaf done (pl:op:ms) = do unless (pl `IS.member` done) $ modifyAmaf n amaf pl (upd+) (upd*scoreDiff) scoreAmaf (n+1) amaf (pl `IS.insert` (op `IS.insert` done)) ms scoreAmaf nstart amaf occupied moves loop (n+1) score gen availableMoves board playout :: PureMT -> Int -> Int -> Counts -> AvailableMoves s -> MoveMap s -> M s (Int, Int, Int, PureMT, [Move]) playout gen boardSize nstart counts availableMoves board = do (len,gen,moves) <- genMoveSequence (maxMoves boardSize) nstart gen boardSize counts availableMoves board (scoreB,scoreW) <- simpleScoreChinese boardSize board return (scoreB,scoreW,len,gen,moves) -- }}} ------------------------------------------------------ {{{ main maxPos,maxMoves::Int -> Int maxPos boardSize = boardSize*boardSize maxMoves boardSize = maxPos boardSize*3 -- maximum no of moves (excluding passes); superko alone could go on longer, -- avoiding eye-filling should stop earlier (how often doesn't it, though?) outDir = "out" main = do [maxGamesS] <- getArgs let maxGames = (read maxGamesS)::Int input <- getContents gtps <- stToIO emptyGtpState hSetBuffering stdout LineBuffering foldM (flip gtp) gtps{maxGames=maxGames} (lines input) -- }}} ------------------------------------------------------ {{{ gtp name = "SimpleGo" version = "0" data GtpState s = GtpState { boardSize :: !Int , board :: !(MoveMap s) , boardBM :: !Bitmap , history :: !(Set.Set Bitmap) , prisonersB:: !Int , prisonersW:: !Int , move :: !Int , moves :: ![Pos] , komi :: !Float -- , time :: ?? , maxGames :: !Int } emptyGtpState = do mvs <- mkMoveMap 9 return GtpState { boardSize = 9 , board = mvs , boardBM = 0 , history = Set.empty , prisonersB= 0 , prisonersW= 0 , move = 1 , moves = [] , komi = 0.5 , maxGames = 1000 } gtp l state = maybe (gtp_error "unknown command">>return state) (\a->a args state) mb_action where (command:args) = words l mb_action = command `lookup` gtp_api #ifdef GOGUI gtp_comment response = hPutStr stderr $ "TEXT "++response++"\n" #else gtp_comment response = putStr $ "# "++response++"\n" #endif gtp_error response = putStr $ "? "++response++"\n\n" gtp_response response = putStr $ "= "++response++"\n\n" gtp_responses responses = putStr $ "= "++unlines responses++"\n" #ifdef GOGUI gtp_gogui_gfx cmd = hPutStrLn stderr ("gogui-gfx: "++cmd) #else gtp_gogui_gfx cmd = return () #endif gtp_coords size mv = ((labels!!(hor-1)):show (size+1-ver)) where (ver,hor) = decodeMove size mv labels = take size $ filter (/='i') ['a'..'z'] gtp_record_move mv captured state@GtpState{boardSize=s,prisonersB=pB,prisonersW=pW,move=n,moves=mvs,boardBM=bm,history=h} | odd n = do let bm' = (foldl' (\bm p->bm `clearBit` (2*p)) bm captured) `setBit` (2*mv+1) if bm' `Set.member` h then return $ Left "positional superko violation!" else do dBM <- displayBitMap s bm' return $ Right state{prisonersB=pB+length captured,move=n+1,moves=mv:mvs ,boardBM=bm',history= bm' `Set.insert` h} | otherwise = do let bm' = (foldl' (\bm p->bm `clearBit` (2*p+1)) bm captured) `setBit` (2*mv) if bm' `Set.member` h then return $ Left "positional superko violation!" else do dBM <- displayBitMap s bm' return $ Right state{prisonersW=pW+length captured,move=n+1,moves=mv:mvs ,boardBM=bm',history= bm' `Set.insert` h} gtp_restore n mv captured board = board `updateMoves` ((mv,0):zip captured (repeat (n-1))) gtp_play (c:m:_) state@GtpState{boardSize=s,board=b,prisonersB=pB,prisonersW=pW ,move=n,moves=mvs,boardBM=bm,history=h} = do let -- color | map toLower c `elem` ["w","white"] = White -- | map toLower c `elem` ["b","black"] = Black -- TODO - use extra bit instead of odd/even for player id, respect 'c' here case map toLower m of m | m=="pass" -> do gtp_response "" return state{move=n+1,moves=0:mvs} (l:dd) | l `elem` labels && dd `elem` map show [1..s] -> do let Just hor = lookup l (zip labels [1..s]) ver = read dd::Int mv = (s-ver)*s+hor result <- stToIO (nextBoardPosNoEyeTest s n mv b) either (\reason ->do gtp_error ("cannot play "++unwords [c,m]++": "++reason) return state) (\captured->do result <- stToIO (gtp_record_move mv captured state) either (\e->gtp_error ("cannot play "++unwords [c,m]++": "++e) >> return state) (\state->gtp_response "" >> return state) result ) result | otherwise -> do gtp_error $ "cannot play "++unwords [c,m] return state where labels = take s $ filter (/='i') ['a'..'z'] gtp_genmove (c:_) state@GtpState{boardSize=s,board=b,komi=k,prisonersB=pB,prisonersW=pW ,move=n,moves=mvs,maxGames=maxGames,boardBM=bm,history=h} = do -- TODO - use extra bit instead of odd/even for player id, make 'c' here -- affect move color, not just move sorting order -- gen <- getStdGen -- default randoms gen <- newPureMT -- mersenne twister amaf <- stToIO (do assocs <- getAssocs b let occupied = IS.fromList [ pos | (pos,mv) <- assocs, mv>0 ] availableMoves <- MA.newArray (1,maxPos s) 0 let initAvailable !i !o !assocsAvailable ((m,0):ms) = initAvailable (i+1) o ((i,m):assocsAvailable) ms initAvailable !i !o !assocsAvailable ((m,_):ms) = initAvailable i (o-1) ((o,m):assocsAvailable) ms initAvailable !i !o !assocsAvailable [] = return (Counts (i-1) 0,assocsAvailable) (!counts,!assocsAvailable) <- initAvailable 1 (maxPos s) [] assocs emptyScore <- mkEmptyScore s Score{amaf=amaf} <- playouts k maxGames 1 emptyScore gen s (length mvs+1) assocs occupied assocsAvailable counts availableMoves =<< emptyBoard s return amaf) amafAssocs <- stToIO (MA.getAssocs amaf) let tuples [] = [] tuples ((m,s):(_,h):(_,d):(_,ma):(_,mi):(_,mnr):shs) = (m `div` 6,(s,h,d,ma,mi,mnr)):tuples shs amafScores = [ (m,fromIntegral s/fromIntegral h::Double ,fromIntegral d/fromIntegral h::Double ,ma,mi ,fromIntegral mnr/fromIntegral h::Double) | (m,(s,h,d,ma,mi,mnr)) <- tuples amafAssocs, h>0 ] show_score 0 score d ma mi mnr = printf "pass - amaf-score: %.3f (%.3f %d %d %.3f)" score d ma mi mnr show_score m score d ma mi mnr = printf "%s - amaf-score: %.3f (%.3f %d %d %.3f)" (gtp_coords s m) score d ma mi mnr playerBlack = map toLower c `elem` ["b","black"] forPlayer c | playerBlack = compare `on` (\(_,s,_,_,_,_)->negate s) | otherwise = compare `on` (\(_,s,_,_,_,_)->s) -- try next-best amaf-scored move, until none left, then pass next_best [] = gtp_response "PASS" >> return state{move=n+1,moves=0:mvs} next_best ((0,score,_,_,_,_):scores) = next_best scores -- next_best ((0,score,d):scores) = do -- unless (null scores) $ gtp_comment (show_score 0 score d) -- gtp_response "PASS" >> return state{move=n+1,moves=0:mvs} next_best scores@((mv,score,d,ma,mi,mnr):_) = do mapM_ (\(mv,sc,d,ma,mi,mnr)->gtp_comment (show_score mv sc d ma mi mnr)) $ take 10 scores ((mv,score,d,ma,mi,mnr):scores) <- case span (\(_,s,_,_,_,_)->s==score) scores of ([_], rest) -> return scores (equivalent0,rest) -> do let equivalent = filter (\(m,_,_,_,_,_)->m/=0) equivalent0 r <- {-# SCC "randomRIO" #-} randomRIO (1,length equivalent) let (a,(mv,score,d,ma,mi,mnr):b) = splitAt (r-1) equivalent return ((mv,score,d,ma,mi,mnr):(a++b++rest)) -- need to check mv for suicide,etc.! -- non-occupied position, can be become playable later in playouts, hence amaf-rated.. result <- stToIO (nextBoardPosGobble s n mv b) either (\reason ->do gtp_comment (show_score mv score d ma mi mnr++" not possible: "++reason) next_best scores) (\captured->do result <- stToIO (gtp_record_move mv captured state) either (\reason->do gtp_comment (show_score mv score d ma mi mnr++" not possible: "++reason) stToIO (gtp_restore n mv captured b) next_best scores) (\state->do gtp_comment (show_score mv score d ma mi mnr++" selected") if (playerBlack&&score== -1)||(not playerBlack&&score==1) then do gtp_response "RESIGN"; return state else do gtp_response (gtp_coords s mv); return state) result ) result next_best $ sortBy (forPlayer c) amafScores gtp_commands = map fst gtp_api gtp_api = [("protocol_version",\_ state->do gtp_response "2"; return state) ,("name", \_ state->do gtp_response name; return state) ,("version", \_ state->do gtp_response version; return state) ,("known_command", \(c:_) state->do gtp_response (map toLower (show (c `elem` gtp_commands))) return state) ,("list_commands", \_ state->do gtp_responses gtp_commands; return state) ,("quit", \_ state->do gtp_response ""; exitWith ExitSuccess) ,("boardsize", \(s:_) state->do gtp_response ""; return state{boardSize=read s}) ,("clear_board", \_ state->do gtp_response "" mvs <- stToIO (mkMoveMap (boardSize state)) return state{board=mvs,prisonersB=0,prisonersW=0,move=1,moves=[],boardBM=0,history=Set.empty}) ,("komi", \(s:_) state->do gtp_response ""; return state{komi=read s}) -- fixed_handicap number_of_stones -- place_free_handicap number_of_stones -- set_free_handicap vertices ,("play", gtp_play ) ,("genmove", gtp_genmove ) -- undo -- time_settings main_time byo_time byo_stones -- time_left color time stones ,("final_score", \_ state@GtpState{boardSize=s,board=b,komi=k,prisonersB=pB,prisonersW=pW ,move=n,moves=mvs}->do result <- tryJust assertions $ stToIO (simpleScoreChinese s b) let score (sB,sW) = case fromIntegral sB-(fromIntegral sW+k) of score | score>0 -> "B+"++show score | score<0 -> "W+"++show (negate score) | otherwise -> "0" either (\_->gtp_error "cannot score") (\s->gtp_response (score s)) result return state ) -- final_status_list -- load_sgf filename move_number -- reg_genmove color ,("showboard", \_ state@GtpState{boardSize=s,board=b,prisonersB=pB,prisonersW=pW ,move=n,moves=mvs}->do dm <- stToIO $ displayMoves s b gtp_responses (printf "next move: %d - prisoners: (%d/%d)" n pB pW:dm) return state ) -- ref-playouts -- ref-score -- ref-nodes ] -- }}}