{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-}
module Protocol
(mainLoop)
where
import Data.Char
import Data.List as List
import CreatureData
import Creature
import Character
import DB
import System.Exit
import System.IO
import BeginGame
import Data.Maybe
import Plane
import PlaneData
import Building
import BuildingData
import Tool
import FactionData
import PlaneVisibility
import Facing
import ToolData
import Control.Monad.Error
import Turns
import SpeciesData
import Species
import Data.Ord
import Combat
import Substances
import PlayerState
import Make
import Control.Concurrent
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Control.Exception
import WorkCluster
import qualified Data.ByteString.Char8 as B
import qualified Perception
-- Don't call dbBehave, use dbPerformPlayerTurn
import Behavior hiding (dbBehave)
-- We need to construct References based on UIDs, so we cheat a little:
import DBPrivate (Reference(ToolRef))
mainLoop :: DB_BaseType -> IO ()
mainLoop db_init =
do db_var <- newMVar db_init
input_chan <- newChan
output_chan <- newChan
query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress)
wait_quit <- newEmptyMVar
work_cluster <- newWorkCluster
replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever
_ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< B.getLine
_ <- forkIO $ foreverLoopThenQuit $
do next_line <- liftM (B.map toLower . B.unlines . B.lines) (readChan output_chan)
when (B.length next_line > 0) $
do B.putStrLn next_line
B.putStrLn "over"
hFlush stdout
_ <- forkIO $ foreverLoopThenQuit $
do next_command <- readChan input_chan
case (B.words $ B.map toLower next_command) of
["quit"] -> exitWith ExitSuccess
["reset"] -> stopping query_count $ modifyMVar_ db_var (const $ return initial_db)
("game":"query":args) ->
do querrying query_count $
do result <- workRequest work_cluster (Query, args)
complete Nothing output_chan result
("game":"action":args) ->
do result <- workRequest work_cluster (Action, args)
stopping query_count $ complete (Just db_var) output_chan result
querrying query_count $ complete Nothing output_chan result -- print the result as a query, this will ensure errors get printed
replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
("noop":_) -> return ()
failed ->
do _ <- forkIO $ complete Nothing output_chan $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ B.unpack (B.unwords failed) ++ "`"
return ()
takeMVar wait_quit -- "park" the main function
-- | Evaluate a 'GameDirective' and return it from a remote thread via an 'MVar'.
evaluateGame :: DB_BaseType -> WorkRequest -> IO WorkResult
evaluateGame db0 (Query, ["snapshot"]) = (runDB $ ro $ liftM (\b -> "answer: snapshot " `B.append` if b then "yes" else "no") dbHasSnapshot) db0
evaluateGame db0 (Query, args) = (runDB $ ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0
evaluateGame db0 (Action, args) = runDB (liftM (const "") $ dbDispatchAction args) db0
-- | Wait for currently running queries to finish, and stop processing incomming queries while we mutate the database.
stopping :: TVar (Maybe Integer) -> IO () -> IO ()
stopping query_count actionM = bracket
(atomically $ do maybe retry (\x -> when (x /= 0) retry) =<< readTVar query_count
writeTVar query_count $ Nothing)
(const $ atomically $ writeTVar query_count (Just 0))
(const actionM)
-- | Process a querry concurrently with other queries.
querrying :: TVar (Maybe Integer) -> IO () -> IO ()
querrying query_count actionM =
do atomically $ writeTVar query_count =<< liftM Just . (maybe retry $ return . (+1)) =<< readTVar query_count
_ <- forkIO $ finally (atomically $ do writeTVar query_count =<< liftM (fmap (subtract 1)) (readTVar query_count)) actionM
return ()
-- | Complete a querry or action. If a database variable is provided, it will be modified according to the result of the action.
-- The result of the action will be printed to the output_chan.
complete :: Maybe (MVar DB_BaseType) -> Chan B.ByteString -> Either DBError (B.ByteString,DB_BaseType) -> IO ()
complete m_db_var output_chan result =
do case m_db_var of
Just db_var ->
do modifyMVar_ db_var $ \db0 -> return $ case result of
Right (_,db1) -> db1
Left (DBErrorFlag errflag) -> db0 { db_error_flag = show errflag }
Left (DBError _) -> db0
writeChan output_chan "done"
Nothing ->
do case result of
Right (outstr,_) ->
do _ <- evaluate outstr
writeChan output_chan outstr
Left (DBErrorFlag _) -> return () -- client will query this explicitly (if it cares)
Left (DBError errstr) ->
do writeChan output_chan $ "error: " `B.append` B.pack errstr
B.hPutStrLn stderr $ "DBError: " `B.append` B.pack errstr
dbOldestSnapshotOnly :: (DBReadable db) => db ()
dbOldestSnapshotOnly =
do b <- dbHasSnapshot
when b $ fail "protocol-error: pending snapshot"
-- |
-- Perform an action assuming the database is in the DBRaceSelectionState,
-- otherwise returns an error message.
--
dbRequiresRaceSelectionState :: (DBReadable db) => db a -> db a
dbRequiresRaceSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
RaceSelectionState -> action
_ -> throwError $ DBError $ "protocol-error: not in race selection state (" ++ show state ++ ")"
-- |
-- Perform an action assuming the database is in the DBClassSelectionState,
-- otherwise returns an error message.
--
dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a
dbRequiresClassSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
ClassSelectionState creature -> action creature
_ -> throwError $ DBError $ "protocol-error: not in class selection state (" ++ show state ++ ")"
-- |
-- Perform an action that operates on the player creature (not in any context).
-- The states that work for this are:
--
-- * ClassSelectionState
-- * PlayerCreatureTurn
--
dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db a) -> db a
dbRequiresPlayerCenteredState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
ClassSelectionState creature -> action creature
PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
_ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
-- |
-- Perform an action that works during any creature's turn in a planar environment.
-- The states that work for this are:
--
-- * PlayerCreatureTurn
-- * SnapshotEvent
--
dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
dbRequiresPlanarTurnState action =
do dbOldestSnapshotOnly
state <- playerState
maybe (throwError $ DBError $ "protocol-error: not in planar turn state (" ++ show state ++ ")") action $ creatureOf state
-- |
-- Perform an action that works only during a player-character's turn.
-- The states that work for this are:
--
-- PlayerCreatureTurn
--
dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
dbRequiresPlayerTurnState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
PlayerCreatureTurn creature_ref _ -> action creature_ref
_ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")"
-- |
-- For arbitrary-length menu selections, get the current index into the menu, if any.
--
menuState :: (DBReadable db) => db (Maybe Integer)
menuState = liftM menuIndex playerState
-- |
-- For arbitrary-length menu selections, modify the current index into the menu. If there is no menu index
-- in the current state, this has no effect.
--
modifyMenuState :: (Integer -> Integer) -> DB ()
modifyMenuState f_ =
do number_of_tools <- liftM genericLength toolMenuElements
let f = (\x -> if number_of_tools == 0 then 0 else x `mod` number_of_tools) . f_
setPlayerState . modifyMenuIndex f =<< playerState
dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString
dbDispatchQuery ["state"] =
do state <- playerState
return $ case state of
RaceSelectionState -> "answer: state race-selection"
ClassSelectionState {} -> "answer: state class-selection"
PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
PlayerCreatureTurn _ MoveMode -> "answer: state move"
PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup"
PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop"
PlayerCreatureTurn _ (WieldMode {}) -> "answer: state wield"
PlayerCreatureTurn _ AttackMode -> "answer: state attack"
PlayerCreatureTurn _ FireMode -> "answer: state fire"
PlayerCreatureTurn _ JumpMode -> "answer: state jump"
PlayerCreatureTurn _ TurnMode -> "answer: state turn"
PlayerCreatureTurn _ (MakeMode _ make_prep) | isFinished make_prep -> "answer: state make-finished"
PlayerCreatureTurn _ (MakeMode _ make_prep) | needsKind make_prep -> "answer: state make-what"
PlayerCreatureTurn _ (MakeMode {}) -> "answer: state make"
PlayerCreatureTurn _ ClearTerrainMode -> "answer: state clear-terrain"
SnapshotEvent (AttackEvent {}) -> "answer: state attack-event"
SnapshotEvent (MissEvent {}) -> "answer: state miss-event"
SnapshotEvent (KilledEvent {}) -> "answer: state killed-event"
SnapshotEvent (WeaponOverheatsEvent {}) -> "answer: state weapon-overheats-event"
SnapshotEvent (WeaponExplodesEvent {}) -> "answer: state weapon-explodes-event"
SnapshotEvent (DisarmEvent {}) -> "answer: state disarm-event"
SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event"
SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event"
SnapshotEvent (HealEvent {}) -> "answer: state heal-event"
SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event"
GameOver -> "answer: state game-over"
dbDispatchQuery ["action-count"] =
do n <- dbActionCount
return $ "answer: action-count " `B.append` (B.pack $ show n)
dbDispatchQuery ["menu-state"] =
do m_state <- menuState
return $ case m_state of
Nothing -> "answer: menu-state 0"
Just state -> "answer: menu-state " `B.append` (B.pack $ show state)
dbDispatchQuery ["who-attacks"] =
do state <- playerState
return $ case state of
SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
SnapshotEvent (DisarmEvent { disarm_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
SnapshotEvent (SunderEvent { sunder_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
_ -> "answer: who-attacks 0"
dbDispatchQuery ["who-hit"] =
do state <- playerState
return $ case state of
SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
SnapshotEvent (DisarmEvent { disarm_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
SnapshotEvent (SunderEvent { sunder_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
_ -> "answer: who-hit 0"
dbDispatchQuery ["tool-used"] =
do state <- playerState
return $ case state of
SnapshotEvent (ExpendToolEvent { expend_tool_event_tool = tool_ref }) -> "answer: tool-used " `B.append` (B.pack $ show $ toUID tool_ref)
_ -> "answer: tool-used 0"
dbDispatchQuery ["weapon-used"] =
do state <- playerState
return $ case state of
SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
SnapshotEvent (SunderEvent { sunder_event_source_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
_ -> "answer: weapon-used 0"
dbDispatchQuery ["tool-hit"] =
do state <- playerState
return $ case state of
SnapshotEvent (DisarmEvent { disarm_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
SnapshotEvent (SunderEvent { sunder_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
_ -> "answer: tool-hit 0"
dbDispatchQuery ["who-killed"] =
do state <- playerState
return $ case state of
SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " `B.append` (B.pack $ show $ toUID killed_ref)
_ -> "answer: who-killed 0"
dbDispatchQuery ["who-event"] =
do state <- playerState
return $ case state of
SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event)
_ -> "answer: who-event 0"
dbDispatchQuery ["player-races","0"] =
return ("begin-table player-races 0 name\n" `B.append`
B.unlines (map B.pack player_race_names) `B.append`
"end-table")
dbDispatchQuery ["visible-terrain","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref
return ("begin-table visible-terrain 0 x y terrain-type\n" `B.append`
(B.unlines $ map (\(terrain_type,Position (x,y)) -> B.unwords $ map B.pack [show x, show y, show terrain_type]) terrain_map) `B.append`
"end-table")
dbDispatchQuery ["who-player"] = return "answer: who-player 2"
dbDispatchQuery ["visible-objects","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
(objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
table_rows <- mapM (dbObjectToTableRow . entity) objects
return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append`
(B.unlines $ table_rows) `B.append`
"end-table")
where dbObjectToTableRow obj_ref =
do l <- dbWhere obj_ref
return $ case (extractLocation l,extractLocation l) of
(Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
_ -> ""
dbDispatchQuery ["object-details",uid] = ro $
do maybe_plane_ref <- dbGetCurrentPlane
(visibles :: [Reference ()]) <- maybe
(return [])
(flip dbGetVisibleObjectsForFaction Player $ \ref ->
do let f = (== uid) . B.pack . show . toUID
let m_wielder = coerceReference ref
m_wield <- maybe (return Nothing) dbGetWielded m_wielder
return $ maybe False f m_wield || f ref)
maybe_plane_ref
let creature_refs = mapMaybe (coerceReferenceTyped _creature) visibles
wielded <- liftM catMaybes $ mapM dbGetWielded creature_refs
let tool_refs = mapMaybe (coerceReferenceTyped _tool) visibles ++ wielded
let building_refs = mapMaybe (coerceReferenceTyped _building) visibles
creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs
tools <- liftM (zip tool_refs) $ mapRO dbGetTool tool_refs
buildings <- liftM (zip building_refs) $ mapRO dbGetBuilding building_refs
liftM B.unlines $ liftM3 (\a b c -> concat [a,b,c])
(mapM creatureToTableData creatures)
(mapM toolToTableData tools)
(mapM buildingToTableData buildings)
where objectTableWrapper :: (DBReadable db) =>
Reference a ->
db B.ByteString ->
db B.ByteString
objectTableWrapper obj_ref tableDataF =
do table_data <- tableDataF
return $
"begin-table object-details " `B.append`
(B.pack $ show $ toUID obj_ref) `B.append`
" property value\n" `B.append`
table_data `B.append`
"end-table"
creatureToTableData :: (DBReadable db) =>
(CreatureRef,Creature) ->
db B.ByteString
creatureToTableData (ref,creature) = objectTableWrapper ref $
do fac <- getCreatureFaction ref
hp <- getCreatureAbsoluteHealth ref
maxhp <- getCreatureMaxHealth ref
return $
"object-type creature\n" `B.append`
"species " `B.append` (B.pack $ show $ creature_species creature) `B.append` "\n" `B.append`
"random-id " `B.append` (B.pack $ show $ creature_random_id creature) `B.append` "\n" `B.append`
"faction " `B.append` B.pack (show fac) `B.append` "\n" `B.append`
(if fac == Player then
"hp " `B.append` B.pack (show hp) `B.append` "\n" `B.append`
"maxhp " `B.append` B.pack (show maxhp) `B.append` "\n"
else "")
toolToTableData :: (DBReadable db) => (ToolRef,Tool) -> db B.ByteString
toolToTableData (ref,tool) = objectTableWrapper ref $ return $
"object-type tool\n" `B.append`
"tool-type " `B.append` toolType tool `B.append` "\n" `B.append`
"tool " `B.append` toolName tool `B.append` "\n"
buildingToTableData :: (DBReadable db) => (BuildingRef,Building) -> db B.ByteString
buildingToTableData (ref,Building) = objectTableWrapper ref $
do building_type <- buildingType ref
return $ "object-type building\n" `B.append`
"building-type " `B.append` B.pack (show building_type) `B.append` "\n"
dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCenterCoordinates
dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses
dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
liftM (showToolMenuTable "pickups" "0") $ toolsToMenuTable =<< dbAvailablePickups creature_ref
dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
liftM (showToolMenuTable "inventory" "0") $ toolsToMenuTable =<< dbGetContents creature_ref
dbDispatchQuery ["menu","0"] =
liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements
dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =
do n <- liftM (fromMaybe 0) menuState
let half_window = window_size `div` 2
let windowF (x,_,_) = abs (x - (max half_window n)) <= half_window
liftM (showToolMenuTable "menu" s . filter windowF) $ toolsToMenuTable =<< toolMenuElements
dbDispatchQuery ["wielded-objects","0"] =
do m_plane_ref <- dbGetCurrentPlane
creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref
wielded_tool_refs <- mapM dbGetWielded creature_refs
let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe B.ByteString
wieldedPairToTable creature_ref = fmap (\tool_ref -> (B.pack $ show $ toUID tool_ref) `B.append` " " `B.append` (B.pack $ show $ toUID creature_ref))
return $ "begin-table wielded-objects 0 uid creature\n" `B.append`
B.unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) `B.append`
"end-table"
dbDispatchQuery ["biome"] =
do m_plane_ref <- dbGetCurrentPlane
biome_name <- case m_plane_ref of
Nothing -> return "nothing"
Just plane_ref -> liftM (show . plane_biome) $ dbGetPlane plane_ref
return $ "answer: biome " `B.append` B.pack biome_name
dbDispatchQuery ["current-plane"] =
do m_plane_ref <- dbGetCurrentPlane
return $ case m_plane_ref of
Nothing -> "answer: current-plane 0"
Just plane_ref -> "answer: current-plane " `B.append` (B.pack $ show $ toUID plane_ref)
dbDispatchQuery ["plane-random-id"] =
do m_plane_ref <- dbGetCurrentPlane
case m_plane_ref of
Nothing -> return "answer: plane-random-id 0"
Just plane_ref -> liftM (("answer: plane-random-id " `B.append`) . B.pack . show . plane_random_id) $ dbGetPlane plane_ref
dbDispatchQuery ["planet-name"] =
do m_plane_ref <- dbGetCurrentPlane
case m_plane_ref of
Nothing -> return "answer: planet-name nothing"
Just plane_ref -> liftM ("answer: planet-name " `B.append`) $ planetName plane_ref
dbDispatchQuery ["compass"] =
do m_player_ref <- getCurrentCreature Player
case m_player_ref of
Nothing -> return "answer: compass nothing"
Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: compass " `B.append`) . B.pack . show) Perception.compass
dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" `B.append` B.unwords unrecognized `B.append` "`"
dbDispatchAction :: [B.ByteString] -> DB ()
dbDispatchAction ["continue"] = dbPopOldestSnapshot
dbDispatchAction ["select-race",race_name] =
dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name
dbDispatchAction ["reroll"] =
dbRequiresClassSelectionState $ dbRerollRace
dbDispatchAction ["select-class",class_name] =
dbRequiresClassSelectionState $ dbSelectPlayerClass class_name
dbDispatchAction [direction] | isJust $ stringToFacing direction =
do state <- playerState
case state of
PlayerCreatureTurn _ player_mode -> case player_mode of
JumpMode -> dbDispatchAction ["jump",direction]
TurnMode -> dbDispatchAction ["turn",direction]
AttackMode -> dbDispatchAction ["attack",direction]
FireMode -> dbDispatchAction ["fire",direction]
MoveMode -> dbDispatchAction ["move",direction]
ClearTerrainMode -> dbDispatchAction ["clear-terrain",direction]
_ -> dbDispatchAction ["normal",direction]
_ -> throwError $ DBError $ "protocol-error: not in player turn state"
dbDispatchAction ["normal"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref NormalMode)
dbDispatchAction ["normal",direction] | Just face <- stringToFacing direction =
dbRequiresPlayerTurnState $ \creature_ref ->
do behavior <- facingBehavior creature_ref face
dbPerformPlayerTurn behavior creature_ref
dbDispatchAction ["move"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref MoveMode)
dbDispatchAction ["move",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref)
dbDispatchAction ["jump"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref JumpMode)
dbDispatchAction ["jump",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Behavior.Jump $ fromJust $ stringToFacing direction) creature_ref)
dbDispatchAction ["turn"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref TurnMode)
dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref
dbDispatchAction ["clear-terrain"] =
dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref ClearTerrainMode)
dbDispatchAction ["clear-terrain",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (ClearTerrain $ fromJust $ stringToFacing direction) creature_ref
dbDispatchAction ["next"] = modifyMenuState (+1)
dbDispatchAction ["prev"] = modifyMenuState (subtract 1)
dbDispatchAction ["select-menu"] =
do state <- playerState
i <- menuState
tool_table <- toolsToMenuTable =<< toolMenuElements
let selection = maybe "0" (\(_,tool_ref,_) -> B.pack $ show $ toUID tool_ref) $ find (\(n,_,_) -> Just n == i) tool_table
case state of
PlayerCreatureTurn _ player_mode -> case player_mode of
PickupMode {} -> dbDispatchAction ["pickup",selection]
DropMode {} -> dbDispatchAction ["drop",selection]
WieldMode {} -> dbDispatchAction ["wield",selection]
MakeMode {} -> dbDispatchAction ["make-with",selection]
_ -> throwError $ DBError $ "protocol-error: not in menu selection state"
_ -> throwError $ DBError $ "protocol-error: not in player turn state"
dbDispatchAction ["make-begin"] = dbRequiresPlayerTurnState $ \creature_ref ->
setPlayerState (PlayerCreatureTurn creature_ref (MakeMode 0 prepare_make))
dbDispatchAction ["make-what",what] | (Just device_kind) <- readDeviceKind what =
do state <- playerState
case state of
PlayerCreatureTurn c (MakeMode n make_prep) -> (setPlayerState $ PlayerCreatureTurn c $ MakeMode n (make_prep `makeWith` device_kind))
_ -> throwError $ DBError $ "protocol-error: not in make or make-what state"
dbDispatchAction ["make-with",tool_uid] =
do tool_ref <- readUID ToolRef tool_uid
tool <- dbGetTool tool_ref
state <- playerState
case state of
PlayerCreatureTurn c (MakeMode _ make_prep) -> case (hasChromalite tool, hasMaterial tool, hasGas tool) of
(Just ch,_,_) | needsChromalite make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (ch,tool_ref))
(_,Just m,_) | needsMaterial make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (m,tool_ref))
(_,_,Just g) | needsGas make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (g,tool_ref))
_ | otherwise -> throwError $ DBError "error: tool doesn't have needed substance"
_ -> throwError $ DBError "protocol-error: not in make or make-what state"
dbDispatchAction ["make-end"] =
do state <- playerState
case state of
PlayerCreatureTurn c (MakeMode _ make_prep) | isFinished make_prep -> dbPerformPlayerTurn (Make make_prep) c
PlayerCreatureTurn _ (MakeMode {}) -> throwError $ DBError "protocol-error: make isn't complete"
_ -> throwError $ DBError "protocol-error: not in make or make-what state"
dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref ->
do pickups <- dbAvailablePickups creature_ref
case pickups of
[tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag NothingAtFeet
_ -> setPlayerState (PlayerCreatureTurn creature_ref (PickupMode 0))
dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Pickup tool_ref) creature_ref
dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref ->
do inventory <- dbGetContents creature_ref
case inventory of
[tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag NothingInInventory
_ -> setPlayerState (PlayerCreatureTurn creature_ref (DropMode 0))
dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Drop tool_ref) creature_ref
dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref ->
do available <- availableWields creature_ref
case available of
[tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag NothingInInventory
_ -> setPlayerState (PlayerCreatureTurn creature_ref (WieldMode 0))
dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Wield tool_ref) creature_ref
dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref
dbDispatchAction ["fire"] =
dbRequiresPlayerTurnState $ \creature_ref -> rangedAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref FireMode)
dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref
dbDispatchAction ["attack"] =
dbRequiresPlayerTurnState $ \creature_ref -> meleeAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref AttackMode)
dbDispatchAction ["attack",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Attack $ fromJust $ stringToFacing direction) creature_ref
dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Activate creature_ref
dbDispatchAction unrecognized = throwError $ DBError $ ("protocol-error: unrecognized action `" ++ (B.unpack $ B.unwords unrecognized) ++ "`")
dbSelectPlayerRace :: B.ByteString -> DB ()
dbSelectPlayerRace race_name =
case find (\s -> B.map toLower (B.pack $ show s) == race_name) player_species of
Nothing -> throwError $ DBError $ "protocol-error: unrecognized race '" ++ B.unpack race_name ++ "'"
Just species -> generateInitialPlayerCreature species
dbSelectPlayerClass :: B.ByteString -> Creature -> DB ()
dbSelectPlayerClass class_name creature =
let eligable_base_classes = getEligableBaseCharacterClasses creature
in case find (\x -> (B.map toLower . B.pack . show) x == class_name) eligable_base_classes of
Nothing -> throwError $ DBError $ "protocol-error: unrecognized or invalid class '" ++ B.unpack class_name ++ "'"
Just the_class -> dbBeginGame creature the_class
dbRerollRace :: Creature -> DB ()
dbRerollRace _ = do starting_race <- dbGetStartingRace
generateInitialPlayerCreature $ fromJust starting_race
dbQueryPlayerStats :: (DBReadable db) => Creature -> db B.ByteString
dbQueryPlayerStats creature = return $ playerStatsTable creature
-- |
-- Generate a list of tools, e.g. for an inventory list or pickup list.
-- The data source is selected on a context-sensitive basis.
--
toolMenuElements :: (DBReadable db) => db [ToolRef]
toolMenuElements =
do state <- playerState
case state of
PlayerCreatureTurn c (PickupMode {}) -> dbAvailablePickups c
PlayerCreatureTurn c (WieldMode {}) -> availableWields c
PlayerCreatureTurn c (MakeMode _ make_prep) | needsChromalite make_prep -> filterM (liftM (isJust . hasChromalite) . dbGetTool) =<< availableWields c
PlayerCreatureTurn c (MakeMode _ make_prep) | needsMaterial make_prep -> filterM (liftM (isJust . hasMaterial) . dbGetTool) =<< availableWields c
PlayerCreatureTurn c (MakeMode _ make_prep) | needsGas make_prep -> filterM (liftM (isJust . hasGas) . dbGetTool) =<< availableWields c
PlayerCreatureTurn c _ -> dbGetContents c
_ -> return []
-- |
-- Convert a list of tool menu elements into table row entries.
-- The result entries consist of an index incrementing from zero, ToolRef, and name of the tool.
--
toolsToMenuTable :: (DBReadable db) => [ToolRef] -> db [(Integer,ToolRef,B.ByteString)]
toolsToMenuTable raw_uids =
do let uids = sortBy (comparing toUID) raw_uids
tool_names <- mapM (liftM toolName . dbGetTool) uids
return $ zip3 [0..] uids tool_names
-- |
-- Generate a tool menu table in text form, with the specified name and element list.
--
showToolMenuTable :: B.ByteString -> B.ByteString -> [(Integer,ToolRef,B.ByteString)] -> B.ByteString
showToolMenuTable table_name table_id tool_table =
"begin-table " `B.append` table_name `B.append` " " `B.append` table_id `B.append` " n uid name" `B.append` "\n" `B.append`
B.unlines (map (\(n,uid,tool_name) -> B.unwords [B.pack $ show n,B.pack $ show $ toUID uid,tool_name]) tool_table) `B.append`
"end-table"
-- |
-- Information about player creatures (for which the player should have almost all available information.)
--
playerStatsTable :: Creature -> B.ByteString
playerStatsTable c =
"begin-table player-stats 0 property value\n" `B.append`
"str " `B.append` (B.pack $ show $ rawScore Strength c) `B.append` "\n" `B.append`
"spd " `B.append` (B.pack $ show $ rawScore Speed c) `B.append` "\n" `B.append`
"con " `B.append` (B.pack $ show $ rawScore Constitution c) `B.append` "\n" `B.append`
"int " `B.append` (B.pack $ show $ rawScore Intellect c) `B.append` "\n" `B.append`
"per " `B.append` (B.pack $ show $ rawScore Perception c) `B.append` "\n" `B.append`
"cha " `B.append` (B.pack $ show $ rawScore Charisma c) `B.append` "\n" `B.append`
"mind " `B.append` (B.pack $ show $ rawScore Mindfulness c) `B.append` "\n" `B.append`
"maxhp " `B.append` (B.pack $ show $ creatureAbilityScore ToughnessTrait c) `B.append` "\n" `B.append`
"species " `B.append` (B.pack $ show $ creature_species c) `B.append` "\n" `B.append`
"random-id " `B.append` (B.pack $ show $ creature_random_id c) `B.append` "\n" `B.append`
"gender " `B.append` (B.pack $ show $ creatureGender c) `B.append` "\n" `B.append`
"end-table"
toolName :: Tool -> B.ByteString
toolName (DeviceTool _ d) = deviceName d
toolName (Sphere s) = prettySubstance s
toolType :: Tool -> B.ByteString
toolType (DeviceTool Gun _) = "gun"
toolType (DeviceTool Sword _) = "sword"
toolType (Sphere (GasSubstance _)) = "sphere-gas"
toolType (Sphere (MaterialSubstance _)) = "sphere-material"
toolType (Sphere (ChromaliteSubstance _)) = "sphere-chromalite"
dbQueryBaseClasses :: (DBReadable db) => Creature -> db B.ByteString
dbQueryBaseClasses creature = return $ baseClassesTable creature
baseClassesTable :: Creature -> B.ByteString
baseClassesTable creature =
"begin-table base-classes 0 class\n" `B.append`
(B.unlines $ map (B.pack . show) $ getEligableBaseCharacterClasses creature) `B.append`
"end-table"
dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db B.ByteString
dbQueryCenterCoordinates creature_ref =
do l <- dbWhere creature_ref
case (extractLocation l,extractLocation l :: Maybe Facing) of
(Just (Position (x,y)),Nothing) ->
return (begin_table `B.append`
"x " `B.append` B.pack (show x) `B.append` "\n" `B.append`
"y " `B.append` B.pack (show y) `B.append` "\n" `B.append`
"end-table")
(Just (Position (x,y)),Just face) ->
return (begin_table `B.append`
"x " `B.append` B.pack (show x) `B.append` "\n" `B.append`
"y " `B.append` B.pack (show y) `B.append` "\n" `B.append`
"facing " `B.append` B.pack (show face) `B.append` "\n" `B.append`
"end-table")
_ -> return (begin_table `B.append` "end-table")
where begin_table = "begin-table center-coordinates 0 axis coordinate\n"
readUID :: (Integer -> Reference a) -> B.ByteString -> DB (Reference a)
readUID f x =
do let m_uid = readNumber x
ok <- maybe (return False) (dbVerify . f) m_uid
when (not ok) $ throwError $ DBError $ "protocol-error: " ++ B.unpack x ++ " is not a valid uid."
return $ f $ fromJust m_uid
readNumber :: B.ByteString -> Maybe Integer
readNumber = fmap fst . B.readInteger
readDeviceKind :: B.ByteString -> Maybe DeviceKind
readDeviceKind "pistol" = Just Pistol
readDeviceKind "carbine" = Just Carbine
readDeviceKind "rifle" = Just Rifle
readDeviceKind "fleuret" = Just Fleuret
readDeviceKind "sabre" = Just Sabre
readDeviceKind _ = Nothing