\section{Actions}
\begin{code}
module Actions
(takeUserInputAction,
getValidActions,
ActionInput(..),
select_race_action_names,
select_base_class_action_names,
executeContinueAction)
where
import System.Exit
import Control.Monad
import Control.Monad.Error
import Driver
import Data.IORef
import Data.List
import PrintText
import Tables
import Data.Maybe
import System.IO
data ActionInput = ActionInput {
action_driver_object :: DriverObject,
action_print_text_object :: PrintTextObject }
type Action = ActionInput -> ErrorT String IO (IO ())
actionValid :: ActionInput -> Action -> IO Bool
actionValid action_input action =
do result <- runErrorT $ action action_input
return $ either (const False) (const True) result
executeAction :: ActionInput -> Action -> IO ()
executeAction action_input action =
do result <- runErrorT $ action action_input
either (\s -> printText (action_print_text_object action_input) UnexpectedEvent ("unable to execute action: " ++ s))
(id)
result
return ()
executeContinueAction :: ActionInput -> IO ()
executeContinueAction action_input =
do either (const $ return()) id =<< (runErrorT $ (snd continue_action) action_input)
return ()
quit_action :: (String,Action)
quit_action = ("quit",
\_ -> return $ exitWith ExitSuccess)
-- |
-- Constructs an action such that the action is valid only if it is listed in
-- a table from the engine. The first parameter identifies the table column to look up,
-- (table name, table id, header to look under). The second parameter is the name of the
-- action as it will be send to the engine. The third parameter is the action_param.
-- The action_param must be listed under the specified header of the specified table,
-- or the action will not be allowed to execute.
--
-- For example: selectTableAction ("people","0","name") "select-person-to-call-state" "call-with-telephone" "carl"
--
-- \> game query state
-- answer: state select-person-to-call-state
-- \> game query people
-- begin-table people 0 name
-- john
-- wendy
-- carl
-- bob
-- end-table
-- \> game action call-with-telephone Carl
--
-- In this case the action executes because the state is actually select-person-to-call-state and Carl
-- is actually listed under the "name" header of the "people" table.
--
-- In practice this function is used for things like the race-selection-state and the class-selection-state
-- where we select from a predifined list of possible choices, but the engine further restricts the choices.
-- Each possible choice is it's own action that will only return action_valid if it is listed in the appropriate
-- table from the engine.
--
selectTableAction :: (String,String,String) -> String -> String -> String -> Action
selectTableAction (the_table_name,the_table_id,the_table_header) allowed_state action_name action_param =
\action_input ->
do state <- maybe (fail "") return =<< (lift $ driverGetAnswer (action_driver_object action_input) "state")
guard $ state == allowed_state
table <- maybe (fail "") return =<< (lift $ driverGetTable (action_driver_object action_input) the_table_name the_table_id)
guard $ [action_param] `elem` tableSelect table [the_table_header]
return $ driverAction (action_driver_object action_input) [action_name, action_param]
-- |
-- An action that depends on the state flag of the game engine and an arbitrary constant parameter.
-- For example, actions that operate directionally are parameterized
-- on the eight directions (n,s,w,e,nw,ne,sw,se).
--
-- i.e., parameterizedAction "player-turn" "move" "nw" becomes
-- ("move-nw",driverAction _ ["move","nw"])
--
parameterizedAction :: String -> String -> String -> (String,Action)
parameterizedAction allowed_state action_name parameter =
(action_name ++ "-" ++ parameter,
stateGuard allowed_state $ \action_input ->
return $ driverAction (action_driver_object action_input) [action_name,parameter])
-- |
-- Guard an action to only run during a specific state.
--
stateGuard :: String -> Action -> Action
stateGuard allowed_state actionM action_input =
do guard =<< (liftM (== Just allowed_state) $ lift $ driverGetAnswer (action_driver_object action_input) "state")
actionM action_input
-- |
-- An action that depends just on the state flag of the game engine.
--
stateLinkedAction :: String -> String -> (String,Action)
stateLinkedAction allowed_state action_name =
(action_name,
stateGuard allowed_state $ \action_input ->
return $ driverAction (action_driver_object action_input) [action_name])
continue_action :: (String,Action)
continue_action = ("continue",\action_input ->
do guard =<< (liftM (== Just "yes") $ lift $ driverGetAnswer (action_driver_object action_input) "snapshot")
return $ driverAction (action_driver_object action_input) ["continue"])
moveAction :: String -> (String,Action)
moveAction = parameterizedAction "player-turn" "move"
turnAction :: String -> (String,Action)
turnAction = parameterizedAction "player-turn" "turn"
fireAction :: String -> (String,Action)
fireAction = parameterizedAction "player-turn" "fire"
reroll_action :: (String,Action)
reroll_action = stateLinkedAction "class-selection" "reroll"
pickup_action :: (String,Action)
pickup_action = stateLinkedAction "player-turn" "pickup"
drop_action :: (String,Action)
drop_action = stateLinkedAction "player-turn" "drop"
wield_action :: (String,Action)
wield_action = stateLinkedAction "player-turn" "wield"
unwield_action :: (String,Action)
unwield_action = stateLinkedAction "player-turn" "unwield"
selectRaceAction :: String -> (String,Action)
selectRaceAction s =
(s,selectTableAction ("player-races","0","name") "race-selection" "select-race" s)
selectBaseClassAction :: String -> (String,Action)
selectBaseClassAction s =
(s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s)
select_race_action_names :: [String]
select_race_action_names = [--"anachronid",
"androsynth",
"ascendant",
"caduceator",
"encephalon",
--"goliath",
--"hellion",
--"kraken",
--"myrmidon",
--"perennial",
"recreant",
"reptilian"]
select_race_actions :: [(String,Action)]
select_race_actions = map selectRaceAction select_race_action_names
select_base_class_action_names :: [String]
select_base_class_action_names = ["barbarian",
"consular",
"engineer",
"forceadept",
"marine",
"ninja",
"pirate",
"scout",
"shepherd",
"thief",
"warrior"]
select_base_class_actions :: [(String,Action)]
select_base_class_actions = map selectBaseClassAction select_base_class_action_names
eight_directions :: [String]
eight_directions = ["n","ne","nw","e","w","se","sw","s"]
move_actions :: [(String,Action)]
move_actions = map moveAction eight_directions
turn_actions :: [(String,Action)]
turn_actions = map turnAction eight_directions
fire_actions :: [(String,Action)]
fire_actions = map fireAction eight_directions
all_actions :: [(String,Action)]
all_actions = [continue_action,quit_action,reroll_action,pickup_action,drop_action,wield_action,unwield_action] ++
select_race_actions ++
select_base_class_actions ++
move_actions ++
turn_actions ++
fire_actions
lookupAction :: String -> (String,Action)
lookupAction x = (x,fromMaybe (error $ "tried to operate on an unknown action named " ++ x) $ lookup x all_actions)
-- |
-- Answer a complete list of all actions that can be run at this time.
-- Accepts an optional list of action names to choose from; if Nothing,
-- uses all concievable actions as that list.
--
getValidActions :: ActionInput -> Maybe [String] -> IO [String]
getValidActions action_input actions_list =
do valid_action_pairs <- filterM (actionValid action_input . snd) $
maybe all_actions (map lookupAction) actions_list
return $ map fst valid_action_pairs
-- |
-- Takes a list of action names and executes the first action in the list that is valid
-- in the current context, based on each action's action_valid entry.
-- Returns True if an action was taken, False otherwise.
--
takeUserInputAction :: ActionInput -> [String] -> IO Bool
takeUserInputAction _ [] = return False
takeUserInputAction action_input action_names =
do valid_actions <- getValidActions action_input (Just action_names)
let action = map lookupAction valid_actions
case length action of
0 -> return False
1 -> do executeAction action_input $ snd $ head action
return True
_ -> do hPutStrLn stderr ("Action bindings warning: multiple valid action for binding: " ++ (concat $ intersperse ", " $ map fst action))
executeAction action_input $ snd $ head action
return True
\end{code}