{-# LANGUAGE OverloadedStrings #-}
-- |
-- A set of actions that should be bound to keystrokes.
--
module Actions
(takeUserInputAction,
getValidActions,
ActionInput(..),
select_race_action_names,
select_base_class_action_names,
make_what_action_names,
executeContinueAction,
menu_states,
player_turn_states)
where
import Control.Monad.Error
import Driver
import Data.List
import PrintText
import Tables
import Data.Maybe
import Globals
import RSAGL.Types
import Control.Concurrent.STM
import Quality
import Data.Char
import qualified Data.ByteString.Char8 as B
-- |
-- Input to an action.
--
data ActionInput = ActionInput {
action_globals :: Globals,
action_driver_object :: DriverObject,
action_print_text_object :: PrintTextObject }
type Action = ActionInput -> ErrorT ActionValidityReason STM (STM ())
data ActionValidity = Go | Hold ActionValidityReason deriving (Read, Show)
data ActionValidityReason = Invalid | Undecided String deriving (Read,Show)
instance Error ActionValidityReason where
noMsg = strMsg ""
strMsg = Undecided
invalid :: ErrorT ActionValidityReason STM ()
invalid = throwError Invalid
isUndecided :: ActionValidity -> Bool
isUndecided (Hold (Undecided _)) = True
isUndecided _ = False
isGo :: ActionValidity -> Bool
isGo Go = True
isGo _ = False
{----------------------------------------------------------
-- Support functions for Actions
----------------------------------------------------------}
actionValid :: ActionInput -> Action -> STM ActionValidity
actionValid action_input action =
do result <- runErrorT $ action action_input
return $ either Hold (const Go) result
executeAction :: ActionInput -> Action -> STM ()
executeAction action_input action =
do result <- runErrorT $ action action_input
either (\failure -> printText
(action_print_text_object action_input)
UnexpectedEvent
("unable to execute action: " `B.append`
B.pack (show failure)))
(id)
result
return ()
executeContinueAction :: ActionInput -> STM ()
executeContinueAction action_input =
do either (const $ return()) id =<< (runErrorT $ (snd continue_action) action_input)
return ()
-- |
-- 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 :: (B.ByteString,B.ByteString,B.ByteString) -> B.ByteString -> B.ByteString -> B.ByteString -> Action
selectTableAction (the_table_name,the_table_id,the_table_header) allowed_state action_name action_param = stateGuard [allowed_state] $
\action_input ->
do table <- maybe (fail $ "need table " ++ B.unpack the_table_name) return =<< (lift $ getTable (action_driver_object action_input) the_table_name the_table_id)
unless ([action_param] `elem` tableSelect table [the_table_header]) invalid
return $ driverAction (action_driver_object action_input) [action_name, action_param]
-- |
-- Guard an action to only run during specific states.
--
stateGuard :: [B.ByteString] -> Action -> Action
stateGuard allowed_states actionM action_input =
do is_valid_state <- liftM (maybe False (`elem` allowed_states)) $ lift $ getAnswer (action_driver_object action_input) "state"
unless is_valid_state invalid
actionM action_input
-- |
-- A simple action that can run whenever the player state is a member of a given list.
-- The action name is passed directly to the engine.
--
stateLinkedAction :: [B.ByteString] -> B.ByteString -> (B.ByteString,Action)
stateLinkedAction allowed_state action_name =
(action_name,
stateGuard allowed_state $ \action_input ->
return $ driverAction (action_driver_object action_input) [action_name])
-- |
-- An action that can always run, like "quit".
--
alwaysAction :: B.ByteString -> (ActionInput -> STM ()) -> (B.ByteString,Action)
alwaysAction action_name actionSTM =
(action_name,
\action_input -> return $ actionSTM action_input)
{----------------------------------------------------------
Specific Actions
----------------------------------------------------------}
player_turn_states :: [B.ByteString]
player_turn_states = ["player-turn","move","attack","fire","jump","turn","clear-terrain"]
menu_states :: [B.ByteString]
menu_states = ["race-selection","class-selection","pickup","drop","wield","make","make-finished","make-what"]
selectable_menu_states :: [B.ByteString]
selectable_menu_states = if all (`elem` menu_states) states then states else error "selectable_menu_states: inconsistent with menu_states"
where states = ["pickup","drop","wield","make"]
quit_action :: (B.ByteString,Action)
quit_action = alwaysAction "quit" $ \action_input ->
writeTVar (global_should_quit $ action_globals action_input) True
continue_action :: (B.ByteString,Action)
continue_action = ("continue",\action_input ->
do is_snapshot <- liftM (== Just "yes") $ lift $ getAnswer (action_driver_object action_input) "snapshot"
unless is_snapshot invalid
return $ driverAction (action_driver_object action_input) ["continue"])
direction_actions :: [(B.ByteString,Action)]
direction_actions = map (stateLinkedAction player_turn_states) ["n","ne","e","se","s","sw","w","nw"]
next_action :: (B.ByteString,Action)
next_action = stateLinkedAction selectable_menu_states "next"
prev_action :: (B.ByteString,Action)
prev_action = stateLinkedAction selectable_menu_states "prev"
select_menu_action :: (B.ByteString,Action)
select_menu_action = stateLinkedAction selectable_menu_states "select-menu"
normal_action :: (B.ByteString,Action)
normal_action = ("normal",
stateGuard (menu_states ++ player_turn_states) $ \action_input ->
return $ driverAction (action_driver_object action_input) ["normal"])
move_action :: (B.ByteString,Action)
move_action = stateLinkedAction player_turn_states "move"
jump_action :: (B.ByteString,Action)
jump_action = stateLinkedAction player_turn_states "jump"
turn_action :: (B.ByteString,Action)
turn_action = stateLinkedAction player_turn_states "turn"
fire_action :: (B.ByteString,Action)
fire_action = stateLinkedAction player_turn_states "fire"
attack_action :: (B.ByteString,Action)
attack_action = stateLinkedAction player_turn_states "attack"
clear_terrain_action :: (B.ByteString,Action)
clear_terrain_action = stateLinkedAction player_turn_states "clear-terrain"
reroll_action :: (B.ByteString,Action)
reroll_action = stateLinkedAction ["class-selection"] "reroll"
pickup_action :: (B.ByteString,Action)
pickup_action = stateLinkedAction player_turn_states "pickup"
drop_action :: (B.ByteString,Action)
drop_action = stateLinkedAction player_turn_states "drop"
wield_action :: (B.ByteString,Action)
wield_action = stateLinkedAction player_turn_states "wield"
unwield_action :: (B.ByteString,Action)
unwield_action = stateLinkedAction player_turn_states "unwield"
activate_action :: (B.ByteString,Action)
activate_action = stateLinkedAction player_turn_states "activate"
make_begin_action :: (B.ByteString,Action)
make_begin_action = stateLinkedAction player_turn_states "make-begin"
make_what_action_names :: [B.ByteString]
make_what_action_names = ["pistol","carbine","rifle","fleuret","sabre"]
makeWhatAction :: B.ByteString -> (B.ByteString,Action)
makeWhatAction s = (s,
stateGuard ["make-what","make","make-finished"] $ \action_input ->
return $ driverAction (action_driver_object action_input) ["make-what",s])
make_what_actions :: [(B.ByteString,Action)]
make_what_actions = map makeWhatAction make_what_action_names
make_end_action :: (B.ByteString,Action)
make_end_action = stateLinkedAction ["make-finished"] "make-end"
selectRaceAction :: B.ByteString -> (B.ByteString,Action)
selectRaceAction s =
(s,selectTableAction ("player-races","0","name") "race-selection" "select-race" s)
selectBaseClassAction :: B.ByteString -> (B.ByteString,Action)
selectBaseClassAction s =
(s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s)
zoomSize :: RSdouble -> RSdouble
zoomSize x | x < 3 = 0.2
zoomSize x | x < 10 = 1.0
zoomSize _ | otherwise = 5.0
zoomIn :: RSdouble -> RSdouble
zoomIn x = x - (zoomSize $ x - zoomSize x)
zoomOut :: RSdouble -> RSdouble
zoomOut x = x + (zoomSize x)
zoom_in_action :: (B.ByteString,Action)
zoom_in_action = alwaysAction "zoom-in" $ \action_input ->
do writeTVar (global_planar_camera_distance $ action_globals action_input) .
(max 1.0 . zoomIn) =<< readTVar (global_planar_camera_distance $
action_globals action_input)
return ()
zoom_out_action :: (B.ByteString,Action)
zoom_out_action = alwaysAction "zoom-out" $ \action_input ->
do writeTVar (global_planar_camera_distance $ action_globals action_input) .
(min 25.0 . zoomOut) =<< readTVar (global_planar_camera_distance $
action_globals action_input)
return ()
sky_on_action :: (B.ByteString,Action)
sky_on_action = alwaysAction "sky-on" $ \action_input ->
do writeTVar (global_sky_on $ action_globals action_input) True
return ()
sky_off_action :: (B.ByteString,Action)
sky_off_action = alwaysAction "sky-off" $ \action_input ->
do writeTVar (global_sky_on $ action_globals action_input) False
return ()
setQualityAction :: Quality -> (B.ByteString,Action)
setQualityAction q =
alwaysAction (B.pack $ map toLower $ "quality-" ++ show q) $
\action_input ->
do writeTVar (global_quality_setting $ action_globals action_input) q
return ()
quality_bad :: (B.ByteString,Action)
quality_bad = setQualityAction Bad
quality_poor :: (B.ByteString,Action)
quality_poor = setQualityAction Poor
quality_good :: (B.ByteString,Action)
quality_good = setQualityAction Good
quality_super :: (B.ByteString,Action)
quality_super = setQualityAction Super
{----------------------------------------------------------
Lists of Known Actions
----------------------------------------------------------}
select_race_action_names :: [B.ByteString]
select_race_action_names = [--"anachronid",
"androsynth",
"ascendant",
"caduceator",
"encephalon",
--"goliath",
--"hellion",
--"kraken",
--"myrmidon",
--"perennial",
"recreant",
"reptilian"]
select_race_actions :: [(B.ByteString,Action)]
select_race_actions = map selectRaceAction select_race_action_names
select_base_class_action_names :: [B.ByteString]
select_base_class_action_names = ["barbarian",
"consular",
"engineer",
"forceadept",
"marine",
"ninja",
"pirate",
"scout",
"shepherd",
"thief",
"warrior"]
select_base_class_actions :: [(B.ByteString,Action)]
select_base_class_actions = map selectBaseClassAction select_base_class_action_names
-- | List of every convievable action.
all_actions :: [(B.ByteString,Action)]
all_actions = [continue_action,quit_action,reroll_action,
pickup_action,drop_action,wield_action,unwield_action,
next_action,prev_action,normal_action,select_menu_action,
zoom_in_action,zoom_out_action,sky_on_action,sky_off_action,
quality_bad,quality_poor,quality_good,quality_super] ++
select_race_actions ++
select_base_class_actions ++
direction_actions ++
make_what_actions ++
[move_action,turn_action,fire_action,jump_action,attack_action,clear_terrain_action,activate_action,
make_begin_action,make_end_action]
-- | Find an action with the given name.
lookupAction :: B.ByteString -> (B.ByteString,Action)
lookupAction x = (x,fromMaybe (error $ "tried to operate on an unknown action named " ++ B.unpack 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 [B.ByteString] -> STM [B.ByteString]
getValidActions action_input actions_list =
do valid_action_pairs <- mapM (\a -> liftM ((,) a) $ actionValid action_input $ snd a) $ maybe all_actions (map lookupAction) actions_list
return $ case () of
() | any (isUndecided . snd) valid_action_pairs -> []
() | otherwise -> map (fst . fst) $ filter (isGo . snd) 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 -> [B.ByteString] -> STM 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 driverSendError (action_driver_object action_input)
("Action bindings warning: multiple valid action for binding: " `B.append`
(B.concat $ intersperse ", " $ map fst action))
executeAction action_input $ snd $ head action
return True