{-# 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 30/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 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.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) ------------------------------------------------------ {{{ 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 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 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 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 -> Neighbours -> MoveMap s -> M s a -> M s a -> M s a noEye :: EyeTest s a noEye _ _ _ _ _ _ isNoEye = isNoEye -- 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) {-# INLINE gobble #-} gobble :: EyeTest s a gobble boardSize oddn pos (Neighbours{orthogonal=nbs,diagonal=dnbs,border=border}) mvs isEye isNoEye = do let -- sameColour = null opStrs && not free sameColour [] = return True sameColour ((p,_):ps) = do mvsp <- mvs `selectMove` p if (mvsp==0) || (oddn/=oddB mvsp) then return False else sameColour ps fewDiagOps0 (dnbp:dnbps) = do diagNb <- mvs `selectMove` dnbp if (diagNb/=0) && (oddB diagNb/=oddn) then fewDiagOps1 dnbps else fewDiagOps0 dnbps fewDiagOps0 [] = isEye fewDiagOps1 (dnbp:dnbps) = do diagNb <- mvs `selectMove` dnbp if (diagNb/=0) && (oddB diagNb/=oddn) then isNoEye else fewDiagOps1 dnbps fewDiagOps1 [] = isEye sc <- sameColour nbs if sc then if border then fewDiagOps1 dnbs else fewDiagOps0 dnbs else isNoEye -- }}} -- 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 -- follow string of same colour: Nothing - string has at least one liberty; Just ps - maximal string, no liberties follow :: Bool-> [Neighbours]-> MoveMap s-> [Pos]-> M s (Maybe [Pos]) follow oddmv [] !mvs strPs = mvs `clearMarks` strPs >> return (Just strPs) follow oddmv (nbs:ps) !mvs strPs = loop (orthogonal nbs) ps strPs where loop ((nbp,nbs):nbps) !ps !strPs = {-# CORE "follow_loop" #-} do nb <- mvs `selectMarkMove` nbp case () of _ | extractMove nb==0 -> mvs `clearMarks` strPs >> return Nothing _ | (testMark nb) || (oddmv/=oddB nb) -> loop nbps ps strPs _ | otherwise -> mvs `setMark` nbp >> loop nbps (nbs:ps) (nbp:strPs) loop [] !ps !strPs = follow oddmv ps mvs strPs -- collect positions of non-safe opponent strings touching mv {-# INLINE capture #-} capture :: Move -> Bool -> Int -> MoveMap s -> M s [Pos] capture mv evenn boardSize board = do board `setMark` mv loop (orthogonal $ neighbourIndex boardSize `selectIndex` mv) [] where loop ((nbp,_):nbps) opPos | nbp `elem` opPos = loop nbps opPos | otherwise = do nb <- board `selectMarkMove` nbp if (testMark nb) || (extractMove nb==0) || (evenn/=oddB nb) then loop nbps opPos else do board `setMark` nbp opstr <- follow evenn [neighbourIndex boardSize `selectIndex` nbp] board (nbp:opPos) loop nbps $! maybe opPos id opstr loop [] opPos = do board `clearMark` mv board `clearMoves` opPos {- board `clearMarks` opPos -} return opPos {-# INLINE nextBoardPosGobble #-} nextBoardPosGobble = nextBoardPos gobble {-# INLINE nextBoardPosNoEyeTest #-} nextBoardPosNoEyeTest = nextBoardPos noEye {-# INLINE nextBoardPos #-} nextBoardPos :: EyeTest s a -> Int -> Int -> Move -> MoveMap s -> (String -> M s a) -> ([Pos] -> M s a) -> M s a nextBoardPos eyeTest = \boardSize !n !mv !board left right -> do let !oddn = oddB n; !evenn = evenB n eyeTest boardSize oddn mv (neighbourIndex boardSize `selectIndex` mv) board (left "gobble-style eye") (do board `updateMove` (mv,n) dead_opponent_positions <- capture mv evenn boardSize board suicide <- if null dead_opponent_positions then do board `setMark` mv pos <- follow oddn [neighbourIndex boardSize `selectIndex` mv] board [mv] maybe (return False) (const $ return True) pos else return False case () of _ | suicide -> board `updateMove` (mv,0) >> left "suicide" _ | otherwise -> right dead_opponent_positions) -- }}} ------------------------------------------------------{{{ move sequences type AvailableMoves s = ST.STUArray s Pos Move -- {{{ (layout: |possible|tried|occupied|) 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] 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 select :: AvailableMoves s -> Pos -> M s Move (!map) `select` (!elem) = MA.readArray map elem -- }}} 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 nextBoardPosGobble boardSize n mv board (\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) | 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 -- {{{ (6*p: scorecount, +1: hits, +2: scorediff, +3: scoremax, +4: scoremin, +5: movenr) displayAmaf :: ((String,String,String,String,String,String)->String) -> Int -> Amaf s -> M s [String] displayAmaf select boardSize amaf = do amaf_elems <- MA.getElems amaf return $ map concat $ segments (fromIntegral boardSize) $ tail $ scores amaf_elems where scaled 0 h = " ......." scaled s h = printf " %+07.3f" ((fromIntegral s/fromIntegral h)::Float) raw d = printf " %7d" d scores [] = [] scores (s:h:d:ma:mi:nr:shs) = select (scaled s h,raw h,scaled d h,raw ma,raw mi,scaled nr h):scores shs mkAmaf :: Int -> M s (Amaf s) mkAmaf boardSize = MA.newArray (0,high) 0 where !high = 6*(boardSize*boardSize)+5 modifyAmaf :: Move -> Amaf s -> Pos -> Int -> Int -> Int -> M s () modifyAmaf !n !amaf (!elem) !sign !win !d = do MA.readArray amaf scorecount >>= \a->MA.writeArray amaf scorecount $! sign*win+a MA.readArray amaf hits >>= \a->MA.writeArray amaf hits $! succ a MA.readArray amaf scorediff >>= \a->MA.writeArray amaf scorediff $! sd+a MA.readArray amaf scoremax >>= \a->MA.writeArray amaf scoremax $! sd `max` a MA.readArray amaf scoremin >>= \a->MA.writeArray amaf scoremin $! sd `min` a MA.readArray amaf movenr >>= \a->MA.writeArray amaf movenr $! n+a where sd = sign*d index = 6*elem scorecount = index hits = index+1 scorediff = index+2 scoremax = index+3 scoremin = index+4 movenr = index+5 -- }}} data Playout s = Playout{ -- gamesB:: !Int,gamesW:: !Int --,scoreB:: !Int,scoreW:: !Int --,games :: !Int,gameLength:: !Int amaf :: !(Amaf s) ,gen :: !PureMT ,counts :: !Counts ,availableMoves :: !(AvailableMoves s) ,board :: !(MoveMap s) } initPlayout boardSize gen counts availableMoves board = do amaf <- mkAmaf boardSize return Playout{ -- games=0,gamesB=0,gamesW=0,scoreB=0,scoreW=0,gameLength=0 amaf=amaf,gen=gen,counts=counts,availableMoves=availableMoves,board=board} playouts :: Bool -> Float -> Int -> Int -> Playout s -> Int -> Int -> [(Pos,Move)] -> IS.IntSet -> [(Pos,Move)] -> M s (Playout s) playouts !playerBlack !komi !maxGames !n !state boardSize nstart assocsBoard !occupied assocsAvailable = loop n state where loop :: Int -> Playout s -> M s (Playout s) loop !n !state@Playout{amaf=amaf,gen=gen,counts=initCounts,availableMoves=availableMoves,board=board} | n>maxGames = return state | 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 state -- 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 = state{gamesB=gamesB state+1} | whiteWin = state{gamesW=gamesW state+1} | otherwise = state !state' = scoreGames{scoreB=scoreB state+sB ,scoreW=scoreW state+sW ,gameLength=len+gameLength state ,games=1+games state } -} -- neutral black/white view adjusted for player sign | playerBlack = 1 | otherwise = -1 win | 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 sign win scoreDiff scoreAmaf !n !amaf done (pl:op:ms) = do unless (pl `IS.member` done) $ modifyAmaf n amaf pl sign win scoreDiff scoreAmaf (n+1) amaf (pl `IS.insert` (op `IS.insert` done)) ms scoreAmaf nstart amaf occupied moves loop (n+1) state{gen=gen} 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 , boardGTP :: !(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 , boardGTP = 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,boardGTP=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 (return.Left) (return.Right)) 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,boardGTP=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 let playerBlack = map toLower c `elem` ["b","black"] -- 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 <- initPlayout s gen counts availableMoves =<< emptyBoard s Playout{amaf=amaf} <- playouts playerBlack k maxGames 1 emptyScore s (length mvs+1) assocs occupied assocsAvailable sd <- displayAmaf (\(s,_,d,_,_,_)->s++":"++d) s amaf hnr <- displayAmaf (\(_,h,_,_,_,nr)->h++":"++nr) s amaf trace (unlines $ concat $ zipWith (\x->(x:).(:[])) sd hnr) $ return () da <- displayAmaf (\(_,_,_,ma,mi,_)->ma++":"++mi) s amaf trace (unlines da) $ return () 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,h,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 h score d ma mi mnr = printf "pass - amaf-score: %.3f (%.3f %d %d %d %.3f)" score d h ma mi mnr show_score m h score d ma mi mnr = printf "%s - amaf-score: %.3f (%.3f %d %d %d %.3f)" (gtp_coords s m) score d h ma mi mnr forPlayer c = compare `on` (\(_,_,s,_,_,_,_)->negate 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,h,score,d,ma,mi,mnr):_) = do mapM_ (\(mv,h,sc,d,ma,mi,mnr)->gtp_comment (show_score mv h sc d ma mi mnr)) $ take 10 scores ((mv,h,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,h,score,d,ma,mi,mnr):b) = splitAt (r-1) equivalent return ((mv,h,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 (return.Left) (return.Right)) either (\reason ->do gtp_comment (show_score mv h 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 h 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 h score d ma mi mnr++" selected") if 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{boardGTP=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,boardGTP=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,boardGTP=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 ] -- }}}