{-# LANGUAGE ExistentialQuantification, PatternSignatures #-}
module Protocol
(mainLoop)
where
import Data.Char
import Data.List as List
import CreatureData
import Creature
import Character
import StatsData
import DB
import DBData
import System.Exit
import Races
import System.IO
import BeginGame
import Data.Maybe
import Plane
import Tool
import FactionData
import PlaneVisibility
import Facing
import ToolData
import Control.Monad.Error
import Numeric
import Turns
-- 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(..))
mainLoop :: DB_BaseType -> IO ()
mainLoop db0 = do next_command <- getLine
db1 <- ioDispatch (words $ map toLower next_command) db0
putStrLn "over"
hFlush stdout
mainLoop db1
done :: DB String
done = return "done"
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 String -> db String
dbRequiresRaceSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
RaceSelectionState -> action
_ -> return $ "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 String) -> db String
dbRequiresClassSelectionState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
ClassSelectionState creature -> action creature
_ -> return $ "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:
--
-- DBClassSelectionState
-- DBPlayerCreatureTurn
--
dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db String) -> db String
dbRequiresPlayerCenteredState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
ClassSelectionState creature -> action creature
PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
_ -> return $ "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:
--
-- DBPlayerCreaturePickupMode
-- DBEvent
--
dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String
dbRequiresPlanarTurnState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
PlayerCreatureTurn creature_ref _ -> action creature_ref
SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> action attacker_ref
SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> action attacker_ref
SnapshotEvent (KilledEvent killed_ref) -> action killed_ref
_ -> return $ "protocol-error: not in planar turn state (" ++ show state ++ ")"
-- |
-- Perform an action that works only during a player-character's turn.
-- The states that work for this are:
--
-- DBPlayerCreatureTurn
--
dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db String) -> db String
dbRequiresPlayerTurnState action =
do dbOldestSnapshotOnly
state <- playerState
case state of
PlayerCreatureTurn creature_ref _ -> action creature_ref
_ -> return $ "protocol-error: not in player turn state (" ++ show state ++ ")"
ioDispatch :: [String] -> DB_BaseType -> IO DB_BaseType
ioDispatch ["quit"] _ = exitWith ExitSuccess
ioDispatch ["reset"] _ = do putStrLn "done"
return initial_db
ioDispatch ("game":game) db0 =
do a <- case game of
["query","snapshot"] -> runDB (ro $ liftM (\b -> "answer: snapshot " ++ if b then "yes" else "no") $ dbHasSnapshot) db0
("query":args) -> runDB (ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0
("action":args) -> runDB (dbDispatchAction args) db0
_ -> return $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ unwords game ++ "`"
case a of
Right (outstr,db1) ->
do putStrLn (map toLower outstr)
return db1
Left (DBErrorFlag errstr) ->
do putStrLn "done"
return $ db0 { db_error_flag = errstr }
Left (DBError errstr) ->
do putStrLn (map toLower errstr ++ "\n")
return db0
ioDispatch ("save":_) db0 = do putStrLn "engine-error: save not implemented"
return db0
ioDispatch ("load":_) db0 = do putStrLn "engine-error: load not implemented"
return db0
ioDispatch ("noop":_) db0 = return db0
ioDispatch unknown_command db0 = do putStrLn ("protocol-error: unknown command " ++ (unwords unknown_command))
return db0
dbDispatchQuery :: (DBReadable db) => [String] -> db String
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 _ PickupMode -> "answer: state pickup"
PlayerCreatureTurn _ DropMode -> "answer: state drop"
PlayerCreatureTurn _ WieldMode -> "answer: state wield"
SnapshotEvent (AttackEvent {}) -> "answer: state attack"
SnapshotEvent (MissEvent {}) -> "answer: state miss"
SnapshotEvent (KilledEvent {}) -> "answer: state killed"
GameOver -> "answer: state game-over"
dbDispatchQuery ["who-attacks"] =
do state <- playerState
return $ case state of
SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " ++ (show $ toUID attacker_ref)
SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " ++ (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 " ++ (show $ toUID target_ref)
_ -> "answer: who-hit 0"
dbDispatchQuery ["weapon-used"] =
do state <- playerState
return $ case state of
SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)
SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " ++ (show $ toUID weapon_ref)
_ -> "answer: weapon-used 0"
dbDispatchQuery ["who-killed"] =
do state <- playerState
return $ case state of
SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " ++ (show $ toUID killed_ref)
_ -> "answer: who-killed 0"
dbDispatchQuery ["player-races","0"] =
return ("begin-table player-races 0 name\n" ++
unlines player_race_names ++
"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" ++
(unlines $ map (\(terrain_type,Position (x,y)) -> unwords [show x, show y, show terrain_type]) terrain_map) ++
"end-table")
dbDispatchQuery ["visible-objects","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
(objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref
table_rows <- mapM (dbObjectToTableRow . entity) objects
return ("begin-table visible-objects 0 object-unique-id x y facing\n" ++
(unlines $ table_rows) ++
"end-table")
where dbObjectToTableRow obj_ref =
do l <- dbWhere obj_ref
return $ case (extractLocation l,extractLocation l) of
(Just (Position (x,y)),maybe_face) -> unwords [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
_ -> ""
dbDispatchQuery ["object-details",_] = ro $
do maybe_plane_ref <- dbGetCurrentPlane
(visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) 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
creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs
tools <- liftM (zip tool_refs)$ mapRO dbGetTool tool_refs
return $ unlines $ (map creatureToTableData creatures ++
map toolToTableData tools)
where objectTableWrapper obj_ref table_data =
("begin-table object-details " ++
(show $ toUID obj_ref) ++
" property value\n" ++
table_data ++
"end-table")
creatureToTableData :: (CreatureRef,Creature) -> String
creatureToTableData (ref,creature) = objectTableWrapper ref $
"object-type creature\n" ++
(concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ creatureStatsData creature)
toolToTableData :: (ToolRef,Tool) -> String
toolToTableData (ref,tool) = objectTableWrapper ref $
"object-type tool\n" ++
(concat $ map (\x -> fst x ++ " " ++ snd x ++ "\n") $ toolData tool)
dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCenterCoordinates
dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses
dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
do pickups <- dbAvailablePickups creature_ref
return $ "begin-table pickups 0 uid\n" ++
unlines (map (show . toUID) pickups) ++
"end-table"
dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
do (inventory :: [ToolRef]) <- dbGetContents creature_ref
return $ "begin-table inventory 0 uid\n" ++
unlines (map (show . toUID) inventory) ++
"end-table"
dbDispatchQuery ["wielded-objects","0"] =
do m_plane_ref <- dbGetCurrentPlane
creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction Player) m_plane_ref
wielded_tool_refs <- mapM dbGetWielded creature_refs
let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe String
wieldedPairToTable creature_ref = fmap (\tool_ref -> (show $ toUID tool_ref) ++ " " ++ (show $ toUID creature_ref))
return $ "begin-table wielded-objects 0 uid creature\n" ++
unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) ++
"end-table"
dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" ++ unwords unrecognized ++ "`"
dbDispatchAction :: [String] -> DB String
dbDispatchAction ["continue"] = dbPopOldestSnapshot >> done
dbDispatchAction ["select-race",race_name] =
dbRequiresRaceSelectionState $ dbSelectPlayerRace race_name
dbDispatchAction ["reroll"] =
dbRequiresClassSelectionState $ dbRerollRace
dbDispatchAction ["select-class",class_name] =
dbRequiresClassSelectionState $ dbSelectPlayerClass class_name
dbDispatchAction ["move",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref >> done)
dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction =
dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref >> done)
dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref ->
do pickups <- dbAvailablePickups creature_ref
case pickups of
[tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag "nothing-there"
_ -> setPlayerState (PlayerCreatureTurn creature_ref PickupMode)
done
dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Pickup tool_ref) creature_ref
done
dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref ->
do inventory <- dbGetContents creature_ref
case inventory of
[tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag "nothing-in-inventory"
_ -> setPlayerState (PlayerCreatureTurn creature_ref DropMode)
done
dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Drop tool_ref) creature_ref
done
dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref ->
do inventory <- dbGetContents creature_ref
case inventory of
[tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return ()
[] -> throwError $ DBErrorFlag "nothing-in-inventory"
_ -> setPlayerState (PlayerCreatureTurn creature_ref WieldMode)
done
dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
do tool_ref <- readUID ToolRef tool_uid
dbPerformPlayerTurn (Wield tool_ref) creature_ref
done
dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref >> done
dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref >> done
dbDispatchAction unrecognized = return ("protocol-error: unrecognized action `" ++ (unwords unrecognized) ++ "`")
dbSelectPlayerRace :: String -> DB String
dbSelectPlayerRace race_name = case (selectPlayerRace race_name)
of
Nothing -> return ("protocol-error: unrecognized race '" ++ race_name ++ "'")
Just species -> do dbGenerateInitialPlayerCreature species
done
dbSelectPlayerClass :: String -> Creature -> DB String
dbSelectPlayerClass class_name creature =
let eligable_base_classes = getEligableBaseCharacterClasses creature
in case find (\x -> (map toLower . show) x == class_name) eligable_base_classes of
Nothing -> return ("protocol-error: unrecognized or invalid class '" ++ class_name ++ "'")
Just the_class -> do dbBeginGame creature the_class
done
dbRerollRace :: Creature -> DB String
dbRerollRace _ = do starting_race <- dbGetStartingRace
dbGenerateInitialPlayerCreature $ fromJust starting_race
done
dbQueryPlayerStats :: (DBReadable db) => Creature -> db String
dbQueryPlayerStats creature = return $ playerStatsTable creature
-- |
-- Information about player creatures (for which the player should have almost all available information.)
--
playerStatsTable :: Creature -> String
playerStatsTable c =
"begin-table player-stats 0 property value\n" ++
"str " ++ (show $ str c) ++ "\n" ++
"dex " ++ (show $ dex c) ++ "\n" ++
"con " ++ (show $ con c) ++ "\n" ++
"int " ++ (show $ int c) ++ "\n" ++
"per " ++ (show $ per c) ++ "\n" ++
"cha " ++ (show $ cha c) ++ "\n" ++
"mind " ++ (show $ mind c) ++ "\n" ++
"hp " ++ (show $ creatureScore HitPoints c) ++ "\n" ++
"maxhp " ++ (show $ creatureScore MaxHitPoints c) ++ "\n" ++
"species " ++ (creature_species_name c) ++ "\n" ++
"random-id " ++ (show $ creature_random_id c) ++ "\n" ++
"effective-level " ++ (show $ creatureScore EffectiveLevel c) ++ "\n" ++
"gender " ++ (show $ creatureGender c) ++ "\n" ++
"end-table"
-- |
-- Information about non-player creatures (for which there are very strict limits on what information
-- the player can have). The result is in (Property,Value) form so that the result can easily be
-- manipulated by the caller.
--
creatureStatsData :: Creature -> [(String,String)]
creatureStatsData c = [("percent-hp",show $ (creatureScore HitPoints c * 100) `div` creatureScore MaxHitPoints c),
("species",creature_species_name c),
("random-id",show $ creature_random_id c)]
-- |
-- Information about non-owned tools.
--
toolData :: Tool -> [(String,String)]
toolData g@(GunTool {}) = [("tool-type","gun"),
("tool",toolName g)]
dbQueryBaseClasses :: (DBReadable db) => Creature -> db String
dbQueryBaseClasses creature = return $ baseClassesTable creature
baseClassesTable :: Creature -> String
baseClassesTable creature =
"begin-table base-classes 0 class\n" ++
(unlines $ map show $ getEligableBaseCharacterClasses creature) ++
"end-table"
dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db String
dbQueryCenterCoordinates creature_ref =
do l <- dbWhere creature_ref
case (extractLocation l,extractLocation l :: Maybe Facing) of
(Just (Position (x,y)),Nothing) ->
return (begin_table ++
"x " ++ show x ++ "\n" ++
"y " ++ show y ++ "\n" ++
"end-table")
(Just (Position (x,y)),Just face) ->
return (begin_table ++
"x " ++ show x ++ "\n" ++
"y " ++ show y ++ "\n" ++
"facing " ++ show face ++ "\n" ++
"end-table")
_ -> return (begin_table ++ "end-table")
where begin_table = "begin-table center-coordinates 0 axis coordinate\n"
readUID :: (Integer -> Reference a) -> String -> DB (Reference a)
readUID f x =
do let m_uid = fmap fst $ listToMaybe $ filter (null . snd) $ readDec x
ok <- maybe (return False) (dbVerify . f) m_uid
when (not ok) $ throwError $ DBError $ "protocol-error: " ++ x ++ " is not a valid uid."
return $ f $ fromJust m_uid