\section{Driver}
\begin{code}
module Driver
(DriverObject,
driverNoop,
newDriverObject,
driverRead,
driverGetAnswer,
driverGetTable,
driverAction)
where
import Data.Maybe
import Control.Monad
import Data.IORef
import Data.List
import System.IO
import Tables
import RSAGL.Time
import Control.Concurrent
data RoguestarEngineState = RoguestarEngineState {
restate_tables :: [RoguestarTable],
restate_answers :: [(String,String)] }
data DriverData = DriverData {
driver_engine_input_lines :: [String],
driver_engine_input_line_fragment :: String,
driver_engine_output_lines :: [String],
driver_engine_state :: RoguestarEngineState,
driver_dones :: Integer }
newtype DriverObject = DriverObject (IORef DriverData)
newDriverObject :: IO DriverObject
newDriverObject = liftM DriverObject $ newIORef initial_driver_data
initial_driver_data :: DriverData
initial_driver_data = DriverData {
driver_engine_input_lines = [],
driver_engine_input_line_fragment = [],
driver_engine_output_lines = [],
driver_engine_state = RoguestarEngineState [] [],
driver_dones = 0 }
driverGet :: DriverObject -> (DriverData -> a) -> IO a
driverGet (DriverObject ioref) f = liftM f $ readIORef ioref
modifyDriver :: DriverObject -> (DriverData -> DriverData) -> IO ()
modifyDriver (DriverObject ioref) f = modifyIORef ioref f
\end{code}
\begin{code}
driverNoop :: DriverObject -> IO ()
driverNoop driver_object = driverWrite driver_object "noop\n"
\end{code}
\subsection{Getting Protocol Answers}
\texttt{driverGetAnswer} retrieves an answer from the engine. An answer is a single string.
\begin{code}
driverGetAnswer :: DriverObject -> String -> IO (Maybe String)
driverGetAnswer driver_object query =
do driverQuery driver_object [query]
driverGet driver_object (lookup query . restate_answers . driver_engine_state)
\end{code}
\subsection{Getting Protocol Tables}
\testtt{driverGetTable} retrieves a table from the engine. These tables make up a kind of simple relational database.
\begin{code}
driverGetTable :: DriverObject -> String -> String -> IO (Maybe RoguestarTable)
driverGetTable driver_object the_table_name the_table_id =
do driverQuery driver_object [the_table_name,the_table_id]
driverGet driver_object (find (\x -> table_name x == the_table_name && table_id x == the_table_id) . restate_tables . driver_engine_state)
\end{code}
\texttt{driverQuery} transmits a read-only query against the state of the engine.
\begin{code}
driverQuery :: DriverObject -> [String] -> IO ()
driverQuery driver_object query = driverWrite driver_object $ "game query " ++ unwords query ++ "\n"
\end{code}
\begin{code}
driverAction :: DriverObject -> [String] -> IO ()
driverAction driver_object strs =
do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] []}
driverWrite driver_object $ "game action " ++ unwords strs ++ "\n"
\end{code}
\texttt{driverWrite} writes the specified command to standard output, automatically interleaving calls to read.
\texttt{driverWrite} will never write the same string twice between calls to \texttt{driverReset}.
\begin{code}
driverWrite :: DriverObject -> String -> IO ()
driverWrite driver_object str =
do already_sent <- driverGet driver_object (elem str . driver_engine_output_lines)
unless already_sent $
do modifyDriver driver_object $ \driver -> driver { driver_engine_output_lines=str:driver_engine_output_lines driver }
driverWrite_ driver_object str
driverRead driver_object
driverWrite_ :: DriverObject -> String -> IO ()
driverWrite_ driver_object "" =
do hFlush stdout
driverRead driver_object
driverWrite_ driver_object str =
do driverRead driver_object
putChar $ head str
--hPutChar stderr $ head str -- uncomment to see everything we write in stderr
driverWrite_ driver_object $ tail str
\end{code}
\texttt{maybeRead} reads one character if it is available.
\begin{code}
maybeRead :: IO (Maybe Char)
maybeRead = do ready <- hReady stdin
case ready of
False -> return Nothing
True -> do char <- getChar
return $ Just char
\end{code}
\texttt{driverRead} reads, parses, and stores data from the engine.
\begin{code}
driverRead :: DriverObject -> IO ()
driverRead driver_object =
do maybe_next_char <- maybeRead
case maybe_next_char of
Nothing -> return ()
Just '\n' -> do modifyDriver driver_object
(\driver -> driver { driver_engine_input_lines=
(reverse $ driver_engine_input_line_fragment driver) :
driver_engine_input_lines driver,
driver_engine_input_line_fragment=""});
driverUpdate driver_object
Just next_char -> modifyDriver driver_object
(\driver -> driver { driver_engine_input_line_fragment=(next_char :
driver_engine_input_line_fragment driver) })
when (isJust maybe_next_char) $ do --hPutChar stderr $ fromJust maybe_next_char -- uncomment to see everything we read in stderr
driverRead driver_object
\end{code}
\texttt{driverUpdate} parses stored information in the driver, generating answers and tables.
\begin{code}
driverUpdate :: DriverObject -> IO ()
driverUpdate driver_object =
do head_line <- driverGet driver_object (head . driver_engine_input_lines)
when (head_line == "over") $ interpretText driver_object
data DriverInterpretationState = DINeutral
| DIScanningTable RoguestarTable
| DIError
deriving (Eq,Show)
interpretText :: DriverObject -> IO ()
interpretText driver_object =
do final_state <- foldM (interpretLine driver_object) DINeutral =<< driverGet driver_object (reverse . driver_engine_input_lines)
when (final_state /= DINeutral) $ do hPutStr stderr "interpretText concluded in a non-neutral state, which was:"
hPutStr stderr (show final_state)
modifyDriver driver_object $ \driver -> initial_driver_data {
driver_dones = driver_dones driver,
driver_engine_state = driver_engine_state driver }
modifyDriver driver_object $ \driver -> driver { driver_engine_input_lines = [] }
modifyEngineState :: DriverObject -> (RoguestarEngineState -> RoguestarEngineState) -> IO ()
modifyEngineState driver_object f = modifyDriver driver_object $ \driver -> driver { driver_engine_state = f $ driver_engine_state driver }
interpretLine :: DriverObject -> DriverInterpretationState -> String -> IO DriverInterpretationState
interpretLine _ DIError _ = return DIError
interpretLine _ di_state "" = do return di_state -- ignore empty lines
interpretLine _ _ str | (head $ words str) == "protocol-error:" =
do hPutStr stderr str
return DIError
interpretLine _ _ str | (head $ words str) == "error:" =
do hPutStr stderr str
return DIError
interpretLine driver_object DINeutral "done" =
do modifyDriver driver_object $ \driver -> driver { driver_engine_state = RoguestarEngineState [] [],
driver_engine_output_lines = [],
driver_dones = driver_dones driver + 1 }
return DINeutral
interpretLine _ di_state "done" =
do hPutStr stderr ("client-side protocol error: unexpected \"done\" in " ++ (show di_state) ++ " state.")
return DIError
interpretLine _ DINeutral "over" = return DINeutral
interpretLine _ (DIScanningTable {}) "over" =
do hPutStr stderr "client-side protocol error: 'over' issued while reading a data table"
return DIError
interpretLine driver_object DINeutral str | (head $ words str) == "answer:" && (length $ words str) == 3 =
do modifyEngineState driver_object (\engine_state -> engine_state { restate_answers = (words str !! 1,words str !! 2):restate_answers engine_state })
return DINeutral
interpretLine _ DINeutral str | (head $ words str) == "begin-table" && (length $ words str) > 3 =
do t <- getTime
let table_start_data = words str
return $ DIScanningTable $ RoguestarTable {
table_created = t,
table_name = table_start_data !! 1,
table_id = table_start_data !! 2,
table_header = drop 3 table_start_data,
table_data = []}
interpretLine _ _ str | (head $ words str) == "begin-table" =
do hPutStr stderr "client-side protocol error: incomplete begin-table header"
return DIError
interpretLine driver_object (DIScanningTable table) str | (head $ words str) == "end-table" =
do modifyEngineState driver_object (\engine_state -> engine_state { restate_tables = (table { table_data=reverse $ table_data table}):restate_tables engine_state })
return DINeutral
interpretLine _ (DIScanningTable table) str =
let table_row = words str
in (if length table_row == (length $ table_header table)
then return $ DIScanningTable (table { table_data = table_row : table_data table })
else do hPutStr stderr "client-side protocol error: malformed table row"
return DIError )
interpretLine _ _ str =
do hPutStr stderr str
return DINeutral
\end{code}