<commit_before>module Play where

import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent.Thread.Delay (delay)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.IORef
import Data.Maybe (isJust, isNothing, maybe, fromJust)
import Data.Time.Clock
import Data.Time.LocalTime
import System.IO
import Text.PrettyPrint.Boxes (printBox)

import Command
import Game
import Display
import Unit
import Util
import Types

data Meta = Nop | Dump | Quit | Batch deriving (Show, Eq)

initGameIO :: ProblemId -> Tag -> IO [GameState]
initGameIO n tg = do
  { input <- readProblem ("problems/problem_"++show n++".json")
  ; case input of { Nothing -> return []; Just inp -> return (initGameStates tg inp) }
  }

genTag :: ProblemId -> IO Tag
genTag n = do
  now <- getCurrentTime
  zone <- getCurrentTimeZone
  let (TimeOfDay h m s) = localTimeOfDay $ utcToLocalTime zone now
  return $ "problem" ++ show n ++ "-" ++ show h ++ "-" ++ show m ++ "-" ++ show s

autoPlay :: ProblemId -> Player -> IO ()
autoPlay n ani = testPlay n (play' 0 ani)

testPlay :: ProblemId -> Game () -> IO ()
testPlay n player = do
  tag <- liftIO (genTag n)
  gms <- initGameIO n tag
  gms' <- execStateT player (head gms)
--  LBS.putStrLn $ encode $ dumpOutputItem gms'
  let filename = "outputs/problem"++show n++"-score"++show (gsScore gms')++"-"++tag++".json"
  handle <- openFile filename WriteMode
  hPutStr handle $ LBS.unpack $ encode $ dumpOutputItem gms'
  hClose handle
  return ()

play' :: WaituS -> Player -> Game ()
play' wait = loop
  where
    loop ani = do
      gm <- get
      liftIO (gameDisplay' gm >> delay wait)
      case gsStatus gm of
        Running -> do
          let (c, ani') = runPlayer gm ani
          put (gameStep c gm)
          loop ani'
        _       -> quit
    dump = do
      { gm <- get
      ; let cmds = reverse $ gsCommands gm
      ; liftIO $ print $ cmds
      ; liftIO $ print $ head $ commandsToString cmds
      }
    quit = do
      { liftIO $ putStrLn "QUIT"
      ; dump
      }

play :: Game ()
play = do 
  { liftIO (hSetBuffering stdin NoBuffering)
  ; liftIO (hSetBuffering stdout NoBuffering)
  ; liftIO (hSetEcho stdin False)
  ; loop
  }
  where
    dump = do
      { gm <- get
      ; let cmds = reverse $ gsCommands gm
      ; liftIO $ print $ cmds
      ; liftIO $ print $ head $ commandsToString cmds
      }
    quit = do
      { liftIO $ putStrLn "QUIT"
      ; dump
      }
    opMeta Quit = quit
    opMeta Dump = dump >> loop
    opMeta Nop  = loop
    opMeta Batch = do
      s <- liftIO $ do
        hSetBuffering stdin LineBuffering
        hSetBuffering stdout LineBuffering                      
        hSetEcho stdin True
        putStr "reading [Command] expression in haskell > "
        hFlush stdout
        s <- getLine
        hSetBuffering stdin NoBuffering
        hSetBuffering stdout NoBuffering
        hSetEcho stdin False
        return s
      case reads s of
        (cmds,_) : _ -> do
          modify (gameStepN cmds)
          loop
        _ -> do
          liftIO $ putStrLn "parse error"
          loop
    opCommand cmd = modify (gameStep cmd) >> loop
    loop = do
      { gm <- get
      ; liftIO (gameDisplay' gm >> hFlush stdout)
      ; liftIO (putStrLn (show (gsCurUnit gm))) -- for debug
      ; liftIO (putStrLn ("lockedp : "++show (gsLocked gm))) -- for debug
      ; case gsStatus gm of
          Running -> do
           { cmd <- liftIO (hGetCommand stdin)
           ; either opMeta opCommand cmd
           }
          _       -> quit
      }

hGetCommand :: Handle -> IO (Either Meta Command)
hGetCommand h =  return . keyToCommand =<< hGetChar h

keyToCommand :: Char -> Either Meta Command
keyToCommand 'h' = Right (Move W)
keyToCommand 'l' = Right (Move E)
keyToCommand 'j' = Right (Move SW)
keyToCommand 'k' = Right (Move SE)
keyToCommand ' ' = Right (Turn CW)
keyToCommand 'z' = Right (Turn CCW)
keyToCommand 'q' = Left Quit
keyToCommand 'd' = Left Dump
keyToCommand 'b' = Left Batch
keyToCommand _   = Left Nop


data PlayerM a
  = PReturn a
  | PCommand Command (PlayerM a)
  | PGetGameState (GameState -> PlayerM a)

instance Functor PlayerM where
  fmap = liftM

instance Applicative PlayerM where
  pure  = return
  (<*>) = ap

instance Monad PlayerM where
  return = PReturn
  PReturn x >>= f = f x
  PCommand o cont >>= f = PCommand o (cont >>= f)
  PGetGameState cont >>= f = PGetGameState (\i -> cont i >>= f)

type Player = PlayerM ()

getGameState :: PlayerM GameState
getGameState = PGetGameState return

command :: Command -> Player
command x = PCommand x (return ())
<commit_msg>add 's' meta command to enter solution string directly in a batch<commit_after>module Play where

import Control.Applicative
import Control.Arrow ((&&&))
import Control.Concurrent.Thread.Delay (delay)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.IORef
import Data.Maybe (isJust, isNothing, maybe, fromJust)
import Data.Time.Clock
import Data.Time.LocalTime
import System.IO
import Text.PrettyPrint.Boxes (printBox)

import Command
import Game
import Display
import Unit
import Util
import Types

data Meta = Nop | Dump | Quit | BatchH | BatchS deriving (Show, Eq)

initGameIO :: ProblemId -> Tag -> IO [GameState]
initGameIO n tg = do
  { input <- readProblem ("problems/problem_"++show n++".json")
  ; case input of { Nothing -> return []; Just inp -> return (initGameStates tg inp) }
  }

genTag :: ProblemId -> IO Tag
genTag n = do
  now <- getCurrentTime
  zone <- getCurrentTimeZone
  let (TimeOfDay h m s) = localTimeOfDay $ utcToLocalTime zone now
  return $ "problem" ++ show n ++ "-" ++ show h ++ "-" ++ show m ++ "-" ++ show s

autoPlay :: ProblemId -> Player -> IO ()
autoPlay n ani = testPlay n (play' 0 ani)

testPlay :: ProblemId -> Game () -> IO ()
testPlay n player = do
  tag <- liftIO (genTag n)
  gms <- initGameIO n tag
  gms' <- execStateT player (head gms)
--  LBS.putStrLn $ encode $ dumpOutputItem gms'
  let filename = "outputs/problem"++show n++"-score"++show (gsScore gms')++"-"++tag++".json"
  handle <- openFile filename WriteMode
  hPutStr handle $ LBS.unpack $ encode $ dumpOutputItem gms'
  hClose handle
  return ()

play' :: WaituS -> Player -> Game ()
play' wait = loop
  where
    loop ani = do
      gm <- get
      liftIO (gameDisplay' gm >> delay wait)
      case gsStatus gm of
        Running -> do
          let (c, ani') = runPlayer gm ani
          put (gameStep c gm)
          loop ani'
        _       -> quit
    dump = do
      { gm <- get
      ; let cmds = reverse $ gsCommands gm
      ; liftIO $ print $ cmds
      ; liftIO $ print $ head $ commandsToString cmds
      }
    quit = do
      { liftIO $ putStrLn "QUIT"
      ; dump
      }

play :: Game ()
play = do 
  { liftIO (hSetBuffering stdin NoBuffering)
  ; liftIO (hSetBuffering stdout NoBuffering)
  ; liftIO (hSetEcho stdin False)
  ; loop
  }
  where
    dump = do
      { gm <- get
      ; let cmds = reverse $ gsCommands gm
      ; liftIO $ print $ cmds
      ; liftIO $ print $ head $ commandsToString cmds
      }
    quit = do
      { liftIO $ putStrLn "QUIT"
      ; dump
      }
    opMeta Quit = quit
    opMeta Dump = dump >> loop
    opMeta Nop  = loop
    opMeta BatchH = do
      s <- getLineWithPrompt "reading [Command] expression in haskell > "
      case reads s of
        (cmds,_) : _ -> do
          modify (gameStepN cmds)
          loop
        _ -> do
          liftIO $ putStrLn "parse error"
          loop
    opMeta BatchS = do
      s <- getLineWithPrompt "reading solution string > "
      modify (gameStepN (stringToCommands s))
      loop
    opCommand cmd = modify (gameStep cmd) >> loop
    loop = do
      { gm <- get
      ; liftIO (gameDisplay' gm >> hFlush stdout)
      ; liftIO (putStrLn (show (gsCurUnit gm))) -- for debug
      ; liftIO (putStrLn ("lockedp : "++show (gsLocked gm))) -- for debug
      ; case gsStatus gm of
          Running -> do
           { cmd <- liftIO (hGetCommand stdin)
           ; either opMeta opCommand cmd
           }
          _       -> quit
      }

    getLineWithPrompt prompt = liftIO $ do
      hSetBuffering stdin LineBuffering
      hSetBuffering stdout LineBuffering                      
      hSetEcho stdin True
      putStr prompt
      hFlush stdout
      s <- getLine
      hSetBuffering stdin NoBuffering
      hSetBuffering stdout NoBuffering
      hSetEcho stdin False
      return s

hGetCommand :: Handle -> IO (Either Meta Command)
hGetCommand h =  return . keyToCommand =<< hGetChar h

keyToCommand :: Char -> Either Meta Command
keyToCommand 'h' = Right (Move W)
keyToCommand 'l' = Right (Move E)
keyToCommand 'j' = Right (Move SW)
keyToCommand 'k' = Right (Move SE)
keyToCommand ' ' = Right (Turn CW)
keyToCommand 'z' = Right (Turn CCW)
keyToCommand 'q' = Left Quit
keyToCommand 'd' = Left Dump
keyToCommand 'b' = Left BatchH
keyToCommand 's' = Left BatchS
keyToCommand _   = Left Nop


data PlayerM a
  = PReturn a
  | PCommand Command (PlayerM a)
  | PGetGameState (GameState -> PlayerM a)

instance Functor PlayerM where
  fmap = liftM

instance Applicative PlayerM where
  pure  = return
  (<*>) = ap

instance Monad PlayerM where
  return = PReturn
  PReturn x >>= f = f x
  PCommand o cont >>= f = PCommand o (cont >>= f)
  PGetGameState cont >>= f = PGetGameState (\i -> cont i >>= f)

type Player = PlayerM ()

getGameState :: PlayerM GameState
getGameState = PGetGameState return

command :: Command -> Player
command x = PCommand x (return ())

{'fraction_non_alphanumeric': 0.10237113402061855, 'fraction_numerical': 0.0004123711340206186, 'mean_word_length': 2.5161290322580645, 'pattern_counts': {'":': 0, '<': 38, '<?xml version=': 0, '>': 88, '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': '1006751', 'n_tokens_mistral': 3221, 'n_tokens_neox': 3163, 'n_words': 1053}