<commit_before>{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module AIChallenger.Match
    ( launchBotsAndSimulateMatch
    , simulateMatch
    ) where

import Control.Exception
import Control.Monad
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Vector.Extended as V
import Path

import AIChallenger.Bot
import AIChallenger.Types

launchBotsAndSimulateMatch :: Game game => game -> Turn -> V.Vector Bot -> MatchId -> IO Match
launchBotsAndSimulateMatch game turnLimit bots mid@(MatchId x) = do
    replayPath <- parseAbsFile ("/tmp/" <> show x <> ".replay")
    let work (Right players) = do
             GameResult winnerIds gameOver replay <- simulateMatch game turnLimit players
             gameSaveReplay game replayPath replay
             let winnerPlayers = (V.filter ((`elem` winnerIds) . playerId) players)
             let winnerNames = fmap playerName winnerPlayers
                 winnerBots = V.filter ((`elem` winnerNames) .  botName) bots
             return (Match mid bots winnerBots gameOver replayPath)
        work (Left (winnerBots, faults)) = do
             let replay = gameExtractReplay game (gameInitialState game)
             gameSaveReplay game replayPath replay
             return (Match mid bots winnerBots (Disqualification faults) replayPath)
    bracket
        (launchBots bots)
        (either (const (return ())) (V.mapM_ playerClose))
        work

simulateMatch :: Game game => game -> Turn -> V.Vector Player -> IO (GameResult game)
simulateMatch game turnLimit bots =
    go mempty (gameInitialState game)
    where
    go turn state | turn >= turnLimit = return (gameTimeout state)
    go turn state = do
        sendWorld game state bots
        faultsOrOrders <- getOrders game bots
        case faultsOrOrders of
            Left faults -> do
                let losers = fmap fst faults
                    winners = V.filter (not . (`V.elem` losers)) (fmap playerId bots)
                return (GameResult
                    winners
                    (Disqualification faults)
                    (gameExtractReplay game state))
            Right orders ->
                case gameAdvance orders state of
                    Left result -> return result
                    Right newState -> go (succ turn) newState

sendWorld :: Game game => game -> GameState game -> V.Vector Player -> IO ()
sendWorld game gameState players = do
    forM_ players $ \(Player { playerId = PlayerId me, playerInput = ch }) -> do
        sendLine ch ("Y " <> showT me)
        gameSendWorld game (PlayerId me) gameState (sendLine ch)
        sendLine ch "."

getOrders :: forall game. Game game => game -> V.Vector Player
    -> IO (Either Faults (V.Vector (PlayerId, V.Vector (GameOrder game))))
getOrders game bots = do
    unparsedOrdersAndFaults <- forM bots $ \(Player {playerId = me, playerOutput = ch}) ->
        do
            faultOrTexts <- chReadLinesUntilDot ch
            case faultOrTexts of
                Left fault -> return (me, Left (pure fault))
                Right texts -> return (me, Right texts)
    let ioFaults :: V.Vector (PlayerId, NonEmpty Fault)
        ioFaults =
            V.mapMaybe
                (\case
                    (botIdent, Left f) -> Just (botIdent, f)
                    _ -> Nothing)
                unparsedOrdersAndFaults<commit_msg>Limit think time for bots<commit_after>{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module AIChallenger.Match
    ( launchBotsAndSimulateMatch
    , simulateMatch
    ) where

import Control.Exception
import Control.Monad
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Vector.Extended as V
import Path
import System.Timeout

import AIChallenger.Bot
import AIChallenger.Types

launchBotsAndSimulateMatch :: Game game => game -> Turn -> V.Vector Bot -> MatchId -> IO Match
launchBotsAndSimulateMatch game turnLimit bots mid@(MatchId x) = do
    replayPath <- parseAbsFile ("/tmp/" <> show x <> ".replay")
    let work (Right players) = do
             GameResult winnerIds gameOver replay <- simulateMatch game turnLimit players
             gameSaveReplay game replayPath replay
             let winnerPlayers = (V.filter ((`elem` winnerIds) . playerId) players)
             let winnerNames = fmap playerName winnerPlayers
                 winnerBots = V.filter ((`elem` winnerNames) .  botName) bots
             return (Match mid bots winnerBots gameOver replayPath)
        work (Left (winnerBots, faults)) = do
             let replay = gameExtractReplay game (gameInitialState game)
             gameSaveReplay game replayPath replay
             return (Match mid bots winnerBots (Disqualification faults) replayPath)
    bracket
        (launchBots bots)
        (either (const (return ())) (V.mapM_ playerClose))
        work

simulateMatch :: Game game => game -> Turn -> V.Vector Player -> IO (GameResult game)
simulateMatch game turnLimit bots =
    go mempty (gameInitialState game)
    where
    go turn state | turn >= turnLimit = return (gameTimeout state)
    go turn state = do
        sendWorld game state bots
        faultsOrOrders <- getOrders game bots
        case faultsOrOrders of
            Left faults -> do
                let losers = fmap fst faults
                    winners = V.filter (not . (`V.elem` losers)) (fmap playerId bots)
                return (GameResult
                    winners
                    (Disqualification faults)
                    (gameExtractReplay game state))
            Right orders ->
                case gameAdvance orders state of
                    Left result -> return result
                    Right newState -> go (succ turn) newState

sendWorld :: Game game => game -> GameState game -> V.Vector Player -> IO ()
sendWorld game gameState players = do
    forM_ players $ \(Player { playerId = PlayerId me, playerInput = ch }) -> do
        sendLine ch ("Y " <> showT me)
        gameSendWorld game (PlayerId me) gameState (sendLine ch)
        sendLine ch "."

getOrders :: forall game. Game game => game -> V.Vector Player
    -> IO (Either Faults (V.Vector (PlayerId, V.Vector (GameOrder game))))
getOrders game bots = do
    unparsedOrdersAndFaults <- forM bots $ \(Player {playerId = me, playerOutput = ch}) ->
        do
            let oneSecond = 1000000
            maybeFaultOrTexts <- timeout oneSecond (chReadLinesUntilDot ch)
            case maybeFaultOrTexts of
                Nothing -> return (me, Left (pure (Fault "Time limit exceeded")))
                Just (Left fault) -> return (me, Left (pure fault))
                Just (Right texts) -> return (me, Right texts)
    let ioFaults :: V.Vector (PlayerId, NonEmpty Fault)
        ioFaults =
            V.mapMaybe
                (\case
                    (botIdent, Left f) -> Just (botIdent, f)
                    _ -> Nothing)
                unparsedOrdersAndFaults
{'fraction_non_alphanumeric': 0.08501520597179983, 'fraction_numerical': 0.0009676527508985347, 'mean_word_length': 2.231353282715498, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 64, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6783057', 'n_tokens_mistral': 2063, 'n_tokens_neox': 1964, 'n_words': 669}