Windows build & fixes

[jimablett]

Hi,

I've managed to build a working Windows executable >

Engine & fixed src

Proton link:
https://drive.proton.me/urls/VDDRMXZRXC#3lZeyMtEn1So

Smash link:
https://fromsmash.com/Trout10JA

I had uci parsing errors and divide by zero errors which needed fixing to produce a working executable.

Here are the fixed files.

Uci.hs

module Trout.Uci (doUci, UciState (..), newUciState) where

import Control.Concurrent
  ( MVar,
    ThreadId,
    forkIO,
    killThread,
    newEmptyMVar,
    newMVar,
    putMVar,
    readMVar,
    swapMVar,
    tryReadMVar,
    tryTakeMVar,
  )
import Control.Exception (evaluate)
import Control.Monad.ST (RealWorld, stToIO)
import Control.Monad.Trans.Reader (ReaderT (runReaderT))
import Data.Bifunctor (first, second)
import Data.Foldable (foldl')
import Data.Function ((&))
import Data.Int (Int16)
import Data.Maybe (fromMaybe)
import System.IO (hFlush, hPutStrLn, stderr, stdout)
import System.Timeout (timeout)
import Text.Printf (printf)
import Text.Read (readEither)
import Trout.Fen.Parse (fenToGame)
import Trout.Game
  ( Game (..),
    allMoves,
    gameBoard,
    makeMove,
    startingGame,
  )
import Trout.Game.Board (boardTurn)
import Trout.Game.Move
  ( Move (..),
    SpecialMove (Promotion),
    uciShowMove,
  )
import Trout.Piece (Color (..))
import Trout.Search (SearchEnv, bestMove, clearEnv, newEnv, pvWalk)
import Trout.Search.TranspositionTable (sizeOfEntry)
import Trout.Uci.Parse
  ( CommGoArg (..),
    CommPositionInit (..),
    UciCommand (..),
    UciMove (..),
    readUciLine,
  )

data UciState = UciState
  { uciGame :: Game,
    uciIsDebug :: Bool,
    uciSearch :: Maybe (ThreadId, MVar Move),
    uciSearchEnv :: MVar (SearchEnv RealWorld)
  }

-- Safe division function that handles divide-by-zero and overflow
safeQuot :: Int -> Int -> Int
safeQuot _ 0 = 0
safeQuot n d 
  | d == -1 && n == minBound = maxBound  -- Handle overflow case
  | otherwise = n `quot` d

newUciState :: IO UciState
newUciState = do
  let entrySize = sizeOfEntry
      hashSize = if entrySize <= 0 
                 then 1000  -- Fallback if sizeOfEntry is 0 or negative
                 else 16000000 `safeQuot` entrySize
  searchEnv <- stToIO (newEnv (max 1 hashSize)) >>= newMVar
  pure $ UciState startingGame False Nothing searchEnv

modUciStateHash :: Int -> UciState -> IO UciState
modUciStateHash hashMB state = do
  let entrySize = sizeOfEntry
  if entrySize <= 0
    then do
      hPutStrLn stderr "Error: Transposition table entry size is zero or negative, cannot set hash."
      pure state
    else do
      let newHashSize = max 1 (hashMB * 1000000 `safeQuot` entrySize)
      newSearchEnv <- stToIO (newEnv newHashSize)
      var <- newMVar newSearchEnv
      pure $ state {uciSearchEnv = var}

data PlayerTime = PlayerTime
  { playerTime :: Int,
    playerInc :: Int
  }
  deriving (Eq, Show)

data GoSettings = GoSettings
  { goMovetime :: Maybe Int,
    goTimes :: (Int, Int),
    goIncs :: (Int, Int),
    goMaxDepth :: Int
  }
  deriving (Show)

defaultSettings :: GoSettings
defaultSettings =
  GoSettings
    { goMovetime = Nothing,
      goTimes = (maxBound, maxBound),
      goIncs = (0, 0),
      goMaxDepth = maxBound
    }

reportMove :: MVar Move -> IO ()
reportMove moveVar = do
  moveMaybe <- tryTakeMVar moveVar
  let move = uciShowMove (fromMaybe NullMove moveMaybe)
  putStrLn ("bestmove " ++ move)
  hFlush stdout

-- Extract time calculation to a separate function for better debugging
calculateTimeMs :: Maybe Int -> (Int, Int) -> (Int, Int) -> Game -> Int
calculateTimeMs movetime times incs game = 
  max 1000 $ fromMaybe defaultTime movetime
  where
    defaultTime = 
      let currentTime = getter times
          currentInc = getter incs
          baseTime = if currentTime == maxBound || currentTime <= 0
                    then 30000  -- Default 30 seconds if maxBound or invalid
                    else max 1000 (currentTime `safeQuot` 20)
          incTime = if currentInc < 0 then 0 else currentInc `safeQuot` 2
          totalTime = baseTime + incTime
      in max 1000 totalTime  -- Ensure positive result, minimum 1 second
    
    getter = case boardTurn (gameBoard game) of
      White -> fst
      Black -> snd

launchGo :: MVar Move -> MVar (SearchEnv RealWorld) -> Game -> GoSettings -> IO ()
launchGo moveVar ssVar game (GoSettings movetime times incs maxDepth) = do
  let timeMs = calculateTimeMs movetime times incs game
      -- Convert to microseconds safely, avoiding overflow
      timeoutMicros = if timeMs > (maxBound `safeQuot` 1000)
                      then maxBound `safeQuot` 2  -- Large but safe value
                      else timeMs * 1000
  _ <- timeout timeoutMicros (searches (1 :: Int))
  reportMove moveVar
  where
    searches depth
      | depth <= fromIntegral maxDepth && depth > 0 = do
          stateVec <- readMVar ssVar
          result <- stToIO (runReaderT (bestMove (fromIntegral depth) game) stateVec)
          case result of
            (score, move) -> do
              _ <- evaluate score
              _ <- tryTakeMVar moveVar
              putMVar moveVar move
              _ <- swapMVar ssVar stateVec
              pv <- stToIO (runReaderT (pvWalk game) stateVec)
              let pvMoves = foldr (\a str -> ' ' : (uciShowMove a ++ str)) "" pv
              let pvStr = if null pvMoves then "" else " pv" ++ pvMoves
              -- Use putStrLn instead of printf to avoid potential format issues
              putStrLn $ "info depth " ++ show depth ++ " score cp " ++ show score ++ pvStr
              hFlush stdout
              searches (depth + 1)
      | otherwise = pure ()

doUci :: UciState -> IO ()
doUci uciState = do
  line <- getLine
  let command = readUciLine line
  case command of
    Right CommUci -> do
      putStrLn "id name Trout"
      putStrLn "id author Osrepnay"
      putStrLn $ "option name Hash type spin default 16 min 1 max " ++ show (min 1000000 (maxBound `safeQuot` 1000000) :: Int)
      putStrLn "uciok"
      hFlush stdout
      doUci uciState
    Right (CommDebug debug) -> doUci (uciState {uciIsDebug = debug})
    Right CommDont -> do
      putStrLn "miss the annual ShredderChess Annual Barbeque"
      hFlush stdout
      doUci uciState
    Right CommIsready -> do
      putStrLn "readyok"
      hFlush stdout
      doUci uciState
    Right (CommSetoption name value) -> do
      uciState' <- case name of
        "Hash" -> case readEither value of
          Left err -> do
            hPutStrLn stderr err
            pure uciState
          Right hashMB -> if hashMB > 0 
                         then modUciStateHash hashMB uciState
                         else do
                           hPutStrLn stderr "Hash size must be positive"
                           pure uciState
        _ -> do
          hPutStrLn stderr $ "option not supported: " ++ name
          hFlush stderr
          pure uciState
      doUci uciState'
    Right (CommRegister _) -> doUci uciState
    Right CommUcinewgame -> do
      let envMVar = uciSearchEnv uciState
      maybeEnv <- tryReadMVar envMVar
      case maybeEnv of
        Just env -> stToIO (clearEnv env)
        Nothing -> pure ()
      doUci $
        uciState {uciGame = startingGame}
    Right (CommPosition posInit moves) ->
      let ng = case posInit of
            PositionStartpos -> startingGame
            PositionFen fen -> fenToGame fen
       in case playMoves ng moves of
            Left err -> do
              hPutStrLn stderr err
              hFlush stderr
              doUci uciState
            Right game -> do
              doUci (uciState {uciGame = game})
    Right (CommGo args) -> do
      goVar <- newEmptyMVar
      let ssVar = uciSearchEnv uciState
      thread <-
        forkIO $
          launchGo
            goVar
            ssVar
            (uciGame uciState)
            (foldl' (&) defaultSettings (doGoArg <$> args))
      doUci
        ( uciState
            { uciSearch = Just (thread, goVar),
              uciSearchEnv = ssVar
            }
        )
    Right CommStop -> case uciSearch uciState of
      Just (searchId, moveVar) -> do
        killThread searchId
        reportMove moveVar
        doUci uciState
      Nothing -> doUci uciState
    Right CommQuit -> pure ()
    Right CommInfo -> doUci uciState
    Left err -> do
      hPutStrLn stderr err
      doUci uciState
    _ -> doUci uciState
  where
    playMoves g [] = Right g
    playMoves g ((UciMove from to promote) : ms) = case gMoves of
      (move : _) -> case makeMove g move of
        Just ng -> playMoves ng ms
        Nothing -> Left "illegal move"
      [] -> Left "ILLEGAL move"
      where
        moveMatches (Move _ (Promotion p) f t) =
          Just p == promote
            && f == from
            && t == to
        moveMatches (Move _ _ f t) = f == from && t == to
        gMoves = filter moveMatches (allMoves (gameBoard g))
    doGoArg arg gs@(GoSettings mt ts is depth) = case arg of
      GoSearchMoves _ -> gs
      GoPonder -> gs
      GoWtime t -> GoSettings mt (first (const (max 0 t)) ts) is depth
      GoWinc i -> GoSettings mt ts (first (const (max 0 i)) is) depth
      GoBtime t -> GoSettings mt (second (const (max 0 t)) ts) is depth
      GoBinc i -> GoSettings mt ts (second (const (max 0 i)) is) depth
      GoMovestogo _ -> gs
      GoDepth d -> GoSettings mt ts is (max 1 (fromIntegral d))
      GoNodes _ -> gs
      GoMate _ -> gs
      GoMovetime m -> GoSettings (Just (max 1000 m)) ts is depth
      GoInfinite -> GoSettings (Just maxBound) ts is depth

Parse.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use lambda-case" #-}
module Trout.Uci.Parse
  ( CommPositionInit (..),
    CommGoArg (..),
    UciCommand (..),
    UciMove (..),
    parseUciCommand,
    readUciLine,
  )
where

import Data.Bifunctor (Bifunctor (first))
import Data.Char (ord)
import Data.Functor (($>), (<&>))
import Data.Int (Int16)
import Text.Parsec
  ( alphaNum,
    anyChar,
    char,
    digit,
    eof,
    many,
    many1,
    manyTill,
    oneOf,
    optionMaybe,
    parse,
    skipMany1,
    space,
    spaces,
    string,
    string',
    try,
    (<|>),
  )
import Text.Parsec.String (Parser)
import Trout.Fen.Parse (Fen, parseFen)
import Trout.Piece (PieceType (..))

data CommPositionInit
  = PositionStartpos
  | PositionFen Fen
  deriving (Eq, Show)

-- has less info than trout move
data UciMove = UciMove
  { uciMoveFrom :: Int,
    uciMoveTo :: Int,
    uciMovePromote :: Maybe PieceType
  }
  deriving (Eq, Show)

data CommGoArg
  = GoSearchMoves [String]
  | GoPonder
  | GoWtime Int
  | GoWinc Int
  | GoBtime Int
  | GoBinc Int
  | GoMovestogo Int16
  | GoDepth Int16
  | GoNodes Int
  | GoMate Int16
  | GoMovetime Int
  | GoInfinite
  deriving (Eq, Show)

data UciCommand
  = CommUci
  | CommDebug Bool
  | CommDont
  | CommIsready
  | CommSetoption String String
  | CommRegister String -- not actual type, but we dont need register
  | CommUcinewgame
  | CommPosition CommPositionInit [UciMove]
  | CommGo [CommGoArg]
  | CommStop
  | CommPonderhit
  | CommQuit
  | CommInfo
  deriving (Eq, Show)

-- TODO a lot of this is kinda questionably correct, run through it fully sometime

-- make sure there aren't any trailing bits
commBreak :: Parser ()
commBreak = (many1 space $> ()) <|> eof

spaces1 :: Parser ()
spaces1 = skipMany1 space

-- simple commands without arguments
parseArgless :: Parser UciCommand
parseArgless =
  try (string' "uci" *> commBreak) $> CommUci
    <|> try (string' "Dont" *> commBreak) $> CommDont
    <|> try (string' "isready" *> commBreak) $> CommIsready
    <|> try (string' "ucinewgame" *> commBreak) $> CommUcinewgame
    <|> try (string' "stop" *> commBreak) $> CommStop
    <|> try (string' "ponderhit" *> commBreak) $> CommPonderhit
    <|> try (string' "quit" *> commBreak) $> CommQuit

parseDebug :: Parser UciCommand
parseDebug =
  string' "debug"
    *> spaces1
    *> (string' "on" $> True <|> string' "off" $> False)
    <* commBreak
    <&> CommDebug

parseSetoption :: Parser UciCommand
parseSetoption =
  CommSetoption
    <$> ( string' "setoption"
            *> spaces1
            *> string "name"
            *> spaces1
            *> manyTill anyChar (try (spaces1 *> string' "value"))
        )
    <*> (spaces1 *> many anyChar)
    <* commBreak

-- garbage command for normie engines!
parseRegister :: Parser UciCommand
parseRegister = CommRegister <$> (string' "register" *> many anyChar)

parsePosition :: Parser UciCommand
parsePosition =
  string' "position"
    *> spaces1
    $> CommPosition
    <*> ( string' "startpos" $> PositionStartpos
            <|> PositionFen <$> (string' "fen" *> spaces1 *> parseFen)
        )
    <*> ( spaces1
            *> string "moves"
            *> many parseUciMoves
            <|> pure [] -- maybe should be more strict; reject if mangled here
        )
    <* commBreak
  where
    makeUciMove fromCol fromRow toCol toRow maybePromote =
      UciMove
        fromSq
        toSq
        maybePromotePiece
      where
        fromSq = (ord fromRow - ord '1') * 8 + ord fromCol - ord 'a'
        toSq = (ord toRow - ord '1') * 8 + ord toCol - ord 'a'
        maybePromotePiece =
          maybePromote
            >>= \p -> case p of
              'n' -> Just Knight
              'b' -> Just Bishop
              'r' -> Just Rook
              'q' -> Just Queen
              _ -> Nothing
    parseUciMove :: Parser UciMove
    parseUciMove =
      makeUciMove
        <$> oneOf "abcdefgh"
        <*> oneOf "12345678"
        <*> oneOf "abcdefgh"
        <*> oneOf "12345678"
        <*> optionMaybe (oneOf "nbrq")
    parseUciMoves = spaces1 *> parseUciMove

parseGo :: Parser UciCommand
parseGo = string' "go" *> many (spaces1 *> parseArg) <&> CommGo
  where
    parseIntArg :: (Read a) => String -> (a -> CommGoArg) -> Parser CommGoArg
    parseIntArg n c =
      string' n
        *> spaces1
        *> (c . read <$> ((((:) <$> char '-') <*> many1 digit) <|> many1 digit))
    parseArg =
      ( string' "searchmoves"
          *> many (try (spaces *> many alphaNum))
          <&> GoSearchMoves
      )
        <|> string' "ponder" $> GoPonder
        <|> parseIntArg "wtime" GoWtime
        <|> parseIntArg "winc" GoWinc
        <|> parseIntArg "btime" GoBtime
        <|> parseIntArg "binc" GoBinc
        <|> parseIntArg "movestogo" GoMovestogo
        <|> parseIntArg "depth" GoDepth
        <|> parseIntArg "nodes" GoNodes
        <|> parseIntArg "mate" GoMate
        <|> parseIntArg "movetime" GoMovetime
        <|> string' "infinite" $> GoInfinite

-- NEW: Parser for info lines
parseInfo :: Parser UciCommand
parseInfo = try (string' "info") *> manyTill anyChar eof $> CommInfo

parseUciCommand :: Parser UciCommand
parseUciCommand =
  parseArgless
    <|> parseDebug
    <|> parseSetoption
    <|> parseRegister
    <|> parsePosition
    <|> parseGo
    <|> parseInfo

-- dont require parsec import
readUciLine :: String -> Either String UciCommand
readUciLine = first show . parse parseUciCommand ""

Best regards,
Jim Ablett.