diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,32 +1,134 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, OverloadedStrings #-} + module Main (main) where import System.Process import System.Exit +import System.Console.GetOpt import Control.Concurrent -import System.Environment import System.FilePath import System.IO import Control.Monad import Paths_roguestar_gl +import GHC.Environment +import System.Time +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import GHC.Exts (IsString(..)) +data Args = Args { + arg_echo_protocol :: Bool, + arg_single_threaded :: Bool, + arg_verbose :: Bool, + arg_help :: Bool, + arg_prefix :: String, + arg_engine :: [String], + arg_client :: [String] } + +roguestar_options :: [OptDescr (Args -> Args)] +roguestar_options = + [Option "s1" ["single-threaded"] + (NoArg $ \a -> a { arg_single_threaded = True }) + "Run the engine and client single-threaded.", + Option "e" ["echo-protocol"] + (NoArg $ \a -> a { arg_echo_protocol = True }) + "Echo the client-server protocol (for debugging).", + Option "h?" ["help"] + (NoArg $ \a -> a { arg_help = True }) + "Print this help message.", + Option "v" ["verbose"] + (NoArg $ \a -> a { arg_verbose = True }) + "Print debugging information.", + Option "p" ["prefix","path"] + (ReqArg (\s a -> a { arg_prefix = s }) "PREFIX") + ("Path to the directory where the roguestar-engine and " ++ + "roguestar-gl binaries are kept. You might need this " ++ + "to play roguestar off a remotely mounted file server " ++ + "or if something is broken and you know what you're doing.")] + +help_text :: String +help_text = usageInfo + ("Roguestar: A science-fiction role playing game.\n\n" ++ + "Roguestar has a client-server architecture (roguestar-gl, " ++ + "and roguestar-engine). This program instantiates both " ++ + "on the local host and manages all communication between " ++ + "them.\n\n" ++ + "Usage: roguestar [OPTIONS]") + roguestar_options + main :: IO () -main = - do (should_echo_protocol,args) <- - do args <- getArgs - return ("--echo-protocol" `elem` args, - filter (/= "--echo-protocol") $ args) - n <- getNumberOfCPUCores - bin_dir <- getBinDir - let n_rts_string = if n == 1 then [] else ["-N" ++ show n] - let gl_args = ["+RTS", "-G4"] ++ n_rts_string ++ ["-RTS"] ++ args - let engine_args = ["+RTS"] ++ n_rts_string ++ ["-RTS"] ++ ["version","over","begin"] - (e_in,e_out,e_err,roguestar_engine) <- runInteractiveProcess (bin_dir `combine` "roguestar-engine") engine_args Nothing Nothing - (gl_in,gl_out,gl_err,roguestar_gl) <- runInteractiveProcess (bin_dir `combine` "roguestar-gl") gl_args Nothing Nothing - forkIO $ pump e_out $ [("",gl_in)] ++ (if should_echo_protocol then [("engine >>> gl *** ",stdout)] else []) - forkIO $ pump gl_out $ [("",e_in)] ++ (if should_echo_protocol then [("gl <<< engine *** ",stdout)] else []) - forkIO $ pump e_err $ [("roguestar-engine *** ",stderr)] - forkIO $ pump gl_err $ [("roguestar-gl *** ",stderr)] - forkIO $ +main = + do bin_dir <- getBinDir + let default_args = Args { + arg_echo_protocol = False, + arg_single_threaded = False, + arg_help = False, + arg_prefix = bin_dir, + arg_verbose = False, + arg_engine = [], + arg_client = [] } + raw_args <- getFullArgs + let (opts_list,_,errs) = getOpt (ReturnInOrder $ \s args -> args { + arg_engine = arg_engine args ++ [s], + arg_client = arg_client args ++ [s] }) + roguestar_options + raw_args + let args = foldr ($) default_args opts_list + when (arg_help args) $ + do putStrLn help_text + exitWith ExitSuccess + when (not $ null errs) $ + do mapM_ putStrLn errs + exitWith ExitSuccess + let n_rts_string = if arg_single_threaded args then [] else ["-N"] + let gl_args = + ["+RTS", "-G4"] ++ + n_rts_string ++ + ["-RTS"] ++ + arg_client args + let engine_args = + ["+RTS"] ++ + n_rts_string ++ + ["-RTS"] ++ + arg_engine args ++ + ["version","over","begin"] + let roguestar_engine_bin = arg_prefix args `combine` "roguestar-engine" + let roguestar_gl_bin = arg_prefix args `combine` "roguestar-gl" + when (arg_verbose args) $ + putStrLn $ "starting process: " ++ + roguestar_engine_bin ++ " " ++ + unwords engine_args + (e_in,e_out,e_err,roguestar_engine) <- + runInteractiveProcess roguestar_engine_bin + engine_args + Nothing + Nothing + when (arg_verbose args) $ + putStrLn $ "starting process: " ++ + roguestar_gl_bin ++ + " " ++ + unwords gl_args + (gl_in,gl_out,gl_err,roguestar_gl) <- + runInteractiveProcess roguestar_gl_bin gl_args Nothing Nothing + stdout_chan <- newChan + _ <- forkIO $ pump e_out $ + [("",DHandle gl_in)] ++ + (if arg_echo_protocol args + then [("engine >>> gl *** ",DChanTime stdout_chan)] + else []) + _ <- forkIO $ pump gl_out $ + [("",DHandle e_in)] ++ + (if arg_echo_protocol args + then [("engine <<< gl *** ",DChanTime stdout_chan)] + else []) + _ <- forkIO $ pump e_err $ if arg_verbose args + then [("roguestar-engine *** ",DChan stdout_chan)] + else [] + _ <- forkIO $ pump gl_err $ if arg_verbose args + then [("roguestar-gl *** ",DChan stdout_chan)] + else [] + _ <- forkIO $ printChan stdout stdout_chan + _ <- forkIO $ do roguestar_engine_exit <- waitForProcess roguestar_engine case roguestar_engine_exit of ExitFailure x -> putStrLn $ "roguestar-engine terminated unexpectedly (" ++ show x ++ ")" @@ -37,36 +139,29 @@ ExitFailure x -> putStrLn $ "roguestar-gl terminated unexpectedly (" ++ show x ++ ")" _ -> return () -pump :: Handle -> [(String,Handle)] -> IO () +data Destination = DHandle Handle | DChan (Chan B.ByteString) | DChanTime (Chan B.ByteString) + +send :: Destination -> B.ByteString -> IO () +send (DHandle h) str = B.hPutStrLn h str >> hFlush h +send (DChan c) str = writeChan c str +send (DChanTime c) str = + do t <- getClockTime + writeChan c $ fromString (show t) `B.append` ": " `B.append` str + +setup :: Destination -> IO () +setup (DHandle h) = hSetBuffering h NoBuffering +setup _ = return () + +pump :: Handle -> [(B.ByteString,Destination)] -> IO () pump from tos = - do mapM_ (flip hSetBuffering NoBuffering . snd) tos - hSetBuffering from NoBuffering + do mapM_ (setup . snd) tos forever $ - do l <- hGetLine from - flip mapM_ tos $ \(name,to) -> - do hPutStrLn to $ name ++ l - hFlush to - -getNumberOfCPUCores :: IO Int -getNumberOfCPUCores = - do m_nop <- readNumberOfProcessors - m_cpuinfo <- scanCPUInfo - case (m_nop,m_cpuinfo) of - (Just n,_) -> do hPutStrLn stderr $ "roguestar: " ++ show n ++ - " CPU core(s) based on windows environment variable NUMBER_OF_PROCESSORS. " - return n - (_,Just n) -> do hPutStrLn stderr $ "roguestar: " ++ show n ++ " CPU core(s) based on /proc/cpuinfo. " - return n - _ -> do hPutStrLn stderr "roguestar: couldn't find number of CPU cores, assuming 1 core" - return 1 + do l <- B.hGetLine from + flip mapM_ tos $ \(name,to) -> send to $ name `B.append` l -readNumberOfProcessors :: IO (Maybe Int) -readNumberOfProcessors = flip catch (const $ return Nothing) $ liftM Just $ - do n <- getEnv "NUMBER_OF_PROCESSORS" - return $! read n +printChan :: Handle -> Chan B.ByteString -> IO () +printChan h c = forever $ + do s <- readChan c + B.hPutStrLn h s + hFlush h -scanCPUInfo :: IO (Maybe Int) -scanCPUInfo = catch (liftM (Just . length . filter isProcessorLine . map words . lines) $ readFile "/proc/cpuinfo") - (const $ return Nothing) - where isProcessorLine ["processor",":",_] = True - isProcessorLine _ = False diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal --- a/roguestar-gl.cabal +++ b/roguestar-gl.cabal @@ -1,5 +1,5 @@ name: roguestar-gl -version: 0.2.2 +version: 0.4.0.0 license: OtherLicense license-file: LICENSE author: Christopher Lane Hinson @@ -9,23 +9,31 @@ synopsis: Sci-fi roguelike (turn-based, chessboard-tiled, role playing) game description: Roguestar is a science fiction themed roguelike (turn-based, chessboard-tiled, role playing) game written in Haskell. Roguestar uses - OpenGL for graphics. This is still a very early release and several - important things don't work. - . - This initial release allows you to play one of six alien races. You begin - the game stranded on an alien planet, fighting off an endless hoard of - hostile robots. + OpenGL for graphics. This is still a very early release. . The git repository is available at . homepage: http://roguestar.downstairspeople.org/ -build-depends: base>3, containers, arrows, mtl, MonadRandom, GLUT, rsagl >=0.2.2 && <0.3, filepath >1.1 ---roguestar-engine==0.3 +build-depends: base>=4&&<5, + rsagl==0.4.0.0, + containers>=0.3.0.0 && < 0.4, + arrows>=0.4.1.2 && < 0.5, + mtl>=1.1.0.2 && < 1.2, + MonadRandom>=0.1.4 && < 1.2, + GLUT>=2.1.2.1 && < 2.2, + filepath>=1.1.0.3 && < 1.2, + random>=1.0.0.2 && < 1.1, + bytestring>=0.9.1.5 && < 0.10, + statistics>=0.5.1.0 && < 0.6, + vector>=0.6.0.1 && < 0.7, + stm>=2.1.1.2 && < 2.2, + priority-sync>=0.2.1.0 && < 0.2.2 + build-type: Simple -tested-with: GHC==6.8.2 +tested-with: GHC==6.12.1 executable: roguestar-gl -main-is: Main.lhs +main-is: Main.hs hs-source-dirs: src other-modules: Quality, ProtocolTypes, VisibleObject, Strings, WordGenerator, Driver, @@ -36,11 +44,12 @@ Models.Library, Models.MachineParts, Models.LibraryData, Models.Caduceator, Models.Tree, Models.Encephalon, Models.PhaseWeapons, RenderingControl, Keymaps.BuiltinKeymaps, Keymaps.CommonKeymap, Keymaps.NumpadKeymap, - Keymaps.Keymaps, Keymaps.VIKeymap -ghc-options: -Wall -threaded -fno-warn-type-defaults -fexcess-precision + Keymaps.Keymaps, Keymaps.VIKeymap, AnimationBuildings, Models.Monolith, + Models.Stargate, Statistics +ghc-options: -threaded -fno-warn-type-defaults -fexcess-precision ghc-prof-options: -prof -auto-all executable: roguestar main-is: Main.hs -build-depends: process -ghc-options: -Wall -threaded +build-depends: process, old-time, bytestring +ghc-options: -threaded diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Actions.hs @@ -0,0 +1,389 @@ +{-# 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 + diff --git a/src/Actions.lhs b/src/Actions.lhs deleted file mode 100644 --- a/src/Actions.lhs +++ /dev/null @@ -1,241 +0,0 @@ - -\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.Error -import Driver -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} diff --git a/src/Animation.hs b/src/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Animation.hs @@ -0,0 +1,274 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, + Arrows, + MultiParamTypeClasses, + FlexibleInstances, + TypeFamilies, + ExistentialQuantification, + Rank2Types, + OverloadedStrings, + UndecidableInstances #-} + +module Animation + (RSwitch, + AnimationState, + RoguestarAnimationObject, + newRoguestarAnimationObject, + runRoguestarAnimationObject, + driverGetAnswerA, + driverGetTableA, + printTextA, + printTextOnce, + debugA, + debugOnce, + donesA, + printMenuItemA, + printMenuA, + clearPrintTextA, + clearPrintTextOnce, + libraryA, + libraryPointAtCamera, + blockContinue, + requestPrintTextMode, + readGlobal, + randomA) + where + +import RSAGL.Math +import RSAGL.FRP +import RSAGL.Scene hiding (std_scene_layer_hud,std_scene_layer_cockpit,std_scene_layer_local,std_scene_layer_infinite) +import RSAGL.Animation +import RSAGL.Auxiliary.RecombinantState +import Control.Monad.State +import Control.Arrow +import Control.Arrow.Operations +import Driver +import Tables +import System.IO +import System.Random +import PrintText +import Models.Library +import Models.LibraryData +import Data.Maybe +import Keymaps.Keymaps +import Keymaps.CommonKeymap +import Actions +import Data.List +import Data.Ord +import Strings +import Globals +import Control.Concurrent.STM +import qualified Data.ByteString as B + +data AnimationState = AnimationState { + animstate_scene_accumulator :: SceneAccumulator IO, + animstate_globals :: Globals, + animstate_driver_object :: FrozenDriver, + animstate_print_text_object :: PrintTextObject, + animstate_library :: Library, + animstate_block_continue :: Bool, + animstate_print_text_mode :: PrintTextMode, + animstate_suspended_stm_action :: STM () } + +instance CoordinateSystemClass AnimationState where + getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator + storeCoordinateSystem cs as = as { + animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as } + +instance ScenicAccumulator AnimationState IO where + accumulateScene sl so as = as { + animstate_scene_accumulator = accumulateScene sl so $ animstate_scene_accumulator as } + +instance RecombinantState AnimationState where + type SubState AnimationState = AnimationState + clone old = old { animstate_scene_accumulator = clone $ animstate_scene_accumulator old } + recombine old new = old { + animstate_scene_accumulator = recombine (animstate_scene_accumulator old) (animstate_scene_accumulator new), + animstate_block_continue = animstate_block_continue old || animstate_block_continue new, + animstate_print_text_mode = animstate_print_text_mode old `mergePrintTextModes` animstate_print_text_mode new } + +-- | The RogueStar switch type. +type RSwitch k t i o m = SimpleSwitch k t AnimationState i o m + +instance (CoordinateSystemClass csc,StateOf m ~ csc) => AffineTransformable (FRP e m j p) where + transform m actionA = proc x -> transformA actionA -< (Affine $ transform m,x) + +newtype RoguestarAnimationObject = RoguestarAnimationObject (FRPProgram AnimationState () SceneLayerInfo) + +newRoguestarAnimationObject :: (forall e. FRP e (FRP1 AnimationState () SceneLayerInfo) () SceneLayerInfo) -> IO RoguestarAnimationObject +newRoguestarAnimationObject rs_anim = + liftM RoguestarAnimationObject $ newFRP1Program rs_anim + +runRoguestarAnimationObject :: Library -> + Globals -> + DriverObject -> + PrintTextObject -> + RoguestarAnimationObject -> + IO Scene +runRoguestarAnimationObject lib globals driver_object print_text_object + (RoguestarAnimationObject rso) = + do frozen_driver_object <- atomically $ freezeDriver driver_object + let anim_state = AnimationState { + animstate_globals = globals, + animstate_scene_accumulator = null_scene_accumulator, + animstate_driver_object = frozen_driver_object, + animstate_print_text_object = print_text_object, + animstate_library = lib, + animstate_block_continue = False, + animstate_print_text_mode = Limited, + animstate_suspended_stm_action = return () } + (result_scene_layer_info,result_animstate) <- + updateFRPProgram Nothing ((),anim_state) rso + atomically $ + do when (not $ animstate_block_continue result_animstate) $ + executeContinueAction $ + ActionInput globals driver_object print_text_object + setPrintTextMode print_text_object $ + animstate_print_text_mode result_animstate + animstate_suspended_stm_action result_animstate + assembleScene result_scene_layer_info $ + animstate_scene_accumulator result_animstate + +-- | Request an answer from the engine. This will return 'Nothing' until the answer arrives, which may never happen. +driverGetAnswerA :: (StateOf m ~ AnimationState) => FRP e m B.ByteString (Maybe B.ByteString) +driverGetAnswerA = proc query -> + do driver_object <- arr animstate_driver_object <<< fetch -< () + ioAction (\(driver_object_,query_) -> + atomically $ getAnswer driver_object_ query_) -< + (driver_object,query) + +-- | Request a data table from the engine. This will return 'Nothing' until the entire table arrives, which may never happen. +driverGetTableA :: (StateOf m ~ AnimationState) => FRP e m (B.ByteString,B.ByteString) (Maybe RoguestarTable) +driverGetTableA = proc query -> + do driver_object <- arr animstate_driver_object <<< fetch -< () + ioAction (\(driver_object_,(the_table_name,the_table_id)) -> + atomically $ + getTable driver_object_ the_table_name the_table_id) -< + (driver_object,query) + +-- | Store an IO action and run it at the end of the frame. +suspendedSTMAction :: (FRPModel m, StateOf m ~ AnimationState) => + (i -> STM ()) -> FRP e m i () +suspendedSTMAction action = proc i -> + do s <- fetch -< () + store -< s { animstate_suspended_stm_action = + animstate_suspended_stm_action s >> action i } + +-- | Print a line of text to the game console. This will print exactly once. +-- Accepts 'Nothing' and prints once immediately when a value is supplied. +printTextOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe (TextType,B.ByteString)) () +printTextOnce = onceA printTextA + +printTextA :: (FRPModel m, StateOf m ~ AnimationState) => + FRP e m (Maybe (TextType,B.ByteString)) () +printTextA = proc pt_data -> + do print_text_object <- arr animstate_print_text_object <<< fetch -< () + suspendedSTMAction (\(print_text_object,x) -> case x of + Nothing -> return () + Just (pt_type,pt_string) -> + printText print_text_object pt_type pt_string) + -< (print_text_object,pt_data) + +-- | Number of dones. (A done is a message from the engine that an change has occured in the game world.) +donesA :: (StateOf m ~ AnimationState) => FRP e m () Integer +donesA = proc () -> + do driver_object <- arr animstate_driver_object <<< fetch -< () + ioAction (atomically . driverDones) -< driver_object + +-- | Print a debugging message to 'stderr'. This will print on every frame of animation. +debugA :: (StateOf m ~ AnimationState) => FRP e m (Maybe B.ByteString) () +debugA = ioAction (maybe (return ()) (B.hPutStrLn stderr)) + +-- | Print a debugging message to 'stderr'. This will print exactly once. +debugOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe B.ByteString) () +debugOnce = onceA debugA + +-- | Get a list of keystrokes that correspond to the specified action, that are valid on the current frame of animation. +-- This can be used to display a menu that correctly indicates what keystroke to press for a given action. +actionNameToKeysA :: (StateOf m ~ AnimationState) => B.ByteString -> FRP e m () [B.ByteString] +actionNameToKeysA action_name = proc () -> + do animstate <- fetch -< () + let action_input = ActionInput (animstate_globals animstate) + (thawDriver $ animstate_driver_object animstate) + (animstate_print_text_object animstate) + ioAction id -< atomically (actionNameToKeys action_input + common_keymap + action_name) + +-- | Print a menu using 'printMenuItemA' +printMenuA :: (FRPModel m, StateOf m ~ AnimationState) => [B.ByteString] -> FRP e m () () +printMenuA = foldr (>>>) (arr id) . map printMenuItemA + +-- | Print a single menu item including it's keystroke. +printMenuItemA :: (FRPModel m, StateOf m ~ AnimationState) => B.ByteString -> FRP e m () () +printMenuItemA action_name = proc () -> + do keys <- actionNameToKeysA action_name -< () + printTextA -< fmap (\s -> (Query,s `B.append` " - " `B.append` hrstring action_name)) $ listToMaybe $ sortBy (comparing B.length) keys + +-- | Clear all printed text once. This begins a new clean segment of printed text. +clearPrintTextOnce :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () () +clearPrintTextOnce = onceA clearPrintTextA <<< arr (const $ Just ()) + +clearPrintTextA :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe ()) () +clearPrintTextA = proc i -> + do print_text_object <- arr (animstate_print_text_object) <<< fetch -< () + suspendedSTMAction id -< + when (isJust i) $ clearOutputBuffer print_text_object + +-- | Do an action exactly once. +onceA :: (FRPModel m) => (forall n. (FRPModel n, StateOf n ~ StateOf m) => FRP e n (Maybe j) p) -> FRP e m (Maybe j) p +onceA actionA = frp1Context onceA_ + where onceA_ = proc j -> + do p <- actionA -< j + switchTerminate -< (if isJust j then (Just $ arr (const p)) else Nothing,p) + +-- | Display a library model. +libraryA :: (StateOf m ~ AnimationState,LibraryModelSource lm) => + FRP e m (SceneLayer,lm) () +libraryA = proc (layer,lm) -> + do q <- readGlobal global_quality_setting -< () + lib <- arr animstate_library <<< fetch -< () + accumulateSceneA -< (layer, + sceneObject $ lookupModel lib (toLibraryModel lm) q) + +-- | Display a library model that remains oriented toward the camera. +libraryPointAtCamera :: (StateOf m ~ AnimationState,LibraryModelSource lm) => + FRP e m (SceneLayer,lm) () +libraryPointAtCamera = proc (layer,lm) -> + do q <- readGlobal global_quality_setting -< () + lib <- arr animstate_library <<< fetch -< () + pointAtCameraA -< (layer,lookupModel lib (toLibraryModel lm) q) + +-- | Prevent the engine from auto-continuing. When the engine is in a snapshot state, +-- the client will automatically ask it to step forward either to the next snapshot or +-- the player's turn. This delays the continue action until some animation or +-- text finishes printing. +blockContinue :: (StateOf m ~ AnimationState) => FRP e m Bool () +blockContinue = proc b -> + do animstate <- fetch -< () + store -< animstate { animstate_block_continue = animstate_block_continue animstate || b } + +-- | Change the 'PrintTextMode'. If multiple calls are made to 'requestPrintTextMode', then +-- 'Disabled' takes precedence over all others, while 'Unlimited' takes precedence over 'Limited'. +requestPrintTextMode :: (StateOf m ~ AnimationState) => FRP e m PrintTextMode () +requestPrintTextMode = proc s -> + do animstate <- fetch -< () + store -< animstate { animstate_print_text_mode = animstate_print_text_mode animstate `mergePrintTextModes` s } + +mergePrintTextModes :: PrintTextMode -> PrintTextMode -> PrintTextMode +mergePrintTextModes _ Disabled = Disabled +mergePrintTextModes Disabled _ = Disabled +mergePrintTextModes Limited Unlimited = Unlimited +mergePrintTextModes Unlimited Limited = Unlimited +mergePrintTextModes m _ = m + +-- | Read a global variable. +readGlobal :: (StateOf m ~ AnimationState) => (Globals -> TVar g) -> FRP e m () g +readGlobal f = proc () -> + do globals <- arr animstate_globals <<< fetch -< () + ioAction (\globals_ -> atomically $ readTVar $ f globals_) -< globals + +-- | Get a bounded random value, as 'randomRIO'. A new value is pulled for each frame of animation. +randomA :: (Random a) => FRP e m (a,a) a +randomA = ioAction randomRIO + diff --git a/src/Animation.lhs b/src/Animation.lhs deleted file mode 100644 --- a/src/Animation.lhs +++ /dev/null @@ -1,199 +0,0 @@ -\section{The Roguestar Animation Arrow} - -\begin{code} -{-# LANGUAGE GeneralizedNewtypeDeriving, Arrows #-} - -module Animation - (RSAnimA, - RSAnimA1, - RSAnimAX, - RoguestarAnimationObject, - newRoguestarAnimationObject, - runRoguestarAnimationObject, - driverGetAnswerA, - driverGetTableA, - printTextA, - printTextOnce, - debugA, - debugOnce, - printMenuItemA, - printMenuA, - clearPrintTextA, - clearPrintTextOnce, - libraryA, - libraryPointAtCamera, - blockContinue, - requestPrintTextMode) - where - -import RSAGL.FRP -import RSAGL.CoordinateSystems -import RSAGL.Scene -import RSAGL.AnimationExtras -import Control.Monad.State -import Control.Arrow -import Control.Arrow.Transformer hiding (lift) -import Control.Arrow.Transformer as Arrow -import Control.Arrow.Transformer.State as StateArrow -import Control.Arrow.Operations -import Driver -import Tables -import Control.Concurrent.MVar -import RSAGL.Time -import System.IO -import PrintText -import Models.Library -import Models.LibraryData -import Quality -import Data.Maybe -import Keymaps.Keymaps -import Keymaps.CommonKeymap -import Actions -import Data.List -import Data.Ord -import Strings -import Actions - -data AnimationState = AnimationState { - animstate_scene_accumulator :: SceneAccumulator, - animstate_driver_object :: DriverObject, - animstate_print_text_object :: PrintTextObject, - animstate_library :: Library, - animstate_block_continue :: Bool, - animstate_print_text_mode :: PrintTextMode } - -instance CoordinateSystemClass AnimationState where - getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator - storeCoordinateSystem cs as = as { - animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as } - -instance ScenicAccumulator AnimationState where - accumulateScene sl so as = as { - animstate_scene_accumulator = accumulateScene sl so $ animstate_scene_accumulator as } - -newtype IOGuard a = IOGuard { runIOGuard :: IO a } deriving (Functor,Monad) - -type RSAnimAX k t i o j p = FRPX k t i o (StateArrow AnimationState (Kleisli IOGuard)) j p -type RSAnimA t i o j p = RSAnimAX Threaded t i o j p -type RSAnimA1 i o j p = RSAnimAX () () i o j p - -type RSAnimA_ j p = StateArrow AnimationState (Kleisli IOGuard) j p - -newtype RoguestarAnimationObject = RoguestarAnimationObject { - rso_arrow :: MVar (FRPProgram (StateArrow AnimationState (Kleisli IOGuard)) () Camera) } - -newRoguestarAnimationObject :: RSAnimA1 () Camera () Camera -> IO RoguestarAnimationObject -newRoguestarAnimationObject rs_anim = - liftM RoguestarAnimationObject $ newMVar $ newFRP1Program rs_anim - -runRoguestarAnimationObject :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO Scene -runRoguestarAnimationObject lib driver_object print_text_object rso = - do old_rso_program <- takeMVar $ rso_arrow rso - t <- getTime - ((result_camera,new_rso_program),result_animstate) <- runIOGuard $ (runKleisli $ StateArrow.runState $ updateFRPProgram old_rso_program) (((),t), - AnimationState { - animstate_scene_accumulator = null_scene_accumulator, - animstate_driver_object = driver_object, - animstate_print_text_object = print_text_object, - animstate_library = lib, - animstate_block_continue = False, - animstate_print_text_mode = Limited }) - putMVar (rso_arrow rso) new_rso_program - when (not $ animstate_block_continue result_animstate) $ executeContinueAction $ ActionInput driver_object print_text_object - setPrintTextMode print_text_object $ animstate_print_text_mode result_animstate - assembleScene result_camera $ animstate_scene_accumulator result_animstate - -ioA :: (j -> IO p) -> RSAnimAX any t i o j p -ioA action = Arrow.lift $ ioA_ action - -ioA_ :: (j -> IO p) -> RSAnimA_ j p -ioA_ action = proc j -> Arrow.lift $ Kleisli (\x -> IOGuard $ action x) -< j - -driverGetAnswerA :: RSAnimAX any t i o String (Maybe String) -driverGetAnswerA = proc query -> - do driver_object <- arr animstate_driver_object <<< fetch -< () - ioA (\(driver_object_,query_) -> driverGetAnswer driver_object_ query_) -< (driver_object,query) - -driverGetTableA :: RSAnimAX any t i o (String,String) (Maybe RoguestarTable) -driverGetTableA = proc query -> - do driver_object <- arr animstate_driver_object <<< fetch -< () - ioA (\(driver_object_,(the_table_name,the_table_id)) -> - driverGetTable driver_object_ the_table_name the_table_id) -< (driver_object,query) - -printTextA :: RSAnimAX any t i o (Maybe (TextType,String)) () -printTextA = Arrow.lift printTextA_ - -printTextOnce :: RSAnimAX any t i o (Maybe (TextType,String)) () -printTextOnce = onceA printTextA_ - -printTextA_ :: RSAnimA_ (Maybe (TextType,String)) () -printTextA_ = proc pt_data -> - do print_text_object <- arr animstate_print_text_object <<< fetch -< () - ioA_ (\(print_text_object,x) -> case x of - Nothing -> return () - Just (pt_type,pt_string) -> printText print_text_object pt_type pt_string) -< (print_text_object,pt_data) - -debugA :: RSAnimAX any t i o (Maybe String) () -debugA = Arrow.lift debugA_ - -debugA_ :: RSAnimA_ (Maybe String) () -debugA_ = Arrow.lift $ Kleisli $ maybe (return ()) (IOGuard . hPutStrLn stderr) - -debugOnce :: RSAnimAX any t i o (Maybe String) () -debugOnce = onceA debugA_ - -actionNameToKeysA :: String -> RSAnimAX any t i o () [String] -actionNameToKeysA action_name = Arrow.lift $ proc () -> - do animstate <- fetch -< () - let action_input = ActionInput (animstate_driver_object animstate) - (animstate_print_text_object animstate) - app -< (Arrow.lift $ Kleisli $ const $ IOGuard $ actionNameToKeys action_input common_keymap action_name,()) - -printMenuA :: [String] -> RSAnimAX any t i o () () -printMenuA = foldr (>>>) (arr id) . map printMenuItemA - -printMenuItemA :: String -> RSAnimAX any t i o () () -printMenuItemA action_name = proc () -> - do keys <- actionNameToKeysA action_name -< () - printTextA -< fmap (\s -> (Query,s ++ " - " ++ hrstring action_name)) $ listToMaybe $ sortBy (comparing length) keys - -clearPrintTextA :: RSAnimAX any t i o () () -clearPrintTextA = Arrow.lift clearPrintText_ <<< arr (const $ Just ()) - -clearPrintTextOnce :: RSAnimAX any t i o () () -clearPrintTextOnce = onceA clearPrintText_ <<< arr (const $ Just ()) - -clearPrintText_ :: RSAnimA_ (Maybe ()) () -clearPrintText_ = proc i -> - do print_text_object <- arr (animstate_print_text_object) <<< fetch -< () - app -< maybe (arr $ const (),()) (const (Arrow.lift $ Kleisli $ const $ IOGuard $ clearOutputBuffer print_text_object,())) i - -onceA :: StateArrow AnimationState (Kleisli IOGuard) (Maybe j) p -> RSAnimAX any t i o (Maybe j) p -onceA actionA = frp1Context onceA_ - where onceA_ = proc j -> - do p <- Arrow.lift actionA -< j - switchTerminate -< (if isJust j then (Just $ arr (const p)) else Nothing,p) - -libraryA :: RSAnimAX any t i o (SceneLayer,LibraryModel) () -libraryA = proc (layer,lm) -> - do lib <- arr animstate_library <<< fetch -< () - accumulateSceneA -< (layer,sceneObject $ lookupModel lib lm Good) - -libraryPointAtCamera :: RSAnimAX any t i o (SceneLayer,LibraryModel) () -libraryPointAtCamera = proc (layer,lm) -> - do lib <- arr animstate_library <<< fetch -< () - pointAtCameraA -< (layer,lookupModel lib lm Good) - -blockContinue :: RSAnimAX any t i o Bool () -blockContinue = Arrow.lift $ proc b -> - do animstate <- fetch -< () - store -< animstate { animstate_block_continue = animstate_block_continue animstate || b } - -requestPrintTextMode :: RSAnimAX any t i o PrintTextMode () -requestPrintTextMode = Arrow.lift $ proc s -> - do animstate <- fetch -< () - store -< animstate { animstate_print_text_mode = case (animstate_print_text_mode animstate,s) of - (_,Disabled) -> Disabled - (Limited,Unlimited) -> Unlimited - (m,_) -> m } -\end{code} diff --git a/src/AnimationBuildings.hs b/src/AnimationBuildings.hs new file mode 100644 --- /dev/null +++ b/src/AnimationBuildings.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, FlexibleContexts #-} + +module AnimationBuildings + (buildingAvatar) + where + +import RSAGL.FRP +import Animation +import VisibleObject +import Models.LibraryData +import Control.Arrow +import Scene + +type BuildingAvatarSwitch m = AvatarSwitch () () m +type BuildingAvatar e m = FRP e (BuildingAvatarSwitch m) () () + +buildingAvatar :: (FRPModel m) => BuildingAvatar e m +buildingAvatar = proc () -> + do objectTypeGuard (== "building") -< () + m_building_type <- objectDetailsLookup ThisObject "building-type" -< () + switchContinue -< (fmap switchTo m_building_type,()) + returnA -< () + where switchTo "monolith" = simpleBuildingAvatar Monolith + switchTo "portal" = simpleBuildingAvatar Portal + switchTo _ = questionMarkAvatar >>> arr (const ()) + +simpleBuildingAvatar :: (FRPModel m, LibraryModelSource lm) => + lm -> BuildingAvatar e m +simpleBuildingAvatar phase_weapon_model = proc () -> + do visibleObjectHeader -< () + m_orientation <- objectIdealOrientation ThisObject -< () + whenJust (transformA libraryA) -< fmap + (\o -> (o,(scene_layer_local,phase_weapon_model))) m_orientation + returnA -< () + + diff --git a/src/CommandLine.hs b/src/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/CommandLine.hs @@ -0,0 +1,12 @@ +module CommandLine(CommandLineOptions, keymap_name, parseCommandLine) where + +import Keymaps.Keymaps + +data CommandLineOptions = CommandLineOptions { + keymap_name :: Maybe KeymapName +} + +-- Extremely minimal implementation for now: switch to System.Console.GetOpt or just use a config. file? +parseCommandLine :: [String] -> CommandLineOptions +parseCommandLine [the_keymap_name] = CommandLineOptions $ Just the_keymap_name +parseCommandLine _ = CommandLineOptions Nothing diff --git a/src/CommandLine.lhs b/src/CommandLine.lhs deleted file mode 100644 --- a/src/CommandLine.lhs +++ /dev/null @@ -1,14 +0,0 @@ -\begin{code} -module CommandLine(CommandLineOptions, keymap_name, parseCommandLine) where - -import Keymaps.Keymaps - -data CommandLineOptions = CommandLineOptions { - keymap_name :: Maybe KeymapName -} - --- Extremely minimal implementation for now: switch to System.Console.GetOpt or just use a config. file? -parseCommandLine :: [String] -> CommandLineOptions -parseCommandLine [the_keymap_name] = CommandLineOptions $ Just the_keymap_name -parseCommandLine _ = CommandLineOptions Nothing -\end{code} diff --git a/src/Driver.hs b/src/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Driver.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE OverloadedStrings, PatternGuards #-} +-- | Interacts with Protocol module of roguestar-engine. +module Driver + (DriverObject,RoguestarEngineState,FrozenDriver, + freezeDriver,thawDriver, + DriverClass(..), + driverSendError, + driverNoop, + driverDones, + newDriverObject, + driverAction) + where + +import Control.Concurrent.STM +import Control.Concurrent +import Data.List as List +import Data.Map as Map +import Data.Set as Set +import Data.Maybe +import System.IO +import Tables +import RSAGL.FRP.Time +import Control.Applicative +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B + +-- | Contains detailed information about ongoing interaction with the engine. +data DriverObject = DriverObject { + -- | Unparsed incomming information from the engine. These lines are + -- stored in reverse order from how they were recieved. + driver_incomming :: TVar [B.ByteString], + -- | Unsent outgoing information to the driver. Either a destructive + -- action or a lossy query. + driver_outgoing :: TVar (Either B.ByteString [B.ByteString]), + -- | Unsent outgoing error messages. Stored in reverse order. + driver_errors :: TVar [B.ByteString], + -- | Lines already sent to the engine. This is cleared whenever we send + -- a "game action" line. We retain this because it's wasteful to repeat + -- queries when nothing has been committed back to the engine. + driver_cached_lines :: TVar (Set.Set [B.ByteString]), + -- | Parsed information about the game state. This is cleared whenever + -- we send a "game action" line. + driver_engine_state :: TVar RoguestarEngineState, + -- | Count of the number of times we've recieved "done" from the engine. + driver_dones :: TVar Integer, + -- | Count of the number of destructive actions we've sent to the + -- engine. + driver_actions :: TVar Integer, + -- | Current time, updated constantly by the read/write/error loops. + driver_time :: TVar Time } + +-- | A frozen 'DriverObject'. It has a static view of the world as seen at the +-- time that the Driver is fozen, however, the original 'DriverObject' continues +-- to be updated when this 'FrozenDriver' is used. +data FrozenDriver = FrozenDriver { + _frozen_driver :: DriverObject, + _frozen_state :: RoguestarEngineState, + _frozen_actions :: Integer, + _frozen_dones :: Integer } + +-- | Contains all of the information that is known about roguestar-engine at a +-- specific moment in time. +data RoguestarEngineState = RoguestarEngineState { + -- index by (table_name, table_id) + restate_tables :: Map (B.ByteString,B.ByteString) RoguestarTable, + restate_answers :: Map B.ByteString B.ByteString } + +-- | Initialize a DriverObject. Call only once in any given process. +newDriverObject :: IO DriverObject +newDriverObject = + do driver_object <- initialDriverData + _ <- forkIO $ forever $ driverReadLoop driver_object + _ <- forkIO $ forever $ driverWriteLoop driver_object + _ <- forkIO $ forever $ driverErrorLoop driver_object + return driver_object + +initialDriverData :: IO DriverObject +initialDriverData = DriverObject <$> + newTVarIO [] <*> + newTVarIO (Right []) <*> + newTVarIO [] <*> + newTVarIO Set.empty <*> + newTVarIO (RoguestarEngineState Map.empty Map.empty) <*> + newTVarIO 0 <*> + newTVarIO 0 <*> + (newTVarIO =<< getTime) + +updateTime :: DriverObject -> Time -> STM () +updateTime driver_object t = + do old_time <- readTVar (driver_time driver_object) + when (t > old_time) $ + writeTVar (driver_time driver_object) t + +-- | Just write to the engine. +driverWriteLoop :: DriverObject -> IO () +driverWriteLoop driver_object = + do hFlush stdout + (mapM_ B.putStrLn =<<) $ atomically $ + do writes <- readTVar (driver_outgoing driver_object) + writeTVar (driver_outgoing driver_object) $ Right [] + case writes of + Left destructive -> + do writeTVar (driver_cached_lines driver_object) Set.empty + writeTVar (driver_actions driver_object) . succ =<< + readTVar (driver_actions driver_object) + return [destructive] + Right queries -> + do when (List.null queries) retry + return $ reverse queries + +driverErrorLoop :: DriverObject -> IO () +driverErrorLoop driver_object = + do hFlush stderr + (mapM_ (B.hPutStrLn stderr) =<<) $ atomically $ + do errs <- readTVar (driver_errors driver_object) + when (List.null errs) retry + writeTVar (driver_errors driver_object) [] + return $ reverse errs + +-- | Just read from the engine. Whenever 'driverRead' reads an "over", it +-- automatically fires off 'interpretText' to parse the newly read information. +driverReadLoop :: DriverObject -> IO () +driverReadLoop driver_object = + do str <- B.getLine + t <- getTime + atomically $ + do updateTime driver_object t + readses <- readTVar (driver_incomming driver_object) + writeTVar (driver_incomming driver_object) $ str : readses + when (str == "over") $ interpretText driver_object + +-- | A class for DriverObjects. +class DriverClass a where + -- | Retrieves an answer from the engine. An answer is a single string. + getAnswer :: a -> B.ByteString -> STM (Maybe B.ByteString) + -- | Retrieves a table from the engine. These tables make up a kind of + -- simple relational database. + getTable :: a -> B.ByteString -> B.ByteString -> STM (Maybe RoguestarTable) + +instance DriverClass DriverObject where + getAnswer driver_object query = + do driverQuery driver_object [query] + restate <- readTVar (driver_engine_state driver_object) + getAnswer restate query + getTable driver_object the_table_name the_table_id = + do driverQuery driver_object [the_table_name,the_table_id] + restate <- readTVar (driver_engine_state driver_object) + getTable restate the_table_name the_table_id + +instance DriverClass RoguestarEngineState where + getAnswer restate query = return $ + Map.lookup query $ restate_answers restate + getTable restate the_table_name the_table_id = return $ + (Map.lookup (the_table_name,the_table_id)) $ restate_tables restate + +instance DriverClass FrozenDriver where + getAnswer (FrozenDriver driver_object restate acts _) query = + do result <- getAnswer restate query + when (isNothing result) $ + do current_actions <- readTVar (driver_actions driver_object) + when (current_actions == acts) $ + getAnswer driver_object query >> return () + return result + getTable (FrozenDriver driver_object restate acts _) + the_table_name the_table_id = + do result <- getTable restate the_table_name the_table_id + when (isNothing result) $ + do current_actions <- readTVar (driver_actions driver_object) + when (current_actions == acts) $ + getTable driver_object the_table_name the_table_id >> + return () + return result + +-- | Transmits a read-only query against the state of the engine. +driverSendLossy :: DriverObject -> [B.ByteString] -> STM () +driverSendLossy driver_object query = + do cached_lines <- readTVar (driver_cached_lines driver_object) + when (not $ query `Set.member` cached_lines) $ + do writes <- either (const retry) return =<< + readTVar (driver_outgoing driver_object) + writeTVar (driver_outgoing driver_object) $ + Right $ B.unwords query : writes + writeTVar (driver_cached_lines driver_object) $ + Set.insert query cached_lines + +-- | Commit a destructive action to the engine. +driverSendDestructive :: DriverObject -> + [B.ByteString] -> + STM () +driverSendDestructive driver_object strs = + do _ <- either (const retry) return =<< + readTVar (driver_outgoing driver_object) + writeTVar (driver_engine_state driver_object) $ + RoguestarEngineState Map.empty Map.empty + writeTVar (driver_outgoing driver_object) $ Left $ + B.unwords strs + +-- | Transmits a read-only query against the state of the engine. +driverSendError :: DriverObject -> B.ByteString -> STM () +driverSendError driver_object err = + writeTVar (driver_errors driver_object) . (err:) =<< + readTVar (driver_errors driver_object) + +-- | Get an immutable driver. This driver still echoes requests +-- to it's parent driver. +freezeDriver :: DriverObject -> STM FrozenDriver +freezeDriver driver_object = + do restate <- readTVar (driver_engine_state driver_object) + actions <- readTVar (driver_actions driver_object) + dones <- readTVar (driver_dones driver_object) + return $ FrozenDriver driver_object restate actions dones + +-- | Not strictly necessary, you can use the original. +thawDriver :: FrozenDriver -> DriverObject +thawDriver (FrozenDriver driver_object _ _ _) = driver_object + +-- | Number of times 'done' has been received from the engine. +driverDones :: FrozenDriver -> STM Integer +driverDones (FrozenDriver _ _ _ dones) = return dones + +-- | Issue a \"driver query\" to the engine. +driverQuery :: DriverObject -> [B.ByteString] -> STM () +driverQuery driver_object query = driverSendLossy driver_object $ + "game":"query":query + +-- | Commit a \"driver action\" to the engine. +driverAction :: DriverObject -> [B.ByteString] -> STM () +driverAction driver_object query = driverSendDestructive driver_object $ + "game":"action":query + +-- | Issue a no-op to the engine.. +driverNoop :: DriverObject -> STM () +driverNoop driver_object = driverSendDestructive driver_object ["noop"] + +{------------------------------------------------------------------------------- + - This is the parser. + - ----------------------------------------------------------------------------} + +data DriverInterpretationState = DINeutral + | DIScanningTable RoguestarTable + | DIError + deriving (Eq,Show) + +-- | Parse 'driver_engine_input_lines'. +interpretText :: DriverObject -> STM () +interpretText driver_object = + do final_state <- foldM (interpretLine driver_object) DINeutral =<< + liftM reverse (readTVar $ driver_incomming driver_object) + when (final_state /= DINeutral) $ + do driverSendError driver_object + "interpretText concluded in a non-neutral state, which was:" + driverSendError driver_object $ B.pack $ show final_state + writeTVar (driver_incomming driver_object) [] + +-- | 'interpretLine' is a simple line-by-line parser invoked using 'foldM'. +interpretLine :: DriverObject -> + DriverInterpretationState -> + B.ByteString -> + STM DriverInterpretationState +interpretLine _ DIError _ = return DIError + +-- Ignore empty lines. +interpretLine _ di_state str | List.null (B.words str) = do return di_state + +-- Report errors. \"protocol-error\" means that engine believes that we screwed +-- up. \"error\" means that the engine admits it screwed up. +interpretLine driver_object _ str | (head $ B.words str) `elem` + ["protocol-error:", "error:"] = + do driverSendError driver_object str + return DIError + +-- Engine acknowledges completed database update. +interpretLine driver_object DINeutral "done" = + do writeTVar (driver_engine_state driver_object) $ + RoguestarEngineState Map.empty Map.empty + writeTVar (driver_dones driver_object) . succ =<< + readTVar (driver_dones driver_object) + return DINeutral + +interpretLine driver_object di_state "done" = + do driverSendError driver_object $ + "Driver raised protocol error: unexpected \"done\" in " `B.append` + (B.pack $ show di_state) `B.append` " state." + return DIError + +-- Engine is finished answering a query or action. +-- (But it may continue to spew answers to other queries.) +interpretLine _ DINeutral "over" = return DINeutral + +interpretLine driver_object (DIScanningTable {}) "over" = + do driverSendError driver_object $ + "Driver raised protocol error: 'over' issued while reading a data table" + return DIError + +-- Engine is answering a question. +interpretLine driver_object DINeutral str + | ["answer:",key,value] <- B.words str = + do engine_state <- readTVar (driver_engine_state driver_object) + writeTVar (driver_engine_state driver_object) $ + engine_state { + restate_answers = Map.insert key value + (restate_answers engine_state) } + return DINeutral + +-- Engine is opening a new table. +interpretLine driver_object DINeutral str + | ("begin-table":tname:tid:theaders) <- B.words str + , not (List.null theaders) = + do t <- readTVar (driver_time driver_object) + return $ DIScanningTable $ RoguestarTable { + table_created = t, + table_name = tname, + table_id = tid, + table_header = theaders, + table_data = [] } + +interpretLine driver_object _ str | (head $ B.words str) == "begin-table" = + do driverSendError driver_object + "Driver raised protocol error: incomplete begin-table header" + return DIError + +-- Engine is closing a table. +interpretLine driver_object (DIScanningTable table) str + | (head $ B.words str) == "end-table" = + do engine_state <- readTVar (driver_engine_state driver_object) + writeTVar (driver_engine_state driver_object) $ + engine_state { restate_tables = + Map.insert (table_name table, table_id table) + (table { table_data = reverse $ table_data table }) $ + restate_tables engine_state } + return DINeutral + +-- Inside an open table, read a single row of that table. +interpretLine driver_object (DIScanningTable table) str = + let table_row = B.words str + in (if length table_row == (length $ table_header table) + then return $ DIScanningTable (table { + table_data = table_row : table_data table }) + else do driverSendError driver_object + "Driver raised protocol error: malformed table row" + return DIError ) + +-- If we don't know what else to do, just print to stderr. +interpretLine driver_object _ str = + do driverSendError driver_object str + return DINeutral + diff --git a/src/Driver.lhs b/src/Driver.lhs deleted file mode 100644 --- a/src/Driver.lhs +++ /dev/null @@ -1,237 +0,0 @@ -\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 - -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} diff --git a/src/Keymaps/CommonKeymap.hs b/src/Keymaps/CommonKeymap.hs --- a/src/Keymaps/CommonKeymap.hs +++ b/src/Keymaps/CommonKeymap.hs @@ -1,59 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + module Keymaps.CommonKeymap - (commonMovementKeymap,MovementKeymap(..),common_keymap) + (common_keymap) where -import Data.Char - import Keymaps.Keymaps -data MovementKeymap = MovementKeymap { - mk_n, mk_s, mk_e, mk_w, mk_nw, mk_ne, mk_sw, mk_se :: String } - -commonMovementKeymap :: MovementKeymap -> Keymap -commonMovementKeymap mk = [ - (mk_n mk,"move-n"), - (mk_s mk,"move-s"), - (mk_e mk,"move-e"), - (mk_w mk,"move-w"), - (mk_nw mk,"move-nw"), - (mk_ne mk,"move-ne"), - (mk_sw mk,"move-sw"), - (mk_se mk,"move-se"), - (">t" ++ mk_n mk,"turn-n"), - (">t" ++ mk_s mk,"turn-s"), - (">t" ++ mk_e mk,"turn-e"), - (">t" ++ mk_w mk,"turn-w"), - (">t" ++ mk_nw mk,"turn-nw"), - (">t" ++ mk_ne mk,"turn-ne"), - (">t" ++ mk_sw mk,"turn-sw"), - (">t" ++ mk_se mk,"turn-se"), - (">f" ++ mk_n mk,"fire-n"), - (">f" ++ mk_s mk,"fire-s"), - (">f" ++ mk_e mk,"fire-e"), - (">f" ++ mk_w mk,"fire-w"), - (">f" ++ mk_nw mk,"fire-nw"), - (">f" ++ mk_ne mk,"fire-ne"), - (">f" ++ mk_sw mk,"fire-sw"), - (">f" ++ mk_se mk,"fire-se")] - common_keymap :: Keymap common_keymap = [ - (":move-n","move-n"), - (":move-s","move-s"), - (":move-w","move-w"), - (":move-e","move-e"), - (":move-nw","move-nw"), - (":move-ne","move-ne"), - (":move-sw","move-sw"), - (":move-se","move-se"), - (":turn-n","turn-n"), - (":turn-s","turn-s"), - (":turn-w","turn-w"), - (":turn-e","turn-e"), - (":turn-nw","turn-nw"), - (":turn-ne","turn-ne"), - (":turn-sw","turn-sw"), - (":turn-se","turn-se"), + (":north","n"), + (":northeast","ne"), + (":east","e"), + (":southeast","sw"), + (":south","s"), + (":southwest","sw"), + (":west","w"), + (":northwest","nw"), + (":escape","escape"), + (":next","next"), + (":prev","prev"), + ("\n","select-menu"), + ("\r","select-menu"), + (">:::KeyDown","next"), + (">:::KeyUp","prev"), + ("\ESC","normal"), + (":move","move"), + ("t","turn"), + (":turn","turn"), + ("J","jump"), + (":jump","jump"), + ("F","attack"), + (":attack","attack"), + ("f","fire"), + (":fire","fire"), + ("c","clear-terrain"), + (":clear-terrain","clear-terrain"), + ("a","activate"), + (":activate","activate"), ("x","anachronid"), (":anachronid","anachronid"), ("a","androsynth"), @@ -102,7 +85,26 @@ (":thief","thief"), ("w","warrior"), (":warrior","warrior"), + ("m","make-begin"), + ("p","pistol"), + (":pistol","pistol"), + ("c","carbine"), + (":carbine","carbine"), + ("r","rifle"), + (":rifle","rifle"), + ("f","fleuret"), + (":fleuret","fleuret"), + ("s","sabre"), + (":sabre","sabre"), + ("\n","make-end"), + ("\r","make-end"), ("#quit","quit"), + ("#sky-on","sky-on"), + ("#sky-off","sky-off"), + ("#quality-1","quality-bad"), + ("#quality-2","quality-poor"), + ("#quality-3","quality-good"), + ("#quality-4","quality-super"), (",","pickup"), (":pickup","pickup"), ("d","drop"), @@ -111,12 +113,8 @@ (":wield","wield"), ("-","unwield"), (":unwield","unwield"), - (":fire-n","fire-n"), - (":fire-s","fire-s"), - (":fire-w","fire-w"), - (":fire-e","fire-e"), - (":fire-new","fire-nw"), - (":fire-ne","fire-ne"), - (":fire-sw","fire-sw"), - (":fire-se","fire-sw"), - (":continue","continue")] + (":continue","continue"), + ("]","zoom-in"), + (":zoom-in","zoom-in"), + ("[","zoom-out"), + (":zoom-out","zoom-out")] diff --git a/src/Keymaps/Keymaps.hs b/src/Keymaps/Keymaps.hs new file mode 100644 --- /dev/null +++ b/src/Keymaps/Keymaps.hs @@ -0,0 +1,89 @@ +-- | 'Keymap's are simple mappings from a sequence of keystrokes to the +-- names of various commands. +{-# LANGUAGE OverloadedStrings #-} + +module Keymaps.Keymaps + (Keymap, + KeymapName, + fixKeymap, + filterKeySequence, + keysToActionNames, + actionNameToKeys) + where + +import Actions +import Data.List +import Control.Monad +import Control.Concurrent.STM +import qualified Data.ByteString.Char8 as B + +type Keymap = [(B.ByteString,B.ByteString)] +type KeymapName = String + +-- 'fixKeymap' processes a keymap to make it usable, by: +-- * removing erroneous whitespace +-- * placing \\n and \\r at the end of multi-key keystrokes that should be +-- activated via the enter key. +-- * passing keystrokes that begin with the escape character '>' as raw +-- keystrokes. + +fixKeymap :: Keymap -> Keymap +fixKeymap = concatMap $ \(keystrokes,action_name) -> + case () of + () | B.null keystrokes -> [] + () | B.length keystrokes == 1 -> [(keystrokes,action_name)] + () | B.head keystrokes == '>' -> + [(B.drop 1 keystrokes,action_name)] + () -> let fixed_keystrokes = + B.concat $ intersperse "-" $ B.words keystrokes + in [(fixed_keystrokes `B.append` "\r",action_name), + (keystrokes `B.append` "\n",action_name)] + +-- | 'validKeyMap' reduces a 'Keymap' to one that contains only those actions +-- that are valid at the instant of the atomic transaction. +validKeyMap :: ActionInput -> Keymap -> STM [(B.ByteString,B.ByteString)] +validKeyMap action_input raw_keymap = + do valid_actions <- getValidActions action_input Nothing + return $ filter (\x -> snd x `elem` valid_actions) raw_keymap + +-- | 'filterKeySequence' transforms a key sequence, providing services such as: +-- * blanking the input buffer is there is no possible completion +-- * performing tab complation +filterKeySequence :: ActionInput -> Keymap -> B.ByteString -> STM B.ByteString +filterKeySequence _ _ key_sequence | (length $ B.words key_sequence) /= 1 = return "" +filterKeySequence action_input keymap key_sequence = + do valid_key_map <- validKeyMap action_input keymap + let is_tab_key_completion = B.last key_sequence == '\t' + let stripped_key_sequence = B.unwords $ B.words key_sequence + let possible_completions = + filter (\x -> elem stripped_key_sequence $ B.inits x) $ + map fst $ valid_key_map + return $ case length possible_completions of + -- if there are no possible completions, clear the buffer + 0 -> "" + -- if the trailing input isn't a tab, chill + _ | not is_tab_key_completion -> stripped_key_sequence + -- if there's only one completion, get it, but strip + -- the trailing return in case they didn't want + -- to exec that completion. + 1 -> if key_sequence /= head possible_completions + then B.init $ head possible_completions + else key_sequence + -- get the best completion we can find + _ -> maximumBy (\x y -> compare (B.length x) (B.length y)) $ + foldr1 intersect $ map B.inits possible_completions + +-- | 'keysToActionNames' gets a list of the names of all action that could be +-- executed by the given key sequence at this instant. A null result +-- indicates that the key sequence isn't a valid command. A result with more +-- than one element indicates a collision in the key map, which is an error. + +keysToActionNames :: ActionInput -> Keymap -> B.ByteString -> STM [B.ByteString] +keysToActionNames action_input keymap key_sequence = + liftM (map snd . filter (\x -> fst x == key_sequence)) $ validKeyMap action_input keymap + +-- 'actionNameToKeys' provides reverse lookup versus keysToActionNames. +actionNameToKeys :: ActionInput -> Keymap -> B.ByteString -> STM [B.ByteString] +actionNameToKeys action_input keymap action_name = + liftM (map fst . filter (\x -> snd x == action_name)) $ validKeyMap action_input keymap + diff --git a/src/Keymaps/Keymaps.lhs b/src/Keymaps/Keymaps.lhs deleted file mode 100644 --- a/src/Keymaps/Keymaps.lhs +++ /dev/null @@ -1,77 +0,0 @@ -\section{Keymaps} - -\texttt{Keymap}s are simple mappings from a sequence of keystrokes to the names of various commands. - -\begin{code} -module Keymaps.Keymaps - (Keymap, - KeymapName, - fixKeymap, - filterKeySequence, - keysToActionNames, - actionNameToKeys) - where - -import Actions -import Data.List -import Control.Monad - -type Keymap = [(String,String)] -type KeymapName = String -\end{code} - -\texttt{fixKeymap} processes a keymap to make it usable. If you type in a multi-character command and it executes before you press enter, -you forgot to use \texttt{fixKeymap}. - -\begin{code} -fixKeymap :: Keymap -> Keymap -fixKeymap = concatMap $ \(x,y) -> - case x of - [c] -> [([c],y)] - ('>':keystrokes) | (not $ null keystrokes) -> [(keystrokes,y)] - command -> let keystrokes = concat $ intersperse "-" $ words command in [(keystrokes ++ "\r",y),(keystrokes ++ "\n",y)] -\end{code} - -\texttt{validKeyMap} reduces a \texttt{Keymap} to one that contains only those actions that are valid at this instant. - -\begin{code} -validKeyMap :: ActionInput -> Keymap -> IO [(String,String)] -validKeyMap action_input raw_keymap = - do valid_actions <- getValidActions action_input Nothing - return $ filter (\x -> snd x `elem` valid_actions) raw_keymap -\end{code} - -\texttt{filterKeySequence} transforms a key sequence into either the empty string, if it isn't the prefix of any valid action, -or completes the key sequence if it is the prefix of exactly one valid action. - -\begin{code} -filterKeySequence :: ActionInput -> Keymap -> String -> IO String -filterKeySequence _ _ key_sequence | (length $ words key_sequence) == 0 = return "" -filterKeySequence action_input keymap key_sequence = - do valid_key_map <- validKeyMap action_input keymap - let possible_completions = filter (\x -> elem key_sequence $ inits x) $ map fst $ valid_key_map - return $ case length possible_completions of - 0 -> "" - 1 -> if key_sequence /= head possible_completions - then init $ head possible_completions - else key_sequence - _ -> maximumBy (\x -> \y -> compare (length x) (length y)) $ foldr1 intersect $ map inits possible_completions -\end{code} - -\texttt{keysToActionNames} gets a list of the names of all action that could be exected by the given key sequence at this instant. -A result of zero indicates that the key sequence isn't a valid command. A result with more than one element indicates -a collision in the key map, which is an error. - -\begin{code} -keysToActionNames :: ActionInput -> Keymap -> String -> IO [String] -keysToActionNames action_input keymap key_sequence = - liftM (map snd . filter (\x -> fst x == key_sequence)) $ validKeyMap action_input keymap -\end{code} - -\texttt{actionNameToKeys} provides reverse lookup versus keysToActionNames. - -\begin{code} -actionNameToKeys :: ActionInput -> Keymap -> String -> IO [String] -actionNameToKeys action_input keymap action_name = - liftM (map fst . filter (\x -> snd x == action_name)) $ validKeyMap action_input keymap -\end{code} diff --git a/src/Keymaps/NumpadKeymap.hs b/src/Keymaps/NumpadKeymap.hs --- a/src/Keymaps/NumpadKeymap.hs +++ b/src/Keymaps/NumpadKeymap.hs @@ -1,21 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + module Keymaps.NumpadKeymap - (numpad_movement_keymap,numpad_keymap) + (numpad_keymap) where import Keymaps.CommonKeymap import Keymaps.Keymaps -numpad_movement_keymap :: MovementKeymap -numpad_movement_keymap = MovementKeymap { - mk_n = "8", - mk_s = "2", - mk_w = "4", - mk_e = "6", - mk_nw = "7", - mk_ne = "9", - mk_sw = "1", - mk_se = "3" } - numpad_keymap :: Keymap -numpad_keymap = - commonMovementKeymap numpad_movement_keymap ++ common_keymap +numpad_keymap = common_keymap ++ + [("8","n"), + ("2","s"), + ("4","w"), + ("6","e"), + ("7","nw"), + ("9","ne"), + ("1","sw"), + ("3","se"), + ("8","prev"), + ("2","next")] diff --git a/src/Keymaps/VIKeymap.hs b/src/Keymaps/VIKeymap.hs --- a/src/Keymaps/VIKeymap.hs +++ b/src/Keymaps/VIKeymap.hs @@ -1,21 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + module Keymaps.VIKeymap - (vi_movement_keymap,vi_keymap) + (vi_keymap) where import Keymaps.Keymaps import Keymaps.CommonKeymap -vi_movement_keymap :: MovementKeymap -vi_movement_keymap = MovementKeymap { - mk_n = "k", - mk_s = "j", - mk_w = "h", - mk_e = "l", - mk_nw = "y", - mk_ne = "u", - mk_sw = "b", - mk_se = "n" } - vi_keymap :: Keymap -vi_keymap = - commonMovementKeymap vi_movement_keymap ++ common_keymap +vi_keymap = common_keymap ++ + [("k","n"), + ("j","s"), + ("h","w"), + ("l","e"), + ("y","nw"), + ("u","ne"), + ("b","sw"), + ("n","se"), + ("j","next"), + ("k","prev")] diff --git a/src/Limbs.hs b/src/Limbs.hs new file mode 100644 --- /dev/null +++ b/src/Limbs.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-} + +module Limbs + (bothArms, + bothLegs) + where + +import VisibleObject +import Animation +import RSAGL.Animation +import RSAGL.Math +import Models.LibraryData +import Control.Arrow +import RSAGL.Scene +import RSAGL.FRP +import EventUtils +import RSAGL.Types + +-- | Animate an arbitrary articulated joint. +libraryJointAnimation :: (FRPModel m, StateOf m ~ AnimationState) => RSdouble -> LibraryModel -> LibraryModel -> FRP e m Joint () +libraryJointAnimation maximum_length upper lower = proc joint_info -> + jointAnimation (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(std_scene_layer_local,upper))) + (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(std_scene_layer_local,lower))) -< + joint_info + +-- | Animate an articulated joint holding constant the bend vector and arm length. +arm :: (FRPModel m, StateOf m ~ AnimationState) => LibraryModel -> LibraryModel -> Vector3D -> RSdouble -> FRP e m (Point3D,Point3D) Joint +arm arm_upper arm_lower bend_vector maximum_length = proc (shoulder_point,hand_point) -> + do let joint_info = joint bend_vector shoulder_point maximum_length hand_point + libraryJointAnimation maximum_length arm_upper arm_lower -< joint_info + returnA -< joint_info + +-- | Animate a right arm. This animation is aware of what tool the current creature (based on thread ID) is holding and raises the arm forward +-- while holding any tool. +rightArm :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> FRP e m () Joint +rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () -> + do m_time_recent_attack <- recentAttack ThisObject -< () + t_now <- threadTime -< () + m_tool_type <- objectDetailsLookup (WieldedTool ThisObject) "tool-type" -< () + is_wielding <- isWielding ThisObject -< () + hand_point <- approachA 0.1 (perSecond 1.0) -< case m_time_recent_attack of + Just t | t_now < t `add` fromSeconds 0.5 && m_tool_type == Just "sword" -> translate (Vector3D maximum_length 0 0) shoulder_anchor + Just t | t_now < t `add` fromSeconds 0.3 && m_tool_type == Nothing -> translate (Vector3D 0 0 $ maximum_length / 4) shoulder_anchor + Just t | t_now < t `add` fromSeconds 1.0 && m_tool_type == Nothing -> translate (Vector3D 0 0 maximum_length) shoulder_anchor + _ | is_wielding -> translate (Vector3D 0 0 maximum_length) shoulder_anchor + _ | otherwise -> hand_rest + arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_point) + +-- | Animate a left arm, which is always held at the side. +leftArm :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> FRP e m () Joint +leftArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = + proc () -> arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_rest) + +-- | Animate two arms. The parameters describe the right arm, and are swapped across the yz plane to produce left arm parameters. +bothArms :: (FRPModel m, + StateOf m ~ AnimationState, + ThreadIDOf m ~ Maybe Integer, + LibraryModelSource lm1, + LibraryModelSource lm2) => + lm1 -> + lm2 -> + Vector3D -> + Point3D -> + RSdouble -> + Point3D -> + FRP e m () (Joint,Joint) +bothArms arm_upper + arm_lower + bend_vector + shoulder_anchor + maximum_length + hand_rest = proc () -> + do left_joint <- leftArm (toLibraryModel arm_upper) + (toLibraryModel arm_lower) + (swapX bend_vector) + (swapX shoulder_anchor) + maximum_length + (swapX hand_rest) -< () + right_joint <- rightArm (toLibraryModel arm_upper) + (toLibraryModel arm_lower) + bend_vector + shoulder_anchor + maximum_length + hand_rest -< () + returnA -< (left_joint,right_joint) + +-- | Animate legs, which automatically know how to take steps when moved. +bothLegs :: (FRPModel m, + StateOf m ~ AnimationState, + LibraryModelSource lm1, + LibraryModelSource lm2) => + lm1 -> + lm2 -> + Vector3D -> + Point3D -> + RSdouble -> + Point3D -> + FRP e m () () +bothLegs leg_upper + leg_lower + bend_vector + hip_anchor + maximum_length + foot_rest = proc () -> + do legs [leg bend_vector + hip_anchor + maximum_length + foot_rest + (libraryJointAnimation maximum_length + (toLibraryModel leg_upper) + (toLibraryModel leg_lower)), + leg bend_vector + (swapX hip_anchor) + maximum_length + (swapX foot_rest) + (libraryJointAnimation maximum_length + (toLibraryModel leg_upper) + (toLibraryModel leg_lower))] + -< () + +swapX :: (AffineTransformable a) => a -> a +swapX = scale (Vector3D (-1.0) 1.0 1.0) diff --git a/src/Limbs.lhs b/src/Limbs.lhs deleted file mode 100644 --- a/src/Limbs.lhs +++ /dev/null @@ -1,66 +0,0 @@ -\section{Limbs} - -\begin{code} -{-# LANGUAGE Arrows #-} - -module Limbs - (rightArm, - leftArm, - bothArms, - bothLegs) - where -import VisibleObject -import Animation -import RSAGL.Joint -import RSAGL.Affine -import Models.LibraryData -import Control.Arrow -import RSAGL.Vector -import RSAGL.CoordinateSystems -import RSAGL.Scene -import RSAGL.InverseKinematics -import Data.Maybe -import RSAGL.Time - -libraryJointAnimation :: Double -> LibraryModel -> LibraryModel -> RSAnimAX any t i o Joint () -libraryJointAnimation maximum_length upper lower = proc joint_info -> - jointAnimation (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,upper))) - (proc () -> transformA libraryA -< (Affine $ scale' (maximum_length/2),(Local,lower))) -< joint_info - -arm :: LibraryModel -> LibraryModel -> Vector3D -> Double -> RSAnimAX any t i o (Point3D,Point3D) Joint -arm arm_upper arm_lower bend_vector maximum_length = proc (shoulder_point,hand_point) -> - do let joint_info = joint bend_vector shoulder_point maximum_length hand_point - libraryJointAnimation maximum_length arm_upper arm_lower -< joint_info - returnA -< joint_info - -rightArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint -rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () -> - do is_wielding <- arr isJust <<< wieldedTool -< () - hand_point <- approachA 0.1 (perSecond 1.0) -< if is_wielding - then translate (Vector3D 0 0 maximum_length) shoulder_anchor - else hand_rest - arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_point) - -leftArm :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () Joint -leftArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = - proc () -> arm arm_upper arm_lower bend_vector maximum_length -< (shoulder_anchor,hand_rest) -\end{code} - -\texttt{bothArms} and \texttt{bothLegs} render two limbs by swapping the description for the right limb. - -\begin{code} -bothArms :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA (Maybe Integer) i o () (Joint,Joint) -bothArms arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest = proc () -> - do left_joint <- leftArm arm_upper arm_lower (swapX bend_vector) (swapX shoulder_anchor) maximum_length (swapX hand_rest) -< () - right_joint <- rightArm arm_upper arm_lower bend_vector shoulder_anchor maximum_length hand_rest -< () - returnA -< (left_joint,right_joint) - -bothLegs :: LibraryModel -> LibraryModel -> Vector3D -> Point3D -> Double -> Point3D -> RSAnimA t i o () () -bothLegs leg_upper leg_lower bend_vector hip_anchor maximum_length foot_rest = proc () -> - do legs [leg bend_vector hip_anchor maximum_length foot_rest (libraryJointAnimation maximum_length leg_upper leg_lower), - leg bend_vector (swapX hip_anchor) maximum_length (swapX foot_rest) (libraryJointAnimation maximum_length leg_upper leg_lower)] - -< () - -swapX :: (AffineTransformable a) => a -> a -swapX = scale (Vector3D (-1.0) 1.0 1.0) -\end{code} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE Arrows #-} + +module Main + (main) + where + +import System.IO +import PrintText +import Data.Maybe +import Graphics.UI.GLUT +import Control.Monad +import Actions +import Keymaps.Keymaps +import CommandLine +import Keymaps.BuiltinKeymaps +import RenderingControl +import Driver +import Animation +import RSAGL.Scene +import Models.Library +import System.Timeout +import System.Exit +import Globals +import Control.Concurrent.STM +import Control.Concurrent +import Statistics + +roguestar_client_version :: String +roguestar_client_version = "0.3" + +default_window_size :: Size +default_window_size = Size 800 600 + +display_mode :: [DisplayMode] +display_mode = [RGBAMode, + WithDepthBuffer, + DoubleBuffered] + +timer_callback_millis :: Int +timer_callback_millis = 30 + +main :: IO () +main = + do (_, command_line) <- getArgsAndInitialize + let command_line_options = parseCommandLine command_line + let keymap = findKeymapOrDefault $ keymap_name command_line_options + scene_var <- newTVarIO Nothing + globals <- defaultGlobals + driver_object <- newDriverObject + print_text_object <- newPrintTextObject + animation_object <- newRoguestarAnimationObject mainAnimationLoop + lib <- newLibrary + initialWindowSize $= default_window_size + initialDisplayMode $= display_mode + window <- createWindow $ "RogueStar GL " ++ roguestar_client_version + reshapeCallback $= Just roguestarReshapeCallback + display_statistics <- newStatistics "rendering" + displayCallback $= roguestarDisplayCallback display_statistics scene_var print_text_object + perWindowKeyRepeat $= PerWindowKeyRepeatOff + keyboardMouseCallback $= (Just $ keyCallback print_text_object) + addTimerCallback timer_callback_millis (roguestarTimerCallback scene_var globals driver_object print_text_object keymap window) + scene_statistics <- newStatistics "scene" + sceneLoop scene_statistics scene_var lib globals driver_object print_text_object animation_object + mainLoop + +watchQuit :: Globals -> IO () +watchQuit g = + do q <- atomically $ readTVar $ global_should_quit g + when q $ exitWith ExitSuccess + +sceneLoop :: Statistics -> TVar (Maybe Scene) -> Library -> Globals -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO () +sceneLoop stats scene_var lib globals driver_object print_text_object animation_object = liftM (const ()) $ forkIO $ forever $ + do atomically $ + do b <- liftM isJust $ readTVar scene_var + when b retry + result <- timeout 20000000 $ + do scene <- runStatistics stats $ runRoguestarAnimationObject lib globals driver_object print_text_object animation_object + atomically $ writeTVar scene_var $ Just scene + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled simulation run (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +roguestarReshapeCallback :: Size -> IO () +roguestarReshapeCallback (Size width height) = + do matrixMode $= Projection + loadIdentity + viewport $= (Position 0 0,Size width height) + +roguestarDisplayCallback :: Statistics -> TVar (Maybe Scene) -> PrintTextObject -> IO () +roguestarDisplayCallback stats scene_var print_text_object = + do scene <- atomically $ + do result <- maybe retry return =<< readTVar scene_var + writeTVar scene_var Nothing + return result + result <- timeout 20000000 $ + do color (Color4 0 0 0 0 :: Color4 GLfloat) + clear [ColorBuffer] + (Size width height) <- get windowSize + runStatistics stats $ + do sceneToOpenGL (fromIntegral width / fromIntegral height) (0.1,80.0) scene + renderText print_text_object + swapBuffers + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled display callback (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +roguestarTimerCallback :: TVar (Maybe Scene) -> Globals -> DriverObject -> PrintTextObject -> Keymap -> Window -> IO () +roguestarTimerCallback scene_var globals driver_object print_text_object keymap window = + do watchQuit globals + result <- timeout 20000000 $ + do addTimerCallback timer_callback_millis $ roguestarTimerCallback scene_var globals driver_object print_text_object keymap window + postRedisplay $ Just window + maybeExecuteKeymappedAction globals driver_object print_text_object keymap + if isNothing result + then do hPutStrLn stderr "roguestar-gl: aborting due to stalled timer callback (timed out after 20 seconds)" + exitWith $ ExitFailure 1 + else return () + +maybeExecuteKeymappedAction :: Globals -> + DriverObject -> + PrintTextObject -> + Keymap -> + IO () +maybeExecuteKeymappedAction globals driver_object print_text_object keymap = + do let action_input = ActionInput globals + driver_object + print_text_object + pullInputBuffer print_text_object + buffer_contents <- getInputBuffer print_text_object + (id =<<) $ atomically $ + do synced_with_engine <- liftM (not . null) $ + getValidActions action_input Nothing + worked <- if synced_with_engine + then takeUserInputAction action_input =<< + keysToActionNames action_input keymap buffer_contents + else return False + filtered <- filterKeySequence action_input + keymap + buffer_contents + return $ if worked + then clearInputBuffer print_text_object + else setInputBuffer print_text_object filtered + diff --git a/src/Main.lhs b/src/Main.lhs deleted file mode 100644 --- a/src/Main.lhs +++ /dev/null @@ -1,114 +0,0 @@ -\section{Main} - -\begin{code} -{-# LANGUAGE Arrows #-} - -module Main - (main) - where - -import System.IO -import PrintText ---import Quality -import Data.Maybe -import Data.List -import Graphics.UI.GLUT -import Control.Monad -import Actions -import Keymaps.Keymaps -import CommandLine -import Keymaps.BuiltinKeymaps -import RenderingControl -import Driver ---import Models.LibraryData ---import Models.Library ---import Camera -import Animation -import RSAGL.Scene -import Models.Library -import System.Timeout -import System.Exit - -roguestar_client_version :: String -roguestar_client_version = "0.2.2" - -default_window_size :: Size -default_window_size = Size 800 600 - -display_mode :: [DisplayMode] -display_mode = [RGBAMode, - WithDepthBuffer, - DoubleBuffered] - -timer_callback_millis :: Int -timer_callback_millis = 30 - ---qualityFromArgs :: [String] -> Quality ---qualityFromArgs [] = Good ---qualityFromArgs ("quality-bad":_) = Bad ---qualityFromArgs ("quality-poor":_) = Poor ---qualityFromArgs ("quality-good":_) = Good ---qualityFromArgs ("quality-super":_) = Super ---qualityFromArgs args = qualityFromArgs $ tail args - -main :: IO () -main = - do (_, command_line) <- getArgsAndInitialize - let command_line_options = parseCommandLine command_line - let keymap = findKeymapOrDefault $ keymap_name command_line_options - driver_object <- newDriverObject - print_text_object <- newPrintTextObject - animation_object <- newRoguestarAnimationObject mainAnimationLoop - lib <- newLibrary - initialWindowSize $= default_window_size - initialDisplayMode $= display_mode - window <- createWindow $ "RogueStar GL " ++ roguestar_client_version - reshapeCallback $= Just roguestarReshapeCallback - displayCallback $= roguestarDisplayCallback lib driver_object print_text_object animation_object - keyboardMouseCallback $= (Just $ keyCallback print_text_object) - addTimerCallback timer_callback_millis (roguestarTimerCallback driver_object print_text_object keymap window) - mainLoop - -roguestarReshapeCallback :: Size -> IO () -roguestarReshapeCallback (Size width height) = - do matrixMode $= Projection - loadIdentity - viewport $= (Position 0 0,Size width height) - -roguestarDisplayCallback :: Library -> DriverObject -> PrintTextObject -> RoguestarAnimationObject -> IO () -roguestarDisplayCallback lib driver_object print_text_object animation_object = - do result <- timeout 20000000 $ - do color (Color4 0 0 0 0 :: Color4 Float) - clear [ColorBuffer] - scene <- runRoguestarAnimationObject lib driver_object print_text_object animation_object - (Size width height) <- get windowSize - sceneToOpenGL (fromIntegral width / fromIntegral height) (0.1,80.0) scene - renderText print_text_object - swapBuffers - if isNothing result - then do hPutStrLn stderr "roguestar-gl: aborting due to stalled display callback (timed out after 20 seconds)" - exitWith $ ExitFailure 1 - else return () - -roguestarTimerCallback :: DriverObject -> PrintTextObject -> Keymap -> Window -> IO () -roguestarTimerCallback driver_object print_text_object keymap window = - do result <- timeout 20000000 $ - do addTimerCallback timer_callback_millis $ roguestarTimerCallback driver_object print_text_object keymap window - driverRead driver_object - postRedisplay $ Just window - maybeExecuteKeymappedAction driver_object print_text_object keymap - if isNothing result - then do hPutStrLn stderr "roguestar-gl: aborting due to stalled timer callback (timed out after 20 seconds)" - exitWith $ ExitFailure 1 - else return () - -maybeExecuteKeymappedAction :: DriverObject -> PrintTextObject -> Keymap -> IO () -maybeExecuteKeymappedAction driver_object print_text_object keymap = - do let action_input = ActionInput driver_object print_text_object - buffer_contents <- getInputBuffer print_text_object - actions <- keysToActionNames action_input keymap buffer_contents - worked <- takeUserInputAction action_input actions - if worked - then clearInputBuffer print_text_object - else setInputBuffer print_text_object =<< filterKeySequence action_input keymap buffer_contents -\end{code} diff --git a/src/Models/Androsynth.hs b/src/Models/Androsynth.hs --- a/src/Models/Androsynth.hs +++ b/src/Models/Androsynth.hs @@ -2,12 +2,10 @@ (androsynth) where -import RSAGL.Affine -import RSAGL.Vector -import RSAGL.Model +import RSAGL.Math +import RSAGL.Modeling import Quality import Models.Materials -import RSAGL.ModelingExtras androsynth_head :: Quality -> Modeling () androsynth_head _ = model $ diff --git a/src/Models/Ascendant.hs b/src/Models/Ascendant.hs --- a/src/Models/Ascendant.hs +++ b/src/Models/Ascendant.hs @@ -2,11 +2,9 @@ (ascendant_glow) where -import RSAGL.Model -import RSAGL.ModelingExtras -import RSAGL.Vector +import RSAGL.Modeling +import RSAGL.Math import Quality -import RSAGL.Affine ascendant_glow :: Quality -> Modeling () ascendant_glow _ = diff --git a/src/Models/Caduceator.hs b/src/Models/Caduceator.hs --- a/src/Models/Caduceator.hs +++ b/src/Models/Caduceator.hs @@ -4,21 +4,17 @@ caduceator_arm_lower) where -import RSAGL.Vector -import RSAGL.CurveExtras -import RSAGL.Model +import RSAGL.Math +import RSAGL.Math.CurveExtras +import RSAGL.Modeling import Quality import Models.Materials -import RSAGL.Affine -import RSAGL.Interpolation -import RSAGL.ModelingExtras -import RSAGL.Angle caduceator :: Quality -> Modeling () caduceator _ = model $ do model $ do tube $ linearInterpolation - [(0.001,Point3D 0 0 (-5)), + [(0,Point3D 0 0 (-5)), (0.5, Point3D 0 2 (-3)), (0.5, Point3D 0 2.5 (-2)), (0.5, Point3D 0 2.5 (-1)), @@ -30,7 +26,7 @@ (0.5, Point3D 0 7 3.5), (0.5, Point3D 0 7.5 4 ), (0.75, Point3D 0 7.25 5 ), - (0.001,Point3D 0 7 7 )] + (0,Point3D 0 7 7 )] deform $ \(Point3D x y z) -> let x' = flip lerpMap y [(0,4), @@ -52,22 +48,22 @@ caduceator_arm_upper :: Quality -> Modeling () caduceator_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do model $ sor $ linearInterpolation $ - points2d [(0.0001,0), + points2d [(0,0), (1.0,1.0), (0.5,10.0), - (0.0001,10.5)] + (0,10.5)] caduceator_skin affine $ scale' (1/10) caduceator_arm_lower :: Quality -> Modeling () caduceator_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do model $ sor $ linearInterpolation $ - points2d [(0.0001,-0.5), + points2d [(0,-0.5), (0.5,0.0), (0.25,9.0), (1.25,10.0), (1.0,10.25), (0.75,9.75), - (0.0001,9)] + (0,9)] caduceator_skin affine $ scale' (1/10) diff --git a/src/Models/Encephalon.hs b/src/Models/Encephalon.hs --- a/src/Models/Encephalon.hs +++ b/src/Models/Encephalon.hs @@ -3,18 +3,16 @@ where import Quality -import RSAGL.Vector -import RSAGL.CurveExtras -import RSAGL.Model -import RSAGL.ModelingExtras +import RSAGL.Math +import RSAGL.Math.CurveExtras +import RSAGL.Modeling import Models.Materials -import RSAGL.Affine encephalon_head :: Quality -> Modeling () encephalon_head _ = model $ do sor $ linearInterpolation $ points2d $ reverse - [(0.001,9), + [(0,9), (0.5,9), (1,9), (1.5,9), @@ -25,8 +23,7 @@ (3,3)] deform dfn encephalon_skin - where dfn (Point3D x y z) | y > (abs x ** 0.4) + 7.5 = Point3D x ((abs x ** 0.4) + 7.5) z - dfn pt = pt + where dfn (Point3D x y z) = Point3D x (min (abs x ** 4 + 7.5) y) z encephalon_eye :: Quality -> Modeling () encephalon_eye _ = model $ @@ -43,7 +40,7 @@ (8,1), (8,0.5), (7,0), - (0.001,0)] + (0,0)] alliance_metal encephalon :: Quality -> Modeling () diff --git a/src/Models/Library.hs b/src/Models/Library.hs new file mode 100644 --- /dev/null +++ b/src/Models/Library.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Models.Library + (Library, + newLibrary, + lookupModel) + where + +import Quality +import Data.Maybe +import Data.Map as Map +import RSAGL.Modeling hiding (model) +import Control.Concurrent.STM +import Control.Monad +import GHC.Conc +import PrioritySync.PrioritySync +import System.IO +import Control.Concurrent.MVar + +import Models.LibraryData + +import Models.Terrain +import Models.QuestionMark +import Models.Tree +import Models.Encephalon +import Models.Recreant +import Models.Androsynth +import Models.Ascendant +import Models.Caduceator +import Models.Reptilian +import Models.PhaseWeapons +import Models.MachineParts +import Models.Sky +import Models.CyborgType4 +import Models.EnergyThings +import Models.EnergySwords +import Models.Spheres +import Models.Monolith +import Models.Stargate + +-- | +-- Get the modeling data for a named library model. +-- +toModel :: LibraryModel -> Quality -> Modeling () +toModel (TerrainTile s) = terrainTile s +toModel (SimpleModel LeafyBlob) = const $ leafy_blob +toModel (SimpleModel TreeBranch) = const $ tree_branch +toModel (SkySphere sky_info) = const $ makeSky sky_info +toModel (SunDisc sun_info) = const $ makeSun sun_info +toModel (SimpleModel QuestionMark) = const $ question_mark +toModel NullModel = const $ return () +toModel (SimpleModel Encephalon) = encephalon +toModel (SimpleModel Recreant) = recreant +toModel (SimpleModel Androsynth) = androsynth +toModel (SimpleModel Caduceator) = caduceator +toModel (SimpleModel Reptilian) = reptilian +toModel (SimpleModel AscendantGlow) = ascendant_glow +toModel (SimpleModel PhasePistol) = phase_pistol +toModel (SimpleModel Phaser) = phaser +toModel (SimpleModel PhaseRifle) = phase_rifle +toModel (SimpleModel GasSphere) = gasSphere +toModel (SimpleModel MetalSphere) = metalSphere +toModel (SimpleModel ChromaliteSphere) = chromaliteSphere +toModel (SimpleModel MachineArmLower) = machine_arm_lower +toModel (SimpleModel MachineArmUpper) = machine_arm_upper +toModel (SimpleModel CaduceatorArmLower) = caduceator_arm_lower +toModel (SimpleModel CaduceatorArmUpper) = caduceator_arm_upper +toModel (SimpleModel ReptilianLegLower) = reptilian_leg_lower +toModel (SimpleModel ReptilianLegUpper) = reptilian_leg_upper +toModel (SimpleModel ReptilianArmLower) = reptilian_arm_lower +toModel (SimpleModel ReptilianArmUpper) = reptilian_arm_upper +toModel (SimpleModel ThinLimb) = thin_limb +toModel (SimpleModel CyborgType4Dome) = cyborg_type_4_dome +toModel (SimpleModel CyborgType4Base) = cyborg_type_4_base +toModel (SimpleModel CyborgType4HyperspaceDisc) = cyborg_type_4_hyperspace_disc +toModel (SimpleModel CyborgType4HyperspaceRotor) = + cyborg_type_4_hyperspace_rotor +toModel (SimpleModel CyborgType4HyperspaceStabilizer) = + cyborg_type_4_hyperspace_stabilizer +toModel (EnergyThing EnergyCylinder c) = energyCylinder c +toModel (EnergyThing EnergySword c) = energySword c 3 +toModel (SimpleModel Monolith) = monolith +toModel (SimpleModel Portal) = portal + +-- | +-- Models that should be displayed at lower quality. +-- +downgraded_models :: [LibraryModel] +downgraded_models = + Prelude.map toLibraryModel + [LeafyBlob,TreeBranch, + GasSphere,MetalSphere,ChromaliteSphere,MachineArmLower, + MachineArmUpper,CaduceatorArmLower,CaduceatorArmUpper, + ReptilianLegLower,ReptilianLegUpper,ReptilianArmLower, + ReptilianArmUpper, ThinLimb] + +-- | +-- Sometimes we want to constrain the quality of some models. +-- +forceQuality :: LibraryModel -> Quality -> Quality +-- ambient box, LOD doesn't affect appearance +forceQuality (SimpleModel CyborgType4HyperspaceRotor) = const Bad +-- terrain just isn't that interesting +forceQuality (TerrainTile _) = min Poor +forceQuality x | x `elem` downgraded_models = \q -> case q of + Bad -> Bad + Poor -> Bad + Good -> Poor + Super -> Poor +forceQuality _ = id + +-- | +-- Models to build at start time. +-- +essential_library_models :: [LibraryModel] +essential_library_models = + Prelude.map TerrainTile known_terrain_types ++ + Prelude.map SimpleModel [minBound..maxBound] ++ + [EnergyThing x y | x <- [minBound..maxBound], + y <- [minBound..maxBound]] + +modelPriority :: Quality -> LibraryModel -> Integer +modelPriority Bad model | model `elem` essential_library_models = 0 +modelPriority q (SkySphere {}) = 10 * qualityPriority q +modelPriority q _ = qualityPriority q + +qualityPriority :: Quality -> Integer +qualityPriority Bad = 1 +qualityPriority Poor = 2 +qualityPriority Good = 4 +qualityPriority Super = 8 + +-- | +-- A library of named models. Models are generated on demand, but models +-- known in all_library_models are generated at worst quality when the library +-- is first initialized. +-- +data Library = Library { + library_cache :: TVar (Map.Map (Quality,LibraryModel) + (TVar (Maybe BakedModel))), + library_wrapper :: Quality -> LibraryModel -> IO () -> IO () } + +-- | +-- Create a new library. +-- Only one Library should be needed per process instance. +-- +newLibrary :: IO Library +newLibrary = + do task_pool <- newTaskPool fast_queue_configuration + (max 1 $ numCapabilities - 2) + () + startQueue task_pool + cache <- newTVarIO Map.empty + loading_stdout_mvar <- newMVar () + let lib = Library cache $ \q m actionIO -> + do _ <- dispatch (schedule task_pool $ modelPriority q m) + actionIO + return () + forM_ essential_library_models $ \x -> lookupModel lib x Bad + let waitFor x = atomically $ + do b <- isLoaded lib x + when (not b) retry + forM_ essential_library_models $ \x -> forkIO $ + do waitFor x + modifyMVar_ loading_stdout_mvar $ const $ + do hPutStrLn stderr $ "Pregenerated model: " ++ show x + hPutStrLn stderr . modelInfo =<< lookupModel lib x Bad + return () + forM_ essential_library_models $ \x -> waitFor x + return lib + +-- | +-- Get a library model. If the model is not available at the requested quality +-- level, a poorer model will be provided instead, and a background thread will +-- launch to begin generating the model at the requested level of detail. +-- +lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel +lookupModel lib model q_ = (id =<<) $ atomically $ + do let q = forceQuality model q_ + cache <- readTVar $ library_cache lib + let m_var = Map.lookup (q,model) cache + case m_var of + Just var -> + do m_result <- liftM (fmap toIntermediateModel) $ readTVar var + case m_result of + Just result -> return $ return result + Nothing | model == NullModel -> + return $ atomically $ liftM toIntermediateModel $ + maybe retry return =<< readTVar var + Nothing | q == Bad -> return $ + lookupModel lib NullModel Bad + Nothing -> return $ + lookupModel lib model (pred q) + Nothing -> + do target <- newTVar Nothing + writeTVar (library_cache lib) $ + Map.insert (q,model) target cache + return $ + do library_wrapper lib q model $ + bakeAndStore target model q + lookupModel lib model q + +isLoaded :: Library -> LibraryModel -> STM Bool +isLoaded lib model = + do cache <- readTVar $ library_cache lib + let m_var = Map.lookup (Bad,model) cache + maybe (return False) (liftM isJust . readTVar) m_var + +bakeAndStore :: TVar (Maybe BakedModel) -> LibraryModel -> Quality -> IO () +bakeAndStore target model q = + do result <- bakeModel $ buildIntermediateModel (qualityToVertices q) + (toModel model q) + atomically $ writeTVar target $ Just result + diff --git a/src/Models/Library.lhs b/src/Models/Library.lhs deleted file mode 100644 --- a/src/Models/Library.lhs +++ /dev/null @@ -1,93 +0,0 @@ -\section{The Model Library} - -\begin{code} -module Models.Library - (Library, - newLibrary, - lookupModel) - where - -import Quality -import Models.LibraryData -import Models.Terrain -import Models.QuestionMark -import Data.Map as Map -import RSAGL.Model -import RSAGL.QualityControl -import Control.Concurrent -import RSAGL.Bottleneck -import Control.Monad -import System.IO -import Models.Encephalon -import Models.Recreant -import Models.Androsynth -import Models.Ascendant -import Models.Caduceator -import Models.Reptilian -import Models.PhaseWeapons -import Models.MachineParts - -toModel :: LibraryModel -> Quality -> Modeling () -toModel (TerrainTile s) = terrainTile s -toModel QuestionMark = const $ question_mark -toModel NullModel = const $ return () -toModel Encephalon = encephalon -toModel Recreant = recreant -toModel Androsynth = androsynth -toModel Caduceator = caduceator -toModel Reptilian = reptilian -toModel AscendantGlow = ascendant_glow -toModel PhasePistol = phase_pistol -toModel MachineArmLower = machine_arm_lower -toModel MachineArmUpper = machine_arm_upper -toModel CaduceatorArmLower = caduceator_arm_lower -toModel CaduceatorArmUpper = caduceator_arm_upper -toModel ReptilianLegLower = reptilian_leg_lower -toModel ReptilianLegUpper = reptilian_leg_upper -toModel ReptilianArmLower = reptilian_arm_lower -toModel ReptilianArmUpper = reptilian_arm_upper -toModel ThinLimb = thin_limb - -all_library_models :: [LibraryModel] -all_library_models = - Prelude.map TerrainTile known_terrain_types ++ - [QuestionMark, NullModel, - Encephalon, - Recreant, - Androsynth, - Caduceator, - Reptilian, - AscendantGlow, - PhasePistol, - MachineArmLower, - MachineArmUpper, - CaduceatorArmLower, - CaduceatorArmUpper, - ReptilianLegLower, - ReptilianLegUpper, - ReptilianArmLower, - ReptilianArmUpper, - ThinLimb] - -data Library = Library - Bottleneck - (MVar (Map LibraryModel (QualityCache Quality IntermediateModel))) - -newLibrary :: IO Library -newLibrary = - do lib <- liftM2 Library newBottleneck (newMVar Map.empty) - mapM_ (\x -> do hPutStrLn stderr ("Preloading model: " ++ show x) - lookupModel lib x Poor) all_library_models - return lib - -lookupModel :: Library -> LibraryModel -> Quality -> IO IntermediateModel -lookupModel (Library bottleneck lib) lm q = - do lib_map <- takeMVar lib - m_qo <- return $ Map.lookup lm lib_map - case m_qo of - Just qo -> do putMVar lib lib_map - getQuality qo q - Nothing -> do qo <- newQuality bottleneck parIntermediateModel (\q' -> toIntermediateModel (qualityToVertices q') (toModel lm q')) [Bad,Poor,Good,Super] - putMVar lib $ insert lm qo lib_map - getQuality qo q -\end{code} diff --git a/src/Models/LibraryData.hs b/src/Models/LibraryData.hs new file mode 100644 --- /dev/null +++ b/src/Models/LibraryData.hs @@ -0,0 +1,82 @@ +module Models.LibraryData + (LibraryModel(..), + SimpleModel(..), + EnergyColor(..), + EnergyThing(..), + LibraryModelSource(..)) + where + +import Models.Sky +import qualified Data.ByteString.Char8 as B + +data EnergyColor = Blue | Yellow | Red | Green + deriving (Eq,Ord,Show,Enum,Bounded) + +data SimpleModel = + LeafyBlob + | TreeBranch + | QuestionMark + -- Creature Bodies + | Encephalon + | Recreant + | Androsynth + | AscendantGlow + | Caduceator + | Reptilian + -- Tools + | PhasePistol + | Phaser + | PhaseRifle + | GasSphere + | MetalSphere + | ChromaliteSphere + -- Arms and Legs + | MachineArmLower + | MachineArmUpper + | CaduceatorArmLower + | CaduceatorArmUpper + | ReptilianLegUpper + | ReptilianLegLower + | ReptilianArmUpper + | ReptilianArmLower + | ThinLimb + -- Space Ship Parts + | CyborgType4Dome + | CyborgType4Base + | CyborgType4HyperspaceDisc + | CyborgType4HyperspaceRotor + | CyborgType4HyperspaceStabilizer + -- Buildings + | Monolith + | Portal + deriving (Eq,Ord,Show,Enum,Bounded) + +data EnergyThing = + EnergySword + | EnergyCylinder + deriving (Eq,Ord,Show,Enum,Bounded) + +data LibraryModel = + -- Terrain + TerrainTile B.ByteString + -- Astronomical Phenomena + | SkySphere SkyInfo + | SunDisc SunInfo + -- The Null Model + | NullModel + -- SimpleModels (zero-parameter models) + | SimpleModel SimpleModel + -- Energy things + | EnergyThing EnergyThing EnergyColor + deriving (Eq,Ord,Show) + +-- | Things that are also LibraryModels. +class LibraryModelSource a where + toLibraryModel :: a -> LibraryModel + +instance LibraryModelSource LibraryModel where + toLibraryModel = id + +instance LibraryModelSource SimpleModel where + toLibraryModel = SimpleModel + diff --git a/src/Models/LibraryData.lhs b/src/Models/LibraryData.lhs deleted file mode 100644 --- a/src/Models/LibraryData.lhs +++ /dev/null @@ -1,29 +0,0 @@ -\section{Library Models} - -\begin{code} -module Models.LibraryData - (LibraryModel(..)) - where - -data LibraryModel = - TerrainTile String - | QuestionMark - | NullModel - | Encephalon - | Recreant - | Androsynth - | AscendantGlow - | Caduceator - | Reptilian - | PhasePistol - | MachineArmLower - | MachineArmUpper - | CaduceatorArmLower - | CaduceatorArmUpper - | ReptilianLegUpper - | ReptilianLegLower - | ReptilianArmUpper - | ReptilianArmLower - | ThinLimb - deriving (Eq,Ord,Show) -\end{code} diff --git a/src/Models/MachineParts.hs b/src/Models/MachineParts.hs --- a/src/Models/MachineParts.hs +++ b/src/Models/MachineParts.hs @@ -5,33 +5,31 @@ where import Quality -import RSAGL.Model -import RSAGL.CurveExtras -import RSAGL.Affine -import RSAGL.Vector -import RSAGL.Angle +import RSAGL.Modeling +import RSAGL.Math.CurveExtras +import RSAGL.Math import Models.Materials machine_arm_lower :: Quality -> Modeling () machine_arm_lower _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ - do sor $ linearInterpolation $ - points2d [(0.001,4.5), + do sor $ linearInterpolation $ reverse $ + points2d [(0.0,4.5), (0.25,4.5), (0.25,3.5), (0.35,3), (0.35,0.5), - (0.001,0.3)] + (0.0,0.3)] alliance_metal machine_arm_upper :: Quality -> Modeling () machine_arm_upper _ = scale' (1/4) $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ - do sor $ linearInterpolation $ - points2d [(0.001,4.5), + do sor $ linearInterpolation $ reverse $ + points2d [(0.0,4.5), (0.5,4.5), (0.75,3.5), (0.5,3), (0.5,1), - (0.001,-0.5)] + (0.0,-0.5)] alliance_metal thin_limb :: Quality -> Modeling () diff --git a/src/Models/Materials.hs b/src/Models/Materials.hs new file mode 100644 --- /dev/null +++ b/src/Models/Materials.hs @@ -0,0 +1,133 @@ +module Models.Materials + ( + -- | Materials by Faction + treaty_metal, + treaty_glow, + treaty_energy_field, + alliance_metal, + concordance_metal, + concordance_dark_glass, + concordance_bright_glass, + cyborg_metal, + cyborg_glow, + -- | Material by Species + caduceator_skin, + encephalon_skin, + reptilian_skin, + reptilian_pigment, + reptilian_specular, + -- | Material by Energy Type + energyColor, + energyMaterial) + where + +import RSAGL.Modeling +import Models.LibraryData + +{--------------------------------------------------------- + - Materials by Faction + - -------------------------------------------------------} + +-- Treaty Organization Materials (cyan-teal solid colors, yellow energy colors) + +treaty_metal :: MaterialM attr () +treaty_metal = material $ + do pigment $ pure camouflage_green + specular 1 $ pure $ viridian + +treaty_glow :: MaterialM attr () +treaty_glow = material $ + do pigment $ pure black + emissive $ pure brass + +treaty_energy_field :: MaterialM attr () +treaty_energy_field = material $ + do emissive $ pure brass + specular 1 $ pure saffron + +-- Alliance Materials (yellow-gold solid colors, orange energy colors) + +alliance_metal :: Modeling () +alliance_metal = material $ + do pigment $ pure $ scaleRGB 0.6 gold + specular 7 $ pure gold + +-- Concordance Materials (violet solid colors, blue energy colors) + +concordance_metal :: Modeling () +concordance_metal = material $ + do pigment $ pure slate_gray + specular 4 $ pure lilac + +concordance_dark_glass :: Modeling () +concordance_dark_glass = material $ + do pigment $ pure black + specular 8 $ pure eggplant + +concordance_bright_glass :: Modeling () +concordance_bright_glass = material $ + do pigment $ pure black + emissive $ pure puce + specular 8 $ pure eggplant + +-- Pirates (green solid colors, red energy colors) + +-- Utopiate (red solid colors, cyan-teal energy colors) + +-- Whispers (black solid colors, white energy colors) + +-- Monster (orange solid colors, violet energy colors) + +-- Cyborg Materials (white solid colors, green energy colors) + +cyborg_metal :: MaterialM attr () +cyborg_metal = metallic $ pure wheat + +cyborg_glow :: MaterialM attr () +cyborg_glow = + do pigment $ pure blackbody + emissive $ pure $ scaleRGB 1.0 green + +{------------------------------------------------------- + - Materials by Species + - -----------------------------------------------------} + +-- Caduceator Skins + +caduceator_skin :: Modeling () +caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure safety_orange),(1.0,pure black)] + +-- Reptilian Skins + +reptilian_pigment :: ColorFunction RGB +reptilian_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure saffron)] + +reptilian_specular :: ColorFunction RGB +reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)] + +reptilian_skin :: Modeling () +reptilian_skin = material $ + do pigment $ reptilian_pigment + specular 5.0 $ reptilian_specular + +-- Encephalon Skins + +encephalon_skin :: Modeling () +encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)] + +{-------------------------------------------------------- + - Material by Energy Type + - ------------------------------------------------------} + +energyColor :: EnergyColor -> RGB +energyColor Blue = cobalt +energyColor Yellow = saffron +energyColor Red = red +energyColor Green = shamrock + +energyMaterial :: EnergyColor -> Modeling () +energyMaterial c = material $ + do pigment $ pure $ scaleRGB 0.33 $ energyColor c + specular 1.0 $ pure $ scaleRGB 0.33 $ energyColor c + emissive $ pure $ scaleRGB 0.33 $ energyColor c + diff --git a/src/Models/Materials.lhs b/src/Models/Materials.lhs deleted file mode 100644 --- a/src/Models/Materials.lhs +++ /dev/null @@ -1,92 +0,0 @@ -\section{Materials} - -\begin{code} -module Models.Materials - (alliance_metal, - concordance_metal, - concordance_dark_glass, - concordance_bright_glass, - caduceator_skin, - encephalon_skin, - recreant_metal, - reptilian_skin, - reptilian_pigment, - reptilian_specular) - where - -import RSAGL.Model -import RSAGL.ModelingExtras -\end{code} - -\subsection{Materials by Alliance} - -\subsubsection{Alliance Materials} - -\begin{code} -alliance_metal :: Modeling () -alliance_metal = material $ - do pigment $ pure $ scaleRGB 0.6 gold - specular 75 $ pure $ scaleRGB 1.0 gold -\end{code} - -\subsubsection{Condorance Materials} - -\begin{code} -concordance_metal :: Modeling () -concordance_metal = material $ - do pigment $ pure slate_gray - specular 45 $ pure lilac -\end{code} - -\begin{code} -concordance_dark_glass :: Modeling () -concordance_dark_glass = material $ - do pigment $ pure black - specular 85 $ pure eggplant -\end{code} - -\begin{code} -concordance_bright_glass :: Modeling () -concordance_bright_glass = material $ - do pigment $ pure black - emissive $ pure puce - specular 85 $ pure eggplant -\end{code} - -\section{Materials by Species} - -\subsubsection{Encephalon Materials} - -\begin{code} -caduceator_skin :: Modeling () -caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure safety_orange),(1.0,pure black)] -\end{code} - -\begin{code} -reptilian_pigment :: ColorFunction RGB -reptilian_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure saffron)] - -reptilian_specular :: ColorFunction RGB -reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)] - -reptilian_skin :: Modeling () -reptilian_skin = material $ - do pigment $ reptilian_pigment - specular 5.0 $ reptilian_specular - -\end{code} - -\begin{code} -encephalon_skin :: Modeling () -encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)] -\end{code} - -\subsubsection{Recreant Materials} - -\begin{code} -recreant_metal :: Modeling () -recreant_metal = material $ - do pigment $ pure camouflage_green - specular 25 $ pure white -\end{code} - diff --git a/src/Models/Monolith.hs b/src/Models/Monolith.hs new file mode 100644 --- /dev/null +++ b/src/Models/Monolith.hs @@ -0,0 +1,14 @@ +module Models.Monolith + (monolith) + where + +import RSAGL.Math +import RSAGL.Modeling +import Quality + +monolith :: Quality -> Modeling () +monolith _ = + do box (Point3D (-1/2) 0 (-1/8)) (Point3D (1/2) (9/4) (1/8)) + material $ + do pigment $ pure blackbody + specular 100 $ pure white diff --git a/src/Models/PhaseWeapons.hs b/src/Models/PhaseWeapons.hs --- a/src/Models/PhaseWeapons.hs +++ b/src/Models/PhaseWeapons.hs @@ -1,20 +1,23 @@ module Models.PhaseWeapons - (phase_pistol) + (phase_pistol, + phaser, + phase_rifle) where import Quality import Models.Materials -import RSAGL.Vector -import RSAGL.Model -import RSAGL.Affine -import RSAGL.CurveExtras -import RSAGL.Angle +import RSAGL.Math +import RSAGL.Modeling +import RSAGL.Math.CurveExtras +import Control.Monad -phase_weapon_emitter :: Quality -> Modeling () -phase_weapon_emitter _ = model $ +-- | A phase weapon emitter. Includes a specification of a phase guide length. +phaseWeaponEmitter :: Integer -> Quality -> Modeling () +phaseWeaponEmitter guide_length _ = model $ do sor $ linearInterpolation $ points2d $ reverse - [(0.001,0), + [(0,0), + (1,0), (4,1), (7,2), (9,3), @@ -23,15 +26,16 @@ (7,-6), (4,-9), (2,-10), - (0.001,-10)] - deform dfn + (0,-10)] + let guide_length_y = fromInteger guide_length * 3 + 6 + when (guide_length > 0) $ openCone (Point3D 0 0 8,1) (Point3D 0 guide_length_y 8,0) + _ <- flip mapM [2..guide_length] $ \i -> + do let y = fromInteger i * 3 + translate (Vector3D 0 y 0) $ torus 8 (lerpBetween (0,y,guide_length_y) (1,0)) + deform dfn_squish affine $ rotateX (fromDegrees 90) - where dfn_squish p@(Point3D _ _ z) | z > 0 = scale (Vector3D 1 1 0.1) p - dfn_squish p = scale (Vector3D 1 1 0.25) p - dfn_smoothe_dish p@(Point3D _ y _) | y > 0 = scale (Vector3D 1 (u/10) 1) p - where u = distanceBetween origin_point_3d $ scale (Vector3D 1 0 1) p - dfn_smoothe_dish p = p - dfn = dfn_smoothe_dish . dfn_squish + where dfn_squish p@(Point3D _ _ z) | z > 0 = scale (Vector3D 1 1 0.1) p -- bottom of emitter is flattened + dfn_squish p = scale (Vector3D 1 1 0.25) p -- top of emitter is more round phase_weapon_grip :: Quality -> Modeling () phase_weapon_grip _ = model $ @@ -52,10 +56,19 @@ dfn_flat_sides (Point3D x y z) = Point3D ((signum x *) $ sqrt (abs x/3)) y z dfn_slope_backwards pt@(Point3D _ y _) = translate (Vector3D 0 0 (-y/3)) pt dfn = dfn_slope_backwards . dfn_flat_back . dfn_flat_sides . dfn_gripped_front - -phase_pistol :: Quality -> Modeling () -phase_pistol q = model $ + +phaseWeapon :: Integer -> Quality -> Modeling () +phaseWeapon guide_length q = model $ scale' (1/100) $ - do translate (Vector3D 0 5 7) $ phase_weapon_emitter q + do translate (Vector3D 0 5 7) $ phaseWeaponEmitter guide_length q translate (Vector3D 0 5 0) $ phase_weapon_grip q concordance_metal + +phase_pistol :: Quality -> Modeling () +phase_pistol = phaseWeapon 0 + +phaser :: Quality -> Modeling () +phaser = phaseWeapon 1 + +phase_rifle :: Quality -> Modeling () +phase_rifle = phaseWeapon 2 diff --git a/src/Models/QuestionMark.hs b/src/Models/QuestionMark.hs --- a/src/Models/QuestionMark.hs +++ b/src/Models/QuestionMark.hs @@ -2,12 +2,9 @@ (question_mark) where -import RSAGL.Model -import RSAGL.ModelingExtras -import RSAGL.Affine -import RSAGL.Vector -import RSAGL.CurveExtras -import RSAGL.Curve +import RSAGL.Modeling +import RSAGL.Math +import RSAGL.Math.CurveExtras question_mark_material :: Modeling () question_mark_material = material $ diff --git a/src/Models/Recreant.hs b/src/Models/Recreant.hs --- a/src/Models/Recreant.hs +++ b/src/Models/Recreant.hs @@ -3,10 +3,9 @@ where import Quality -import RSAGL.Model -import RSAGL.CurveExtras -import RSAGL.Vector -import RSAGL.Affine +import RSAGL.Modeling +import RSAGL.Math.CurveExtras +import RSAGL.Math import Models.Materials recreant_antenna_small :: Quality -> Modeling () @@ -31,11 +30,11 @@ recreant_body _ = do sor $ linearInterpolation $ points2d $ reverse - [(0.001,3), + [(0,3), (4,3), (6,2), (7,1), - (0.001,0)] + (0,0)] recreant :: Quality -> Modeling () recreant q = scale' 0.05 $ diff --git a/src/Models/RecreantFactory.hs b/src/Models/RecreantFactory.hs --- a/src/Models/RecreantFactory.hs +++ b/src/Models/RecreantFactory.hs @@ -3,8 +3,8 @@ where import Quality -import RSAGL.Model -import RSAGL.Vector +import RSAGL.Modeling +import RSAGL.Math import Models.Materials recreant_factory :: Quality -> Modeling () @@ -17,4 +17,4 @@ sphere (Point3D 0.4 0 (-0.4)) 0.1 sphere (Point3D 0.4 0 0.4) 0.1 sphere (Point3D (-0.4) 0 0.4) 0.1 - recreant_metal + alliance_metal diff --git a/src/Models/Reptilian.hs b/src/Models/Reptilian.hs --- a/src/Models/Reptilian.hs +++ b/src/Models/Reptilian.hs @@ -6,20 +6,17 @@ reptilian_arm_lower) where -import RSAGL.Vector -import RSAGL.Model +import RSAGL.Math +import RSAGL.Modeling import Quality import Models.Materials -import RSAGL.ModelingExtras -import RSAGL.CurveExtras -import RSAGL.Affine -import RSAGL.Angle +import RSAGL.Math.CurveExtras reptilian :: Quality -> Modeling () reptilian _ = model $ do model $ do tube $ linearInterpolation - [(0.001,Point3D 0 0 (-6)), + [(0 ,Point3D 0 0 (-6)), (1 ,Point3D 0 5 (-4)), (1.5 ,Point3D 0 5.5 (-3)), (2.4 ,Point3D 0 6 (-2)), @@ -31,7 +28,7 @@ (1 ,Point3D 0 11 1), (1 ,Point3D 0 11 2), (0.5 ,Point3D 0 10 2.5), - (0.001,Point3D 0 9 3)] + (0 ,Point3D 0 9 3)] model $ do triangle (Point3D 0 7 (-2)) (Point3D (-1) 10 (-8)) (Point3D 1 10 (-8)) triangle (Point3D 0 7 (-2)) (Point3D (-0.25) 9 (-9)) (Point3D (-3.5) 9.5 (-8)) @@ -42,20 +39,20 @@ deform $ \(Point3D x y z) -> Point3D x (y+x^2/100) (z+x^2/25+sin (x*10)/4) reptilian_skin model $ - do sphere (Point3D 0.5 11 2) 0.25 - sphere (Point3D (-0.5) 11 2) 0.25 + do sphere (Point3D 0.55 11 2) 0.5 + sphere (Point3D (-0.55) 11 2) 0.5 material $ pigment $ pure black affine $ scale' (1/20) reptilian_leg_upper :: Quality -> Modeling () reptilian_leg_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do model $ sor $ linearInterpolation $ - points2d [(0.0001,0), + points2d [(0 ,0), (1.9,1), (1.6,5), (1,7.5), (0.75,10.6), - (0.0001,10.8)] + (0 ,10.8)] material $ do pigment $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_pigment),(1.0,pure burgundy)] specular 5.0 $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_specular),(1.0,pure crimson)] @@ -64,12 +61,12 @@ reptilian_leg_lower :: Quality -> Modeling () reptilian_leg_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do sor $ linearInterpolation $ - points2d [(0.0001,-0.15), + points2d [(0 ,-0.15), (0.5,-0.1), (1.0,0.0), (0.5,9.0), (0.5,10.0), - (0.0001,10.1)] + (0 ,10.1)] openCone (Point3D 0 9.5 0,0.5) (Point3D 0 10 7,0.0001) openCone (Point3D 0 9.5 0,0.5) (Point3D 5 10 5,0.0001) openCone (Point3D 0 9.5 0,0.5) (Point3D (-5) 10 5,0.0001) @@ -81,13 +78,13 @@ reptilian_arm_upper :: Quality -> Modeling () reptilian_arm_upper _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do sor $ linearInterpolation $ - points2d [(0.0001,0.0), + points2d [(0 ,0.0), (1.0,0.1), (0.5,1.0), (0.25,5.0), (0.5,9.0), (1.0,9.9), - (0.0001,0.0)] + (0 ,0.0)] material $ do pigment $ pure burgundy specular 5.0 $ pure crimson @@ -96,12 +93,12 @@ reptilian_arm_lower :: Quality -> Modeling () reptilian_arm_lower _ = rotate (Vector3D 1 0 0) (fromDegrees 90) $ model $ do sor $ linearInterpolation $ - points2d [(0.0001,-1.0), + points2d [(0 ,-1.0), (1.0,0.0), (0.25,5.0), (0.5,9.0), (0.5,9.9), - (0.0001,0.0)] + (0 ,0.0)] material $ do pigment $ pure burgundy specular 5.0 $ pure crimson diff --git a/src/Models/Stargate.hs b/src/Models/Stargate.hs new file mode 100644 --- /dev/null +++ b/src/Models/Stargate.hs @@ -0,0 +1,38 @@ +module Models.Stargate + (portal) + where + +import RSAGL.Math +import RSAGL.Modeling +import Models.Materials +import Quality + +portal :: Quality -> Modeling () +portal q = + do model $ + do model $ + do box (Point3D (-0.6) 0 (-0.05)) (Point3D (-0.5) 1.618 0.05) + box (Point3D 0.6 0 (-0.05)) (Point3D 0.5 1.618 0.05) + box (Point3D (-1.1) 1.568 (-0.05)) + (Point3D (1.1) 1.668 0.05) + minorFixedQuality q + let cone = + do openCone (Point3D 0 (1.618/6) 0,0.4) + (Point3D 0 (1.618/3) 0,0) + openCone (Point3D 0 (1.618/6) 0,0.4) (Point3D 0 0 0,0) + cone_stack = scale (Vector3D 1 (7/8) 1) $ + do cone + translate (Vector3D 0 (1.618/3) 0) cone + translate (Vector3D 0 (2*1.618/3) 0) cone + translate (Vector3D 0 1.618 0) cone + translate (Vector3D 1.1 0 0) cone_stack + translate (Vector3D (-1.1) 0 0) cone_stack + material treaty_metal + model $ + do quadralateral (Point3D (-0.55) 0 0) + (Point3D (-0.55) 1.618 0) + (Point3D 0.55 1.618 0) + (Point3D 0.55 0 0) + twoSided True + material treaty_energy_field + diff --git a/src/Models/Terrain.hs b/src/Models/Terrain.hs new file mode 100644 --- /dev/null +++ b/src/Models/Terrain.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Models.Terrain + (known_terrain_types, + terrainTile) + where + +import Quality +import Models.RecreantFactory +import RSAGL.Modeling +import RSAGL.Math +import RSAGL.Types +import qualified Data.ByteString.Char8 as B + +-- | +-- A list of all terrain type names known to roguestar-gl. +-- But at any given moment the engine might have been extended to include other types. +known_terrain_types :: [B.ByteString] +known_terrain_types = + ["water", + "deepwater", + "sand", + "desert", + "grass", + "dirt", + "forest", + "deepforest", + "ice", + "lava", + "glass", + "rockyground", + "rubble", + "rockface", + "recreantfactory"] + +-- | +-- A simple 1-by-1 square patch, centered at the origin, and raised on a slope toward it's center. +-- The first parameter indicates the patch's actual height, while the second represent's the patch's +-- apparent height based on it's normal vectors. +-- The sloping effect makes it clear where one tile ends and another begins, which is practical for game play. +-- The two heights are different as it is not desireable that creature's legs should dissappear inside the landscape, +-- but at shallow angles of attack this makes the terrain tile look fake. REVISIT +-- +-- This is just the shape, without any material. +-- +terrainTileShape :: RSdouble -> RSdouble -> Quality -> Modeling () +terrainTileShape physical_height aesthetic_height q = model $ + do heightField (-0.5,-0.5) (0.5,0.5) $ \(x,z) -> let y = 1 - max (abs x) (abs z) * 2 in min (max 0 $ sqrt y) (2*y) + affine $ scale (Vector3D 1 aesthetic_height 1) + deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 (physical_height/aesthetic_height) 1) p) v + qualityToFixed q + +-- | +-- Creates a terrain tile based on 'terrainTileShape' with appropriate characteristics and material for its type, +-- but without any special casing for unsual terrains like forest. +-- +basicTerrainTile :: B.ByteString -> Quality -> Modeling () +basicTerrainTile s q = model $ + do terrainTileShape 0.01 (terrainHeight s) q + material $ terrainTexture s + +-- | +-- Creates a terrain tile based on 'terrainTileShape' +-- Provides special casing for forest, rockface, liquids, etc. +-- +terrainTile :: B.ByteString -> Quality -> Modeling () +terrainTile "recreantfactory" q = recreant_factory q +terrainTile "rockface" q = model $ + do terrainTileShape (terrainHeight "rockface") (terrainHeight "rockface") q + material $ terrainTexture "rockface" +terrainTile s q = basicTerrainTile s q + +-- | +-- Answers the height of a type of terrain. +-- Note that, with some exceptions, all terrain is the same height, but some terrain is given +-- sharper contrast in its normal vectors than others (see 'terrainTileShape'). +-- Unrecognized terrain types will appear very tall, so they can be easily noticed and corrected. +-- +terrainHeight :: B.ByteString -> RSdouble +terrainHeight "water" = 0.01 +terrainHeight "deepwater" = 0.005 +terrainHeight "sand" = 0.1 +terrainHeight "desert" = 0.1 +terrainHeight "grass" = 0.13 +terrainHeight "dirt" = 0.12 +terrainHeight "forest" = 0.15 +terrainHeight "deepforest" = 0.17 +terrainHeight "ice" = 0.05 +terrainHeight "lava" = 0.06 +terrainHeight "glass" = 0.04 +terrainHeight "rockyground" = 0.18 +terrainHeight "rubble" = 0.2 +terrainHeight "rockface" = 1.0 +terrainHeight _ = 5.0 + +-- | +-- Answers the material of a type of terrain. +-- Unrecognized terrain types will appear bright magenta, so they can be easily +-- noticed and corrected. +-- +terrainTexture :: B.ByteString -> MaterialM () () +terrainTexture "water" = + do pigment $ pure blue + specular 100 $ pure white +terrainTexture "deepwater" = + do pigment $ pure $ scaleRGB 0.8 blue + specular 100 $ pure white +terrainTexture "sand" = pigment $ pure corn +terrainTexture "desert" = pigment $ pure $ lerp 0.5 (corn,white) +terrainTexture "grass" = pigment $ pure forest_green +terrainTexture "dirt" = pigment $ pure brown +terrainTexture "forest" = pigment $ pure fern_green +terrainTexture "deepforest" = pigment $ pure fern_green +terrainTexture "ice" = + do pigment $ pure white + specular 1 $ pure teal +terrainTexture "lava" = + do pigment $ pure blackbody + emissive $ pure coral +terrainTexture "glass" = + do pigment $ pure black + specular 1 $ pure white +terrainTexture "rockyground" = pigment $ pure slate_gray +terrainTexture "rubble" = pigment $ pure slate_gray +terrainTexture "rockface" = pigment $ pure slate_gray +terrainTexture _ = + do pigment $ pure blackbody + emissive $ pure magenta + diff --git a/src/Models/Terrain.lhs b/src/Models/Terrain.lhs deleted file mode 100644 --- a/src/Models/Terrain.lhs +++ /dev/null @@ -1,108 +0,0 @@ -\section{Terrain Tiles} - -\begin{code} -module Models.Terrain - (known_terrain_types, - terrainTile) - where - -import Quality -import Models.RecreantFactory -import RSAGL.Model -import RSAGL.ModelingExtras -import Models.Tree -import RSAGL.Vector -import RSAGL.Interpolation -import RSAGL.Affine -import RSAGL.Angle - -known_terrain_types :: [String] -known_terrain_types = - ["water", - "deepwater", - "sand", - "desert", - "grass", - "forest", - "deepforest", - "ice", - "lava", - "glass", - "rockyground", - "rubble", - "rockface", - "recreantfactory"] - -terrainTileShape :: Double -> Double -> Modeling () -terrainTileShape squash height = model $ - do regularPrism (origin_point_3d,sqrt 0.5) (Point3D 0 1 0,0.0001) 4 - deform $ \(Point3D x y z) -> Point3D x (sqrt $ max 0 y) z - affine $ scale (Vector3D 1 height 1) . rotate (Vector3D 0 1 0) (fromDegrees 45) - deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 squash 1) p) v - -terrainTile :: String -> Quality -> Modeling () -terrainTile "recreantfactory" q = recreant_factory q -terrainTile "forest" q = - do basicTerrainTile "forest" - leafy_tree q -terrainTile "deepforest" q = - do basicTerrainTile "deepforest" - translate (Vector3D 0.5 0 0.5) $ leafy_tree q - translate (Vector3D (-0.5) 0 0.5) $ leafy_tree q - translate (Vector3D 0 0 (-0.5)) $ leafy_tree q -terrainTile "rockface" _ = model $ - do terrainTileShape 1.0 (terrainHeight "rockface") - material $ terrainTexture "rockface" -terrainTile s _ = basicTerrainTile s - -basicTerrainTile :: String -> Modeling () -basicTerrainTile s = model $ - do terrainTileShape 0.01 (terrainHeight s) - material $ terrainTexture s - -terrainHeight :: String -> Double -terrainHeight "water" = 0.025 -terrainHeight "deepwater" = 0.025 -terrainHeight "sand" = 0.1 -terrainHeight "desert" = 0.1 -terrainHeight "grass" = 0.13 -terrainHeight "dirt" = 0.12 -terrainHeight "forest" = 0.15 -terrainHeight "deepforest" = 0.17 -terrainHeight "ice" = 0.05 -terrainHeight "lava" = 0.06 -terrainHeight "glass" = 0.04 -terrainHeight "rockyground" = 0.18 -terrainHeight "rubble" = 0.2 -terrainHeight "rockface" = 0.5 -terrainHeight _ = 2.0 - -terrainTexture :: String -> MaterialM () () -terrainTexture "water" = - do pigment $ pure blue - specular 100 $ pure white -terrainTexture "deepwater" = - do pigment $ pure $ scaleRGB 0.8 blue - specular 100 $ pure white -terrainTexture "sand" = pigment $ pure corn -terrainTexture "desert" = pigment $ pure $ lerp 0.5 (corn,white) -terrainTexture "grass" = pigment $ pure forest_green -terrainTexture "dirt" = pigment $ pure brown -terrainTexture "forest" = pigment $ pure fern_green -terrainTexture "deepforest" = pigment $ pure fern_green -terrainTexture "ice" = - do pigment $ pure white - specular 1 $ pure teal -terrainTexture "lava" = - do pigment $ pure blackbody - emissive $ pure coral -terrainTexture "glass" = - do pigment $ pure black - specular 1 $ pure white -terrainTexture "rockyground" = pigment $ pure slate_gray -terrainTexture "rubble" = pigment $ pure slate_gray -terrainTexture "rockface" = pigment $ pure slate_gray -terrainTexture _ = - do pigment $ pure blackbody - emissive $ pure magenta -\end{code} diff --git a/src/Models/Tree.hs b/src/Models/Tree.hs --- a/src/Models/Tree.hs +++ b/src/Models/Tree.hs @@ -1,39 +1,17 @@ module Models.Tree - (leafy_tree) + (leafy_blob, tree_branch) where -import RSAGL.Model -import RSAGL.ModelingExtras -import RSAGL.Vector -import Control.Monad.Random -import Quality -import RSAGL.Affine -import RSAGL.AbstractVector -import RSAGL.Interpolation -import Control.Monad.State +import RSAGL.Modeling +import RSAGL.Math -leafy_tree :: Quality -> Modeling () -leafy_tree Bad = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 2) (mkStdGen 45) -leafy_tree Poor = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 3) (mkStdGen 45) -leafy_tree Good = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 4) (mkStdGen 45) -leafy_tree Super = evalRandT (leafyTreeBranch origin_point_3d (Vector3D 0 0.5 0) 0.1 5) (mkStdGen 45) +leafy_blob :: ModelingM () () +leafy_blob = model $ + do sphere (Point3D 0 0 0) 1.0 + material $ pigment $ pure forest_green -leafyTreeBranch :: Point3D -> Vector3D -> Double -> Int -> RandT StdGen (ModelingM ()) () -leafyTreeBranch point vector thickness recursion | recursion <= 0 = - do b <- getRandom - when b $ lift $ model $ - do sphere point (vectorLength vector + thickness) - material $ pigment $ pure forest_green -leafyTreeBranch point vector thickness recursion = - do lift $ model $ - do closedCone (point,thickness) (translate vector point,thickness/2) - material $ pigment $ pure dark_brown - us <- liftM (take recursion) $ getRandomRs (0.0,1.0) - mapM leafyTreeBranchFrom us - leafyTreeBranchFrom 1.0 - where leafyTreeBranchFrom :: Double -> RandT StdGen (ModelingM ()) () - leafyTreeBranchFrom u = - do let new_vector_constraint = vectorLength vector / 1.5 - (x:y:z:_) <- getRandomRs (-new_vector_constraint,new_vector_constraint) - t <- getRandomR (thickness/3,thickness/2) - leafyTreeBranch (lerp u (point,translate vector point)) (vectorScaleTo new_vector_constraint $ vector `add` (Vector3D x y z)) t (recursion - 1) +tree_branch :: ModelingM () () +tree_branch = model $ + do closedCone (Point3D 0 0 0, 1.0) (Point3D 0 1 0, 0.5) + material $ pigment $ pure dark_brown + diff --git a/src/PrintText.hs b/src/PrintText.hs new file mode 100644 --- /dev/null +++ b/src/PrintText.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A 'PrintTextObject' renders the text console at the bottom of the screen. + +module PrintText + (newPrintTextObject, + printText, + PrintTextObject, + renderText, + PrintTextMode(..), + TextType(..), + getInputBuffer, + pullInputBuffer, + setInputBuffer, + setPrintTextMode, + clearOutputBuffer, + clearInputBuffer, + keyCallback) + where + +import Control.Concurrent.STM +import Graphics.UI.GLUT as GLUT +import PrintTextData +import Control.Monad +import Control.Concurrent.Chan +import qualified Data.ByteString.Char8 as B + +data PrintTextData = PrintTextData { + text_output_buffer :: [(TextType,B.ByteString)], + text_input_buffer :: B.ByteString, + text_output_mode :: PrintTextMode } + +data PrintTextObject = PrintTextObject (TVar PrintTextData) (Chan B.ByteString) + +font_width_pixels :: Int +font_width_pixels = 9 + +font_height_pixels :: Int +font_height_pixels = 15 + +padding_pixels :: Int +padding_pixels = 10 + +font :: BitmapFont +font = Fixed9By15 + +newPrintTextObject :: IO PrintTextObject +newPrintTextObject = + do pt_data <- newTVarIO $ PrintTextData { + text_output_buffer = [], + text_input_buffer = B.empty, + text_output_mode = Unlimited } + pt_chan <- newChan + return $ PrintTextObject pt_data pt_chan + +printText :: PrintTextObject -> TextType -> B.ByteString -> STM () +printText (PrintTextObject pto _) text_type str = + do print_text <- readTVar pto + writeTVar pto $ print_text { + text_output_buffer = text_output_buffer print_text ++ + map ((,) text_type) (B.lines str) } + +keyCallback :: PrintTextObject -> KeyboardMouseCallback +keyCallback (PrintTextObject _ chan) (Char char) Down _ _ = + writeChan chan $ B.pack [char] +keyCallback (PrintTextObject _ chan) (SpecialKey special) Down _ _ = + writeChan chan $ ":::" `B.append` (B.pack $ show special) +keyCallback _ _ _ _ _ = return () + +getInputBuffer :: PrintTextObject -> IO B.ByteString +getInputBuffer (PrintTextObject pto _) = + liftM text_input_buffer $ atomically $ readTVar pto + +-- | Pull one keypress into the input buffer, if it exists. +pullInputBuffer :: PrintTextObject -> IO () +pullInputBuffer (PrintTextObject pto chan) = + do e <- isEmptyChan chan + when (not e) $ + do r <- readChan chan + atomically $ + do print_text <- readTVar pto + writeTVar pto $ print_text { + text_input_buffer = text_input_buffer print_text + `B.append` r } + return () + +setInputBuffer :: PrintTextObject -> B.ByteString -> IO () +setInputBuffer (PrintTextObject pto _) new_input_buffer = atomically $ + do print_text <- readTVar pto + writeTVar pto $ print_text { text_input_buffer = new_input_buffer } + +clearOutputBuffer :: PrintTextObject -> STM () +clearOutputBuffer (PrintTextObject pto _) = + do print_text <- readTVar pto + writeTVar pto $ print_text { text_output_buffer = [] } + +setPrintTextMode :: PrintTextObject -> PrintTextMode -> STM () +setPrintTextMode (PrintTextObject pto _) pt_mode = + do print_text <- readTVar pto + writeTVar pto $ print_text { text_output_mode = pt_mode } + +clearInputBuffer :: PrintTextObject -> IO () +clearInputBuffer (PrintTextObject pto _) = atomically $ + do print_text <- readTVar pto + writeTVar pto $ print_text { text_input_buffer = B.empty } + +renderText :: PrintTextObject -> IO () +renderText (PrintTextObject pto _) = + do ptd <- atomically $ readTVar pto + (Size width height) <- get windowSize + save_depth_func <- get depthFunc + save_depth_mask <- get depthMask + save_blend <- get blend + depthFunc $= Nothing + depthMask $= GLUT.Disabled + blend $= Enabled + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral width) 0 (fromIntegral height) + matrixMode $= Modelview 0 + loadIdentity + let max_characters_height = + (fromIntegral height - 2 * fromIntegral padding_pixels) `div` + (fromIntegral font_height_pixels) + let max_characters_width = + (fromIntegral width - 2 * fromIntegral padding_pixels) `div` + (fromIntegral font_width_pixels) + let lines_to_print = + restrictLines max_characters_height max_characters_width $ + (case (text_output_mode ptd) of + PrintTextData.Disabled -> [] + Limited -> reverse $ take 3 $ reverse $ + text_output_buffer ptd + Unlimited -> (text_output_buffer ptd)) ++ + (if B.length (text_input_buffer ptd) > 0 || + text_output_mode ptd /= PrintTextData.Disabled + then [(Query,"> " `B.append` (text_input_buffer ptd))] + else []) + actual_width_pixels = font_width_pixels * + (maximum $ map (B.length . snd) lines_to_print) + actual_height_pixels = font_height_pixels * (length lines_to_print) + in do color $ (Color4 0 0 0 0.92 :: Color4 GLfloat) + (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()) + (Vertex2 (fromIntegral padding_pixels) + (fromIntegral padding_pixels)) + (Vertex2 (fromIntegral (actual_width_pixels + + padding_pixels)) + (fromIntegral (actual_height_pixels + + padding_pixels))) + currentRasterPosition $= (Vertex4 (fromIntegral padding_pixels) + (fromIntegral padding_pixels) + 0 1) + mapM_ drawLine $ reverse lines_to_print + blend $= save_blend + depthMask $= save_depth_mask + depthFunc $= save_depth_func + +drawLine :: (TextType,B.ByteString) -> IO () +drawLine (textType,str) = do (Vertex4 x y _ _) <- get currentRasterPosition + color $ textTypeToColor textType + currentRasterPosition $= (Vertex4 x y 0 1) + renderString font $ B.unpack str + currentRasterPosition $= (Vertex4 x (y + fromIntegral font_height_pixels) 0 1) + +restrictLines :: Int -> Int -> [(TextType,B.ByteString)] -> [(TextType,B.ByteString)] +restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines + where splitLongLines (_,l) | B.null l = [] + splitLongLines (textType,str) = (textType,B.take width str):(splitLongLines (textType,B.drop width str)) + +textTypeToColor :: TextType -> Color3 GLfloat +textTypeToColor UnexpectedEvent = Color3 1.0 0.5 0.0 +textTypeToColor Event = Color3 0.5 0.75 1.0 +textTypeToColor Input = Color3 0.5 1.0 0.5 +textTypeToColor Query = Color3 1.0 1.0 1.0 + diff --git a/src/PrintText.lhs b/src/PrintText.lhs deleted file mode 100644 --- a/src/PrintText.lhs +++ /dev/null @@ -1,137 +0,0 @@ -\section{PrintText} - -A \texttt{PrintTextObject} renders the text console at the bottom of the screen. - -\begin{code} -module PrintText - (newPrintTextObject, - printText, - PrintTextObject, - renderText, - PrintTextMode(..), - TextType(..), - getInputBuffer, - setInputBuffer, - setPrintTextMode, - clearOutputBuffer, - clearInputBuffer, - keyCallback) - where - -import Data.IORef -import Graphics.UI.GLUT as GLUT -import PrintTextData -import Control.Monad -\end{code} - -\begin{code} -data PrintTextData = PrintTextData { - text_output_buffer :: [(TextType,String)], - text_input_buffer :: String, - text_output_mode :: PrintTextMode } - -newtype PrintTextObject = PrintTextObject (IORef PrintTextData) - -font_width_pixels :: Int -font_width_pixels = 9 - -font_height_pixels :: Int -font_height_pixels = 15 - -padding_pixels :: Int -padding_pixels = 10 - -font :: BitmapFont -font = Fixed9By15 - -newPrintTextObject :: IO PrintTextObject -newPrintTextObject = liftM PrintTextObject $ newIORef $ PrintTextData { - text_output_buffer = [], - text_input_buffer = [], - text_output_mode = Unlimited } - -printText :: PrintTextObject -> TextType -> String -> IO () -printText (PrintTextObject pto) text_type str = - modifyIORef pto $ - \print_text -> print_text { text_output_buffer = text_output_buffer print_text ++ map (\l -> (text_type,l)) (lines str) } - -keyCallback :: PrintTextObject -> KeyboardMouseCallback -keyCallback _ _ Up _ _ = return () -keyCallback _ (MouseButton {}) _ _ _ = return () -keyCallback (PrintTextObject pto) (Char char) _ _ _ = modifyIORef pto $ - \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ [char] } -keyCallback (PrintTextObject pto) (SpecialKey special) _ _ _ = modifyIORef pto $ - \ptd -> ptd { text_input_buffer = text_input_buffer ptd ++ show special } - -getInputBuffer :: PrintTextObject -> IO String -getInputBuffer (PrintTextObject pto) = liftM text_input_buffer $ readIORef pto - -setInputBuffer :: PrintTextObject -> String -> IO () -setInputBuffer (PrintTextObject pto) new_input_buffer = modifyIORef pto $ - \print_text -> print_text { text_input_buffer = new_input_buffer } - -clearOutputBuffer :: PrintTextObject -> IO () -clearOutputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_output_buffer = [] } - -setPrintTextMode :: PrintTextObject -> PrintTextMode -> IO () -setPrintTextMode (PrintTextObject pto) pt_mode = - do modifyIORef pto $ \print_text -> print_text { text_output_mode = pt_mode } - -clearInputBuffer :: PrintTextObject -> IO () -clearInputBuffer (PrintTextObject pto) = modifyIORef pto $ \ptd -> ptd { text_input_buffer = [] } - -renderText :: PrintTextObject -> IO () -renderText (PrintTextObject pto) = - do ptd <- readIORef pto - (Size width height) <- get windowSize - save_depth_func <- get depthFunc - save_depth_mask <- get depthMask - save_blend <- get blend - depthFunc $= Nothing - depthMask $= GLUT.Disabled - blend $= Enabled - matrixMode $= Projection - loadIdentity - ortho2D 0 (fromIntegral width) 0 (fromIntegral height) - matrixMode $= Modelview 0 - loadIdentity - let max_characters_height = (fromIntegral height - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_height_pixels) - let max_characters_width = (fromIntegral width - 2 * fromIntegral padding_pixels) `div` (fromIntegral font_width_pixels) - let lines_to_print = restrictLines max_characters_height max_characters_width $ - (case (text_output_mode ptd) of - PrintTextData.Disabled -> [] - Limited -> reverse $ take 3 $ reverse $ text_output_buffer ptd - Unlimited -> (text_output_buffer ptd)) ++ - (if length (text_input_buffer ptd) > 0 || (text_output_mode ptd) /= PrintTextData.Disabled - then [(Query,"> " ++ (text_input_buffer ptd))] - else []) - actual_width_pixels = font_width_pixels * (maximum $ map (length . snd) lines_to_print) - actual_height_pixels = font_height_pixels * (length lines_to_print) - in do color $ (Color4 0 0 0 0.92 :: Color4 GLfloat) - (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()) - (Vertex2 (fromIntegral padding_pixels) (fromIntegral padding_pixels)) - (Vertex2 (fromIntegral (actual_width_pixels + padding_pixels)) (fromIntegral (actual_height_pixels + padding_pixels))) - currentRasterPosition $= (Vertex4 (fromIntegral padding_pixels) (fromIntegral padding_pixels) 0 1) - mapM_ drawLine $ reverse lines_to_print - blend $= save_blend - depthMask $= save_depth_mask - depthFunc $= save_depth_func - -drawLine :: (TextType,String) -> IO () -drawLine (textType,str) = do (Vertex4 x y _ _) <- get currentRasterPosition - color $ textTypeToColor textType - currentRasterPosition $= (Vertex4 x y 0 1) - renderString font str - currentRasterPosition $= (Vertex4 x (y + fromIntegral font_height_pixels) 0 1) - -restrictLines :: Int -> Int -> [(TextType,String)] -> [(TextType,String)] -restrictLines height width text_lines = reverse $ take height $ reverse $ concatMap splitLongLines text_lines - where splitLongLines (_,[]) = [] - splitLongLines (textType,str) = (textType,take width str):(splitLongLines (textType,drop width str)) - -textTypeToColor :: TextType -> Color3 GLfloat -textTypeToColor UnexpectedEvent = Color3 1.0 0.5 0.0 -textTypeToColor Event = Color3 0.5 0.75 1.0 -textTypeToColor Input = Color3 0.5 1.0 0.5 -textTypeToColor Query = Color3 1.0 1.0 1.0 -\end{code} diff --git a/src/PrintTextData.hs b/src/PrintTextData.hs new file mode 100644 --- /dev/null +++ b/src/PrintTextData.hs @@ -0,0 +1,19 @@ +module PrintTextData + (PrintTextMode(..), + TextType(..)) + where + +-- | How much of the screen should we use for text. +data PrintTextMode = Limited -- ^ print only a few lines + | Unlimited -- ^ fill the entire screen with text + | Disabled -- ^ don't print any text at all + deriving (Eq) + +-- | +-- Type of any line of text printed on the screen. We print the +-- different TextTypes in different colors for readability. +-- +data TextType = Event -- ^ message related to an event in the game + | UnexpectedEvent -- ^ message related to a software problem + | Input -- ^ something the user typed in + | Query -- ^ asking the user to type something diff --git a/src/PrintTextData.lhs b/src/PrintTextData.lhs deleted file mode 100644 --- a/src/PrintTextData.lhs +++ /dev/null @@ -1,30 +0,0 @@ -\section{PrintText Data Structures} - -\begin{code} -module PrintTextData - (PrintTextMode(..), - TextType(..)) - where -\end{code} -How to run printText. - -Limited -- print only the most recent lines at the top of the screen -Unlimited -- fill the entire screen with text -Disabled -- don't print any text at all - -\begin{code} -data PrintTextMode = Limited -- print only a few lines (or only 1) - | Unlimited -- fill the entire screen with text - | Disabled -- don't print any text at all - deriving (Eq) -\end{code} - -Type of any line of text printed on the screen. We print the -different TextTypes in different colors for readability. - -\begin{code} -data TextType = Event -- message related to an even in the game - | UnexpectedEvent -- - | Input -- something the user typed in - | Query -\end{code} diff --git a/src/ProtocolTypes.hs b/src/ProtocolTypes.hs new file mode 100644 --- /dev/null +++ b/src/ProtocolTypes.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | ADTs corresponding to certain data tables incomming from roguestar-engine. +module ProtocolTypes + (ProtocolType(..), + TerrainTile(..), + VisibleObject(..), + WieldedObject(..), + tableSelectTyped) + where + +import Data.Maybe +import Tables +import RSAGL.Math.Angle +import Debug.Trace +import qualified Data.ByteString.Char8 as B + +-- | 'ProtocolType' is any type that can be constructed from a row of a 'RoguestarTable'. +-- 'formatTable' is a function from bottom to the expected format of the table row. +class ProtocolType t where + fromTable :: [TableDataFormat B.ByteString Integer] -> Maybe t + formatTable :: t -> [TableDataFormat B.ByteString B.ByteString] + +data TerrainTile = TerrainTile { + tt_type :: B.ByteString, + tt_xy :: (Integer,Integer) } + deriving (Eq,Show) + +instance ProtocolType TerrainTile where + formatTable = const [TDString "terrain-type",TDNumber "x",TDNumber "y"] + fromTable [TDString t,TDNumber x,TDNumber y] = Just $ TerrainTile t (x,y) + fromTable _ = Nothing + +data VisibleObject = VisibleObject { + vo_unique_id :: Integer, + vo_xy :: (Integer,Integer), + vo_facing :: BoundAngle } + +instance ProtocolType VisibleObject where + formatTable = const $ [TDNumber "object-unique-id",TDNumber "x",TDNumber "y",TDString "facing"] + fromTable [TDNumber unique_id,TDNumber x,TDNumber y,TDString facing] = Just $ + VisibleObject unique_id (x,y) (facingToAngle facing) + fromTable _ = Nothing + +data WieldedObject = WieldedObject { + wo_unique_id :: Integer, + wo_creature_id :: Integer } + +instance ProtocolType WieldedObject where + formatTable = const $ [TDNumber "uid",TDNumber "creature"] + fromTable [TDNumber unique_id,TDNumber creature_id] = Just $ + WieldedObject unique_id creature_id + fromTable _ = Nothing + +facingToAngle :: B.ByteString -> BoundAngle +facingToAngle "south" = BoundAngle $ fromDegrees 0 +facingToAngle "southeast" = BoundAngle $ fromDegrees 45 +facingToAngle "east" = BoundAngle $ fromDegrees 90 +facingToAngle "northeast" = BoundAngle $ fromDegrees 135 +facingToAngle "north" = BoundAngle $ fromDegrees 180 +facingToAngle "northwest" = BoundAngle $ fromDegrees 225 +facingToAngle "west" = BoundAngle $ fromDegrees 270 +facingToAngle "southwest" = BoundAngle $ fromDegrees 315 +facingToAngle "here" = BoundAngle $ fromDegrees 0 +facingToAngle s = trace ("facingToAngle: what is " ++ B.unpack s ++ "?") $ BoundAngle $ fromDegrees 180 + +tableSelectTyped :: (ProtocolType t) => RoguestarTable -> [t] +tableSelectTyped the_table = result + where result = mapMaybe fromTable $ tableSelectFormatted the_table the_format + the_format = formatTable $ (error "tableSelectTyped: undefined" :: (a -> a)) (head result) + diff --git a/src/ProtocolTypes.lhs b/src/ProtocolTypes.lhs deleted file mode 100644 --- a/src/ProtocolTypes.lhs +++ /dev/null @@ -1,72 +0,0 @@ -\section{Protocol Types} - -\begin{code} -module ProtocolTypes - (ProtocolType(..), - TerrainTile(..), - VisibleObject(..), - WieldedObject(..), - tableSelectTyped) - where - -import Data.Maybe -import Tables -import RSAGL.Angle -import Debug.Trace -\end{code} - -\texttt{ProtocolType} is any type that can be constructed from a row of a \texttt{RoguestarTable}. -\texttt{formatTable} is a function from bottom to the expected format of the table row. - -\begin{code} -class ProtocolType t where - fromTable :: [TableDataFormat String Integer] -> Maybe t - formatTable :: t -> [TableDataFormat String String] - -data TerrainTile = TerrainTile { - tt_type :: String, - tt_xy :: (Integer,Integer) } - -instance ProtocolType TerrainTile where - formatTable = const [TDString "terrain-type",TDNumber "x",TDNumber "y"] - fromTable [TDString t,TDNumber x,TDNumber y] = Just $ TerrainTile t (x,y) - fromTable _ = Nothing - -data VisibleObject = VisibleObject { - vo_unique_id :: Integer, - vo_xy :: (Integer,Integer), - vo_facing :: BoundAngle } - -instance ProtocolType VisibleObject where - formatTable = const $ [TDNumber "object-unique-id",TDNumber "x",TDNumber "y",TDString "facing"] - fromTable [TDNumber unique_id,TDNumber x,TDNumber y,TDString facing] = Just $ - VisibleObject unique_id (x,y) (facingToAngle facing) - fromTable _ = Nothing - -data WieldedObject = WieldedObject { - wo_unique_id :: Integer, - wo_creature_id :: Integer } - -instance ProtocolType WieldedObject where - formatTable = const $ [TDNumber "uid",TDNumber "creature"] - fromTable [TDNumber unique_id,TDNumber creature_id] = Just $ - WieldedObject unique_id creature_id - fromTable _ = Nothing - -facingToAngle :: String -> BoundAngle -facingToAngle "south" = BoundAngle $ fromDegrees 0 -facingToAngle "southeast" = BoundAngle $ fromDegrees 45 -facingToAngle "east" = BoundAngle $ fromDegrees 90 -facingToAngle "northeast" = BoundAngle $ fromDegrees 135 -facingToAngle "north" = BoundAngle $ fromDegrees 180 -facingToAngle "northwest" = BoundAngle $ fromDegrees 225 -facingToAngle "west" = BoundAngle $ fromDegrees 270 -facingToAngle "southwest" = BoundAngle $ fromDegrees 315 -facingToAngle "here" = BoundAngle $ fromDegrees 0 -facingToAngle s = trace ("facingToAngle: what is " ++ s ++ "?") $ BoundAngle $ fromDegrees 180 - -tableSelectTyped :: (ProtocolType t) => RoguestarTable -> [t] -tableSelectTyped the_table = result - where result = mapMaybe fromTable $ tableSelectFormatted the_table the_format - the_format = formatTable $ (error "tableSelectTyped: undefined" :: (a -> a)) (head result) -\end{code} diff --git a/src/Quality.hs b/src/Quality.hs --- a/src/Quality.hs +++ b/src/Quality.hs @@ -1,9 +1,12 @@ module Quality (Quality(..), - qualityToVertices) + qualityToVertices, + qualityToFixed, + minorFixedQuality) where +import RSAGL.Modeling data Quality = Bad | Poor @@ -12,8 +15,23 @@ deriving (Eq,Enum,Ord,Show) qualityToVertices :: Quality -> Integer -qualityToVertices Bad = 2^5 -qualityToVertices Poor = 2^9 -qualityToVertices Good = 2^13 -qualityToVertices Super = 2^17 +qualityToVertices Bad = 2^6 +qualityToVertices Poor = 2^8 +qualityToVertices Good = 2^10 +qualityToVertices Super = 2^12 +-- | Sets the fixed quality of of modeled surface using 'RSAGL.Model.fixed'. +-- Good for pieces that need to mesh together but don't for some reason. +qualityToFixed :: Quality -> ModelingM attr () +qualityToFixed Bad = fixed (2^2,2^2) +qualityToFixed Poor = fixed (2^3,2^3) +qualityToFixed Good = fixed (2^4,2^4) +qualityToFixed Super = fixed (2^5,2^5) + +-- | Sets the fixed quality of of modeled surface using 'RSAGL.Model.fixed'. +-- The quality here is very low. +minorFixedQuality :: Quality -> ModelingM attr () +minorFixedQuality Bad = fixed (2^1,2^1) +minorFixedQuality Poor = fixed (2^1,2^1) +minorFixedQuality Good = fixed (2^2,2^2) +minorFixedQuality Super = fixed (2^3,2^3) diff --git a/src/RenderingControl.hs b/src/RenderingControl.hs new file mode 100644 --- /dev/null +++ b/src/RenderingControl.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-} + +module RenderingControl + (mainAnimationLoop) + where + +import Globals +import RSAGL.FRP +import RSAGL.Math +import RSAGL.Modeling +import Animation +import Control.Arrow +import Data.Maybe +import PrintText +import Tables +import VisibleObject +import RSAGL.Animation +import qualified Data.Map as Map +import Sky +import Scene +import Data.Monoid +import AnimationTerrain +import AnimationCreatures +import AnimationBuildings +import AnimationTools +import AnimationMenus +import AnimationExtras +import AnimationEvents +import Strings +import RSAGL.Types +import qualified Data.ByteString.Char8 as B + +-- | Enters the top-level animation loop. +mainAnimationLoop :: FRP e (FRP1 AnimationState () SceneLayerInfo) () SceneLayerInfo +mainAnimationLoop = proc () -> + do m_state <- driverGetAnswerA -< "state" + switchContinue -< (fmap (const $ mainWelcome >>> mainDispatch) m_state,()) + printTextOnce -< Just (UnexpectedEvent,"Waiting for engine...") + returnA -< roguestarSceneLayerInfo mempty basic_camera + where mainWelcome = proc () -> + do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.") + returnA -< () + +-- | This is the actual to-level animation loop. +mainDispatch :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo +mainDispatch = proc () -> + do result <- frp1Context (mainStateHeader (const False) >>> arr (const $ roguestarSceneLayerInfo mempty basic_camera)) -< () + monitorPlanetName -< () + monitorCompassReading -< () + returnA -< result + +-- | Forces the current RSAnim thread to switch whenever the current state does not match the specified predicate. +-- Any switch that wants to surrender control whenever the state changes should call this first. +mainStateHeader :: (FRPModel m) => (B.ByteString -> Bool) -> FRP e (RSwitch Disabled () () SceneLayerInfo m) () () +mainStateHeader = genericStateHeader switchTo + where switchTo blanking_state | blanking_state `elem` blanking_states = blankingDispatch blanking_state + switchTo menu_state | menu_state `elem` menu_states = menuManager + switchTo planar_state | planar_state `elem` planar_states = planarGameplayDispatch + switchTo "game-over" = gameOver + switchTo unknown_state = error $ "mainStateHeader: unrecognized state: " ++ B.unpack unknown_state + +-- | Displays all menus with a black background. +menuManager :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo +menuManager = proc () -> + do mainStateHeader (`elem` menu_states) -< () + frp1Context menuDispatch -< () + +-- | Print a "Welcome to P-XXXX" message whenever we arrive on a new planet. +monitorPlanetName :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () () +monitorPlanetName = proc () -> + do m_planet_name <- driverGetAnswerA -< "planet-name" + p <- changed (==) <<< sticky isJust Nothing -< m_planet_name + printTextA -< case m_planet_name of + _ | not p -> Nothing + Nothing -> Nothing + Just "nothing" -> Nothing + Just somewhere -> Just (Event, B.concat $ ["Welcome to ", capitalize somewhere, "."]) + returnA -< () + +-- | Print a compass heading message whenever it changes. +monitorCompassReading :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () () +monitorCompassReading = proc () -> + do m_compass <- driverGetAnswerA -< "compass" + p <- changed (==) <<< sticky isJust Nothing -< m_compass + printTextA -< case m_compass of + _ | not p -> Nothing + Nothing -> Nothing + Just "nothing" -> Nothing + Just "here" -> Nothing + Just compass -> Just (Event, B.concat $ ["Compass reading: ", hrstring compass, "."]) + returnA -< () + + +-- | Print the game over message and retain control of the rendering loop forever. +gameOver :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo +gameOver = proc () -> + do printTextOnce -< Just (Event,"Game Over") + returnA -< roguestarSceneLayerInfo mempty basic_camera + +-- | List of all states that require the display of the planar environment (terrain, characters, tools, and sky) +planar_states :: [B.ByteString] +planar_states = ["player-turn","move","turn","jump","attack","fire","clear-terrain"] ++ recognized_events + +-- | Captures all planar visuals: terrain, characters, tools, and sky. +planarGameplayDispatch :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo +planarGameplayDispatch = proc () -> + do -- setup/get infos + mainStateHeader (`elem` planar_states) -< () + clearPrintTextOnce -< () + frp1Context eventMessager -< () + -- terrain threads + frpContext (allowAnonymous forbidDuplicates) [(Nothing,terrainThreadLauncher)] -< () + -- building threads + frpContext (allowAnonymous forbidDuplicates) [(Nothing,visibleObjectThreadLauncher buildingAvatar)] -< () + -- creature threads + ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<< + frpContext (allowAnonymous forbidDuplicates) + [(Nothing,visibleObjectThreadLauncher creatureAvatar)] -< () + -- tool threads + frpContext (allowAnonymous forbidDuplicates) [(Nothing,visibleObjectThreadLauncher toolAvatar)] -< + ToolThreadInput { + tti_wield_points = Map.fromList $ map (\(uid,cto) -> (uid,cto_wield_point cto)) ctos } + -- camera/lighting stuff, including sky sphere + sky_info <- getSkyInfo -< () + sky -< sky_info + m_lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<< + arr (fmap (\(x,y) -> Point3D (realToFrac x) 0.25 (negate $ realToFrac y))) <<< centerCoordinates -< () + camera_distance <- approachA 5.0 (perSecond 5.0) <<< readGlobal global_planar_camera_distance -< () + let (planar_camera,lookat) = maybe (basic_camera,origin_point_3d) (\x -> (planarCamera camera_distance x,x)) m_lookat + artificial_light_intensity <- arr lighting_artificial <<< lightingConfiguration -< sky_info + sky_on <- readGlobal global_sky_on -< () + accumulateSceneA -< (scene_layer_local, lightSource $ case () of + () | artificial_light_intensity > 0.05 && sky_on -> + mapLightSource (mapBoth $ scaleRGB artificial_light_intensity) $ PointLight { + lightsource_position = camera_position planar_camera, + lightsource_radius = measure (camera_position planar_camera) lookat, + lightsource_color = gray 0.8, + lightsource_ambient = gray 0.2 } + () | artificial_light_intensity > 0.05 -> PointLight { + lightsource_position = camera_position planar_camera, + lightsource_radius = measure (camera_position planar_camera) lookat, + lightsource_color = gray 0.5, + lightsource_ambient = gray 0.5 } + () | otherwise -> NoLight) + returnA -< roguestarSceneLayerInfo (skyAbsorbtionFilter sky_info) planar_camera + +-- | Sets up a Camera, based on a camera distance parameter (probably tied to the global_planar_camera_distance variable) +-- and the look-at point. +planarCamera :: RSdouble -> Point3D -> Camera +planarCamera camera_distance look_at = PerspectiveCamera { + camera_position = translate (vectorScaleTo camera_distance $ Vector3D 0 (7*(camera_distance/10)**2) camera_distance) look_at, + camera_lookat = translate (Vector3D 0 (1/camera_distance) 0) look_at, + camera_up = Vector3D 0 1 0, + camera_fov = fromDegrees $ 40 + 30 / camera_distance } + +-- | Retrieve the look-at point from the engine. +centerCoordinates :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () (Maybe (Integer,Integer)) +centerCoordinates = proc () -> + do m_center_coordinates_table <- sticky isJust Nothing <<< driverGetTableA -< ("center-coordinates","0") + returnA -< do center_coordinates_table <- m_center_coordinates_table + x <- tableLookupInteger center_coordinates_table ("axis","coordinate") "x" -- Maybe monad + y <- tableLookupInteger center_coordinates_table ("axis","coordinate") "y" + return (x,y) + +-- | A list of the states that require the screen to be blanked (made black), interrupting the planar visuals. +blanking_states :: [B.ByteString] +blanking_states = ["teleport-event"] + +-- | Display the blanked screen and print any blanking events. +blankingDispatch :: (FRPModel m) => B.ByteString -> FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo +blankingDispatch "teleport-event" = proc () -> + do mainStateHeader (`elem` blanking_states) -< () + clearPrintTextOnce -< () + printTextOnce -< Just (Event,"Whoosh!") + blockContinue <<< arr ((< 0.5) . toSeconds) <<< threadTime -< () + returnA -< roguestarSceneLayerInfo mempty basic_camera +blankingDispatch blanking_state = proc () -> + do debugOnce -< Just $ "blankingDispatch: unrecognized blanking_state `" `B.append` blanking_state `B.append` "`" + returnA -< roguestarSceneLayerInfo mempty basic_camera + diff --git a/src/RenderingControl.lhs b/src/RenderingControl.lhs deleted file mode 100644 --- a/src/RenderingControl.lhs +++ /dev/null @@ -1,434 +0,0 @@ -\section{The Top-Level Animation Loop} - -\begin{code} -{-# LANGUAGE Arrows #-} - -module RenderingControl - (mainAnimationLoop) - where - -import Data.List -import RSAGL.FRP -import RSAGL.Edge -import RSAGL.Scene -import RSAGL.Vector -import Animation -import RSAGL.Angle -import Control.Arrow -import Data.Maybe -import PrintText -import Tables -import Models.LibraryData -import RSAGL.CoordinateSystems -import RSAGL.Affine -import RSAGL.ModelingExtras -import RSAGL.Interpolation -import ProtocolTypes -import RSAGL.Time -import RSAGL.AbstractVector -import VisibleObject -import RSAGL.InverseKinematics -import RSAGL.AnimationExtras -import Actions -import Strings -import Control.Applicative -import qualified Data.Map as Map -import Limbs -import RSAGL.Joint -import RSAGL.AbstractVector -\end{code} - -\begin{code} -mainAnimationLoop :: RSAnimA1 () Camera () Camera -mainAnimationLoop = proc () -> - do m_state <- driverGetAnswerA -< "state" - switchContinue -< (fmap (const $ mainWelcome >>> mainDispatch) m_state,()) - printTextOnce -< Just (UnexpectedEvent,"Waiting for engine...") - returnA -< basic_camera - where mainWelcome = proc () -> - do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.") - returnA -< () - -basic_camera :: Camera -basic_camera = PerspectiveCamera { - camera_position = Point3D 0 0 0, - camera_lookat = Point3D 0 0 1, - camera_up = Vector3D 0 1 0, - camera_fov = fromDegrees 60 } -\end{code} - -\subsection{The Main Dispatch} - -\texttt{mainDispatch} transfers control of the main thread to a -subprogram based on the state of the engine. For example, menu-related -states dispatch to \texttt{menuDispatch} which manages the menu gui. - -\texttt{mainHeader} guards against changes in the engine state. -Whenever the state changes, the header switches to \texttt{mainDispatch}. - -\begin{code} -mainStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () () -mainStateHeader = genericStateHeader switchTo - where switchTo menu_state | menu_state `elem` menu_states = menuManager - switchTo planar_state | planar_state `elem` planar_states = planarGameplayDispatch - switchTo "game-over" = gameOver - switchTo unknown_state = error $ "mainStateHeader: unrecognized state: " ++ unknown_state - -genericStateHeader :: (String -> RSAnimA1 i o i o) -> (String -> Bool) -> RSAnimA1 i o i () -genericStateHeader switchTo f = proc i -> - do m_state <- driverGetAnswerA -< "state" - switchContinue -< (if fmap f m_state == Just True then Nothing else fmap switchTo m_state,i) - returnA -< () - -mainDispatch :: RSAnimA1 () Camera () Camera -mainDispatch = mainStateHeader (const False) >>> arr (const basic_camera) -\end{code} - -\subsection{The Menu Dispatch} - -\begin{code} -menu_states :: [String] -menu_states = ["race-selection", - "class-selection"] -menuManager :: RSAnimA1 () Camera () Camera -menuManager = proc () -> - do mainStateHeader (`elem` menu_states) -< () - frp1Context menuDispatch -< () - -menuStateHeader :: (String -> Bool) -> RSAnimA1 () Camera () Camera -menuStateHeader f = genericStateHeader switchTo f >>> arr (const basic_camera) - where switchTo "race-selection" = menuRaceSelection - switchTo "class-selection" = menuClassSelection - switchTo unknown_state = error $ "menuStateHeader: unrecognized state: " ++ unknown_state - -menuDispatch :: RSAnimA1 () Camera () Camera -menuDispatch = menuStateHeader (const False) >>> arr (const basic_camera) - -menuRaceSelection :: RSAnimA1 () Camera () Camera -menuRaceSelection = proc s -> - do menuStateHeader (== "race-selection") -< s - requestPrintTextMode -< Unlimited - clearPrintTextA -< () - printMenuA select_race_action_names -< () - printTextA -< Just (Query,"Select a Race:") - returnA -< basic_camera - -menuClassSelection :: RSAnimA1 () Camera () Camera -menuClassSelection = proc () -> - do menuStateHeader (== "class-selection") -< () - changed <- edgep <<< sticky isJust Nothing << RSAnimAX any t i o () () -printCharacterStats unique_id = proc () -> - do m_player_stats <- driverGetTableA -< ("player-stats",show unique_id) - print1CharacterStat -< (m_player_stats,"str") - print1CharacterStat -< (m_player_stats,"dex") - print1CharacterStat -< (m_player_stats,"con") - print1CharacterStat -< (m_player_stats,"int") - print1CharacterStat -< (m_player_stats,"per") - print1CharacterStat -< (m_player_stats,"cha") - print1CharacterStat -< (m_player_stats,"mind") - -print1CharacterStat :: RSAnimAX any t i o (Maybe RoguestarTable,String) () -print1CharacterStat = proc (m_player_stats,stat_str) -> - do let m_stat_int = (\x -> tableLookupInteger x ("property","value") stat_str) =<< m_player_stats - printTextA -< fmap (\x -> (Event,hrstring stat_str ++ ": " ++ show x)) m_stat_int -\end{code} - -\subsection{The Game Over State} - -\begin{code} -gameOver :: RSAnimA1 () Camera () Camera -gameOver = proc () -> - do printTextOnce -< Just (Event,"You have been killed.") - returnA -< basic_camera -\end{code} - -\subsection{The Planar Gameplay Dispatch} - -\begin{code} -planar_states :: [String] -planar_states = ["player-turn","pickup","drop","wield","attack","miss","killed"] - -planarGameplayDispatch :: RSAnimA1 () Camera () Camera -planarGameplayDispatch = proc () -> - do mainStateHeader (`elem` planar_states) -< () - clearPrintTextOnce -< () - frp1Context eventMessager -< () - frpContext (maybeThreadIdentity terrainTileThreadIdentity) [(Nothing,terrainThreadLauncher)] -< () - ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<< - frpContext (maybeThreadIdentity $ unionThreadIdentity (==)) - [(Nothing,visibleObjectThreadLauncher creatureAvatar)] -< () - frpContext (maybeThreadIdentity $ unionThreadIdentity (==)) [(Nothing,visibleObjectThreadLauncher toolAvatar)] -< - ToolThreadInput { - tti_wield_points = Map.fromList $ map (\(uid,cto) -> (uid,cto_wield_point cto)) ctos } - lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<< - arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< centerCoordinates -< () - accumulateSceneA -< (Infinite,lightSource $ DirectionalLight (Vector3D 0.15 1 (-0.3)) (scaleRGB 0.4 $ rgb 1.0 0.9 0.75) (scaleRGB 0.2 $ rgb 0.75 0.9 1.0)) - returnA -< maybe basic_camera cameraLookAtToCamera lookat - -cameraLookAtToCamera :: Point3D -> Camera -cameraLookAtToCamera look_at = PerspectiveCamera { - camera_position = translate (Vector3D 0 3 3) look_at, - camera_lookat = look_at, - camera_up = Vector3D 0 1 0, - camera_fov = fromDegrees 60 } - -centerCoordinates :: RSAnimAX any t i o () (Maybe (Integer,Integer)) -centerCoordinates = proc () -> - do m_center_coordinates_table <- sticky isJust Nothing <<< driverGetTableA -< ("center-coordinates","0") - returnA -< do center_coordinates_table <- m_center_coordinates_table - x <- tableLookupInteger center_coordinates_table ("axis","coordinate") "x" -- Maybe monad - y <- tableLookupInteger center_coordinates_table ("axis","coordinate") "y" - return (x,y) -\end{code} - -\subsection{Terrain} - -\begin{code} -terrainThreadLauncher :: RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () () -terrainThreadLauncher = spawnThreads <<< arr (map (\x -> (Just x,terrainTile x))) <<< terrainElements - -terrainTile :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () () -terrainTile terrain_tile = proc () -> - do t <- threadTime -< () - still_here <- renderTerrainTile terrain_tile -< fromSeconds $ min 0 $ toSeconds t - 1 - switchTerminate -< (if still_here then Nothing else Just $ terrainTile_Descending terrain_tile,()) - -terrainTile_Descending :: ProtocolTypes.TerrainTile -> RSAnimA (Maybe ProtocolTypes.TerrainTile) () () () () -terrainTile_Descending terrain_tile = proc () -> - do t <- threadTime -< () - killThreadIf -< t >= fromSeconds 1 - renderTerrainTile terrain_tile -< t - returnA -< () - -renderTerrainTile :: ProtocolTypes.TerrainTile -> RSAnimA t i o Time Bool -renderTerrainTile (ProtocolTypes.TerrainTile terrain_type (x,y)) = proc t -> - do let awayness = max 0 $ min 0.99 $ (toSeconds t)^2 - terrain_elements <- terrainElements -< () - transformA libraryA -< (Affine $ translate (Vector3D (realToFrac x) 0 (negate $ realToFrac y)) . scale' (1 - awayness), - (Local,Models.LibraryData.TerrainTile terrain_type)) - returnA -< isJust $ find (\a -> tt_xy a == (x,y)) terrain_elements - -terrainElements :: RSAnimA t i o () [ProtocolTypes.TerrainTile] -terrainElements = arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA <<< arr (const ("visible-terrain","0")) - -terrainTileThreadIdentity :: ThreadIdentity ProtocolTypes.TerrainTile -terrainTileThreadIdentity = unionThreadIdentity (\a b -> tt_xy a == tt_xy b) -\end{code} - -\subsection{Creatures and Objects} - -\begin{code} -data CreatureThreadOutput = CreatureThreadOutput { - cto_wield_point :: CoordinateSystem } - -class AbstractEmpty a where - abstractEmpty :: a - -instance AbstractEmpty () where - abstractEmpty = () - -instance AbstractEmpty (Maybe a) where - abstractEmpty = Nothing - -visibleObjectThreadLauncher :: (AbstractEmpty o) => RSAnimA (Maybe Integer) i o i o -> RSAnimA (Maybe Integer) i o i o -visibleObjectThreadLauncher avatarA = arr (const abstractEmpty) <<< spawnThreads <<< arr (map (\x -> (Just x,avatarA))) <<< allObjects <<< arr (const ()) - -objectTypeGuard :: (String -> Bool) -> RSAnimA (Maybe Integer) a b () () -objectTypeGuard f = proc () -> - do m_obj_type <- objectDetailsLookup "object-type" -< () - killThreadIf -< maybe False (not . f) m_obj_type - -creatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -creatureAvatar = proc () -> - do objectTypeGuard (== "creature") -< () - m_species <- objectDetailsLookup "species" -< () - switchContinue -< (fmap switchTo m_species,()) - returnA -< Nothing - where switchTo "encephalon" = encephalonAvatar - switchTo "recreant" = recreantAvatar - switchTo "androsynth" = androsynthAvatar - switchTo "ascendant" = ascendantAvatar - switchTo "caduceator" = caduceatorAvatar - switchTo "reptilian" = reptilianAvatar - switchTo _ = questionMarkAvatar - -genericCreatureAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () CreatureThreadOutput -> - RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -genericCreatureAvatar creatureA = proc () -> - do visibleObjectHeader -< () - m_orientation <- objectIdealOrientation -< () - switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar creatureA,Nothing) else (Nothing,Nothing) - arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_orientation,()) - -encephalonAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -encephalonAvatar = genericCreatureAvatar $ proc () -> - do libraryA -< (Local,Encephalon) - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< - bothArms MachineArmUpper MachineArmLower (Vector3D 0.66 0.66 0) (Point3D 0.145 0.145 0) 0.33 (Point3D 0.35 0.066 0.133) -< () - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -recreantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -recreantAvatar = genericCreatureAvatar $ floatBobbing 0.25 0.4 $ proc () -> - do libraryA -< (Local,Recreant) - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< - bothArms MachineArmUpper MachineArmLower (Vector3D 0 (-1.0) 0) (Point3D 0.3 0.075 0) 0.5 (Point3D 0.5 0.075 0.2) -< () - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -androsynthAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -androsynthAvatar = genericCreatureAvatar $ proc () -> - do libraryA -< (Local,Androsynth) - bothLegs ThinLimb ThinLimb (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.7 (Point3D 0.07 0 0.0) -< () - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< - bothArms ThinLimb ThinLimb (Vector3D (1.0) (-1.0) (-1.0)) (Point3D 0.05 0.65 0.0) 0.45 (Point3D 0.15 0.34 0.1) -< () - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -glower :: Point3D -> Vector3D -> RSAnimA (Maybe Integer) i o () () -glower p_init v_init = proc () -> - do local_origin <- exportToA root_coordinate_system -< origin_point_3d - transformA - (accelerationModel fps120 (p_init,perSecond $ v_init) - (proc () -> - do a <- derivative <<< derivative <<< exportToA root_coordinate_system -< origin_point_3d - returnA -< concatForces [quadraticTrap 10 p_init, - drag 1.0, - \_ _ _ -> scalarMultiply (-1) a, - \_ _ _ -> perSecond $ perSecond v_init, - \_ p _ -> perSecond $ perSecond $ vectorNormalize $ - vectorToFrom origin_point_3d p `crossProduct` v_init]) - (proc (_,()) -> libraryPointAtCamera -< (Local,AscendantGlow))) -< - (translateToFrom local_origin origin_point_3d $ root_coordinate_system,()) - -ascendantAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -ascendantAvatar = genericCreatureAvatar $ proc () -> - do glower (Point3D 0 0.5 0) zero -< () - glower (Point3D 0 0.5 0.35) (Vector3D 0 0 (-1)) -< () - glower (Point3D 0 0.5 (-0.35)) (Vector3D 0 0 1) -< () - glower (Point3D 0.35 0.5 0) (Vector3D (-1) 0 0) -< () - glower (Point3D (-0.35) 0.5 0) (Vector3D 1 0 0) -< () - accumulateSceneA -< (Local, - lightSource $ PointLight (Point3D 0 0.5 0) - (measure (Point3D 0 0.5 0) (Point3D 0 0 0)) - azure - azure) - t <- threadTime -< () - wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.5 0) - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -caduceatorAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -caduceatorAvatar = genericCreatureAvatar $ proc () -> - do libraryA -< (Local,Caduceator) - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< - bothArms CaduceatorArmUpper CaduceatorArmLower (Vector3D 1.0 (-1.0) 1.0) (Point3D 0.1 0.15 0.257) 0.34 (Point3D 0.02 0.17 0.4) -< () - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -reptilianAvatar :: RSAnimA (Maybe Integer) () (Maybe CreatureThreadOutput) () (Maybe CreatureThreadOutput) -reptilianAvatar = genericCreatureAvatar $ proc () -> - do libraryA -< (Local,Reptilian) - bothLegs ReptilianLegUpper ReptilianLegLower (Vector3D 0 0 1) (Point3D (0.05) 0.25 (-0.1)) 0.29 (Point3D 0.07 0 0.0) -< () - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< - bothArms ReptilianArmUpper ReptilianArmLower (Vector3D 1.0 0.0 1.0) (Point3D (0.05) 0.35 (-0.1)) 0.25 (Point3D 0.07 0.25 0.12) -< () - returnA -< CreatureThreadOutput { - cto_wield_point = wield_point } - -toolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput () -toolAvatar = proc tti -> - do objectTypeGuard (== "tool") -< () - m_tool <- objectDetailsLookup "tool" -< () - switchContinue -< (fmap switchTo m_tool,tti) - returnA -< () - where switchTo "phase_pistol" = phasePistolAvatar - switchTo _ = questionMarkAvatar >>> arr (const ()) - -phasePistolAvatar :: RSAnimA (Maybe Integer) ToolThreadInput () ToolThreadInput () -phasePistolAvatar = proc tti -> - do visibleObjectHeader -< () - m_orientation <- wieldableObjectIdealOrientation -< tti - transformA libraryA -< maybe (root_coordinate_system,(Local,NullModel)) - (\o -> (o,(Local,PhasePistol))) - m_orientation - -floatBobbing :: Double -> Double -> RSAnimAX any t i o j p -> RSAnimAX any t i o j p -floatBobbing ay by animationA = proc j -> - do t <- threadTime -< () - let float_y = lerpBetween (-1,sine $ fromRotations $ t `cyclical'` (fromSeconds 5),1) (ay,by) - transformA animationA -< (Affine $ translate (Vector3D 0 float_y 0),j) - -questionMarkAvatar :: RSAnimA (Maybe Integer) i o i (Maybe CreatureThreadOutput) -questionMarkAvatar = proc _ -> - do visibleObjectHeader -< () - t <- threadTime -< () - m_object_type <- objectDetailsLookup "object-type" -< () - m_species <- objectDetailsLookup "species" -< () - m_tool <- objectDetailsLookup "tool" -< () - debugOnce -< if any (isJust) [m_object_type,m_species,m_tool] - then (Just $ "questionMarkAvatar: apparently didn't recognize object: " ++ - show m_object_type ++ ", " ++ show m_species ++ ", " ++ show m_tool) - else Nothing - m_position <- objectIdealPosition -< () - let float_y = sine $ fromRotations $ t `cyclical'` (fromSeconds 5) - let m_transform = fmap (translate (Vector3D 0 (0.7 + float_y/10) 0)) m_position - transformA libraryA -< maybe (Affine id,(Local,NullModel)) (\p -> (Affine $ translateToFrom p origin_point_3d,(Local,QuestionMark))) m_transform - m_wield_point <- whenJust exportCoordinateSystem -< fmap (\p -> translate (vectorToFrom p origin_point_3d `add` Vector3D 0.4 0 0)) m_transform - returnA -< - do wield_point <- m_wield_point - return $ CreatureThreadOutput { - cto_wield_point = wield_point } -\end{code} - -\subsection{Messages} - -\begin{code} -eventStateHeader :: (String -> Bool) -> RSAnimA1 () () () () -eventStateHeader = genericStateHeader switchTo - where switchTo s = fromMaybe eventMessager $ lookup s messages - -eventMessager :: RSAnimA1 () () () () -eventMessager = proc () -> - do eventStateHeader (isNothing . flip lookup messages) -< () - blockContinue -< True - -messageState :: String -> RSAnimA1 () () () (Maybe String) -> (String,RSAnimA1 () () () ()) -messageState s actionA = (s,eventStateHeader (== s) >>> (proc () -> - do m_string <- actionA -< () - blockContinue -< isNothing m_string - printTextOnce -< fmap ((,) Event) m_string)) - -messages :: [(String,RSAnimA1 () () () ())] -messages = [ - messageState "attack" $ proc () -> - do m_weapon <- driverGetAnswerA -< "weapon-used" - returnA -< - do weapon <- m_weapon - return $ case () of - () | weapon == "0" -> "It attacks! It hits!" - () | otherwise -> "You attack! You hit!", - messageState "miss" $ proc () -> - do m_weapon <- driverGetAnswerA -< "weapon-used" - returnA -< - do weapon <- m_weapon - return $ case () of - () | weapon == "0" -> "It attacks! It misses." - () | otherwise -> "You attack! You miss.", - messageState "killed" $ proc () -> - do m_who_killed <- driverGetAnswerA -< "who-killed" - returnA -< - do who_killed <- m_who_killed - return $ case () of - () | who_killed == "2" -> "You are mortally wounded." - () | otherwise -> "You kill it!"] -\end{code} diff --git a/src/Statistics.hs b/src/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Statistics.hs @@ -0,0 +1,79 @@ +module Statistics + (Statistics,newStatistics,runStatistics) + where + +import qualified Data.Vector.Unboxed as V +import Statistics.Sample as S +import Data.List as L +import Statistics.Quantile +import Control.Concurrent +import RSAGL.FRP.Time +import System.IO +import System.IO.Unsafe +import RSAGL.Math.AbstractVector +import Control.Monad +import RSAGL.Types +import Text.Printf +import Control.Exception + +{-# NOINLINE error_pump #-} +error_pump :: Chan String +error_pump = unsafePerformIO $ + do pump <- newChan + _ <- forkIO $ forever $ + do hPutStrLn stderr =<< readChan pump + return pump + +data Statistics = Statistics { + statistics_sample :: MVar [Double], + statistics_max :: MVar Double, + statistics_avg :: MVar Double, + statistics_time :: MVar Time, -- time since last flushing of statistics + statistics_name :: String } + +newStatistics :: String -> IO Statistics +newStatistics name = + do sample <- newMVar [] + t <- newMVar =<< getTime + s_max <- newMVar 0 + s_avg <- newMVar 1000 + return $ Statistics { + statistics_sample = sample, + statistics_max = s_max, + statistics_avg = s_avg, + statistics_time = t, + statistics_name = name } + +runStatistics :: Statistics -> IO a -> IO a +runStatistics stats action = + do t_start <- getTime + a <- action + t_end <- getTime + let t_diff = f2f $ toSeconds $ t_end `sub` t_start + modifyMVar_ (statistics_sample stats) $ return . (t_diff :) + modifyMVar_ (statistics_max stats) $ return . (max t_diff) + modifyMVar_ (statistics_avg stats) $ return . (\t -> (99*t + t_diff)/100) + _ <- evaluate =<< readMVar (statistics_max stats) + _ <- evaluate =<< readMVar (statistics_avg stats) + modifyMVar_ (statistics_time stats) $ \t -> + do let should_report = (toSeconds (t_end `sub` t) > 30) + when should_report $ liftM (const ()) $ forkIO $ + do modifyMVar_ (statistics_sample stats) $ \x -> + do let sv = V.fromList $ take (60*30) x :: Sample + let f = printf "%.4f" . (*60) :: Double -> String + writeChan error_pump $ "\nSTATISTICS " ++ statistics_name stats ++ + "\nMEAN " ++ f (mean sv) ++ + "\nSTD DEV " ++ f (stdDev sv) ++ + "\nKURTOSIS " ++ f (kurtosis sv) ++ + "\nQUARTILES " ++ (concat $ intersperse " | " $ map f $ + [continuousBy medianUnbiased 0 4 sv, + continuousBy medianUnbiased 1 4 sv, + continuousBy medianUnbiased 2 4 sv, + continuousBy medianUnbiased 3 4 sv, + continuousBy medianUnbiased 4 4 sv]) + writeChan error_pump =<< liftM ((statistics_name stats ++ " lifetime maximum ") ++) (liftM f $ readMVar $ statistics_max stats) + writeChan error_pump =<< liftM ((statistics_name stats ++ " floating average ") ++) (liftM f $ readMVar $ statistics_avg stats) + return [] + return $ if should_report then t_end else t + return a + diff --git a/src/Strings.hs b/src/Strings.hs new file mode 100644 --- /dev/null +++ b/src/Strings.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module Strings + (replace,capitalize,hrstring) + where + +import Data.Char +import qualified Data.ByteString.Char8 as B + +-- | Replace all instances of the first string with the second string in the third string. +-- @replace "old" "new" "What's old?"@ +replace :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +replace a b s = case B.breakSubstring a s of + (x,y) | B.null y -> x + (x,y) | otherwise -> x `B.append` b `B.append` replace a b (B.drop (B.length a) y) + +-- | Just capitalize the first letter of the string. +capitalize :: B.ByteString -> B.ByteString +capitalize s = case B.uncons s of + Nothing -> s + Just (c,s') -> toUpper c `B.cons` s' + +-- | Human readable strings, when we can't just rip the plaintext from the protocol. +hrstring :: B.ByteString -> B.ByteString +hrstring "str" = "Strength " +hrstring "spd" = "Speed " +hrstring "con" = "Endurance " +hrstring "int" = "Intellect " +hrstring "per" = "Perception " +hrstring "cha" = "Charisma " +hrstring "mind" = "Mindfulness " +hrstring "maxhp" = "Health " +hrstring "forceadept" = "force adept" +hrstring x = B.map (\c -> if c == '_' then ' ' else c) x + + diff --git a/src/Strings.lhs b/src/Strings.lhs deleted file mode 100644 --- a/src/Strings.lhs +++ /dev/null @@ -1,21 +0,0 @@ -\section{Strings} - -This section merely contains a mapping from strings used in the protocol to human-readable strings. -For example, "str" becomes "strength." - -\begin{code} -module Strings - (hrstring) - where - -hrstring :: String -> String -hrstring "str" = "strength" -hrstring "dex" = "dexterity" -hrstring "con" = "constitution" -hrstring "int" = "intelligence" -hrstring "per" = "perception" -hrstring "cha" = "charisma" -hrstring "mind" = "mindfulness" -hrstring "forceadept" = "force adept" -hrstring x = x -\end{code} diff --git a/src/Tables.hs b/src/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Tables.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tables + (RoguestarTable(..), + TableDataFormat(..), + tableSelect, + tableSelectFormatted, + tableLookup, + tableLookupInteger, + readInteger) + where + +import Data.List +import RSAGL.FRP.Time +import qualified Data.ByteString.Char8 as B + +-- | 'RoguestarTable' is a crude implementation of a relational data table that is used to represent information that has been sent to us from roguestar-engine. +data RoguestarTable = RoguestarTable { table_created :: Time, table_name, table_id :: B.ByteString, table_header :: [B.ByteString], table_data :: [[B.ByteString]] } + deriving (Eq,Show) + +-- | 'tableSelect' selects rows from a table, like the SQL select statement. +-- For example: \texttt{tableSelect people ["name","sex","phone-number"] = [["bob","male","123-4567"],["susan","female","987-6543"]]} +-- If a given header is not in the table, it lists \texttt{"???"} as the value. +-- +-- There is a guarantee that all select functions will return results in the same order. +tableSelect :: RoguestarTable -> [B.ByteString] -> [[B.ByteString]] +tableSelect table headers = let header_indices = map (\x -> elemIndex x $ table_header table) headers + in map (rowSelect header_indices) $ table_data table + +rowSelect :: [Maybe Int] -> [B.ByteString] -> [B.ByteString] +rowSelect (Nothing:more) row = "???" : rowSelect more row +rowSelect (Just x:more) row = (row !! x) : rowSelect more row +rowSelect [] _ = [] + +-- | 'tableSelectFormatted' allows Selection of arbitrary strings and integers. +tableSelectFormatted :: RoguestarTable -> [TableDataFormat B.ByteString B.ByteString] -> [[TableDataFormat B.ByteString Integer]] +tableSelectFormatted table headers = map (toFormat headers) $ tableSelect table (map toString headers) + +-- | "tableLookup table \(\"name\",\"phone-number\"\) \"bob\"" yields Bob\'s phone number, or nothing if \"bob\" isn\'t in the table. +tableLookup :: RoguestarTable -> (B.ByteString,B.ByteString) -> B.ByteString -> Maybe B.ByteString +tableLookup table (k,v) x = fmap (!! 1) $ find ((== x) . head) $ tableSelect table [k,v] + +-- | 'tableLookupInteger' works as 'tableLookup', but answers an 'Integer' +tableLookupInteger :: RoguestarTable -> (B.ByteString,B.ByteString) -> B.ByteString -> Maybe Integer +tableLookupInteger table headers x = tableLookup table headers x >>= readInteger + +data TableDataFormat s n = TDString s + | TDNumber n + +readInteger :: B.ByteString -> Maybe Integer +readInteger = fmap fst . B.readInteger + +toString :: TableDataFormat B.ByteString B.ByteString -> B.ByteString +toString (TDString str) = str +toString (TDNumber str) = str + +toFormat :: [TableDataFormat a b] -> [B.ByteString] -> [TableDataFormat B.ByteString Integer] +toFormat headers row = zipWith toFormat_ headers row + where toFormat_ (TDString {}) str = TDString str + toFormat_ (TDNumber {}) str = maybe (TDString str) TDNumber $ readInteger str diff --git a/src/Tables.lhs b/src/Tables.lhs deleted file mode 100644 --- a/src/Tables.lhs +++ /dev/null @@ -1,81 +0,0 @@ -\section{Tables} - -\begin{code} -module Tables - (RoguestarTable(..), - TableDataFormat(..), - tableSelect, - tableSelectFormatted, - tableLookup, - tableLookupInteger) - where - -import Data.List -import Data.Maybe -import RSAGL.Time -import Control.Monad -\end{code} - -\texttt{RoguestarTable} is a crude implementation of a relational data table that is used to represent information that has been sent to us from roguestar-engine. - -\begin{code} -data RoguestarTable = RoguestarTable { table_created :: Time, table_name, table_id :: String, table_header :: [String], table_data :: [[String]] } - deriving (Eq,Show) -\end{code} - -\texttt{tableSelect} selects rows from a table, like the SQL select statement. -For example: \texttt{tableSelect people ["name","sex","phone-number"] = [["bob","male","123-4567"],["susan","female","987-6543"]]} -If a given header is not in the table, it lists \texttt{"???"} as the value. - -There is a guarantee that all select functions will return results in the same order. - -\begin{code} -tableSelect :: RoguestarTable -> [String] -> [[String]] -tableSelect table headers = let header_indices = map (\x -> elemIndex x $ table_header table) headers - in map (rowSelect header_indices) $ table_data table - -rowSelect :: [Maybe Int] -> [String] -> [String] -rowSelect (Nothing:more) row = "???" : rowSelect more row -rowSelect (Just x:more) row = (row !! x) : rowSelect more row -rowSelect [] _ = [] -\end{code} - -\texttt{tableSelectFormatted} allows Selection of arbitrary strings and integers. - -\begin{code} -tableSelectFormatted :: RoguestarTable -> [TableDataFormat String String] -> [[TableDataFormat String Integer]] -tableSelectFormatted table headers = map (toFormat headers) $ tableSelect table (map toString headers) -\end{code} - -\texttt{tableLookup table ("name","phone-number") "bob"} yields Bob's phone number, or nothing if "bob" isn't in the table. - -\begin{code} -tableLookup :: RoguestarTable -> (String,String) -> String -> Maybe String -tableLookup table (k,v) x = fmap (!! 1) $ find ((== x) . head) $ tableSelect table [k,v] -\end{code} - -\texttt{tableLookupInteger} works as \texttt{tableLookup}, but answers an \texttt{Integer}. - -\begin{code} -tableLookupInteger :: RoguestarTable -> (String,String) -> String -> Maybe Integer -tableLookupInteger table headers x = tableLookup table headers x >>= readInteger -\end{code} - -\subsection{Formatting Arbitrary Table Elements} - -\begin{code} -data TableDataFormat s n = TDString s - | TDNumber n - -readInteger :: String -> Maybe Integer -readInteger = listToMaybe . map fst . reads - -toString :: TableDataFormat String String -> String -toString (TDString str) = str -toString (TDNumber str) = str - -toFormat :: [TableDataFormat a b] -> [String] -> [TableDataFormat String Integer] -toFormat headers row = zipWith toFormat_ headers row - where toFormat_ (TDString {}) str = TDString str - toFormat_ (TDNumber {}) str = maybe (TDString str) TDNumber $ readInteger str -\end{code} diff --git a/src/VisibleObject.hs b/src/VisibleObject.hs new file mode 100644 --- /dev/null +++ b/src/VisibleObject.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE + Arrows, + OverloadedStrings, + Rank2Types, + TypeFamilies, + FlexibleContexts #-} + +module VisibleObject + (ToolThreadInput(..), + CreatureThreadOutput(..), + AbstractEmpty(..), + AvatarSwitch, + visibleObjectThreadLauncher, + objectTypeGuard, + questionMarkAvatar, + visibleObjects, + allObjects, + VisibleObjectReference(..), + getVisibleObject, + isBeingWielded, + isWielding, + visibleObject, + objectDetailsLookup, + objectDestination, + objectIdealPosition, + objectFacing, + objectIdealFacing, + objectIdealOrientation, + visibleObjectHeader, + wieldableObjectIdealOrientation) + where + +import RSAGL.FRP +import Data.Maybe +import ProtocolTypes +import Animation +import Tables +import Control.Arrow +import Data.List +import RSAGL.Animation +import AnimationExtras +import RSAGL.Math +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Monad +import Scene +import Models.LibraryData +import qualified Data.ByteString.Char8 as B + +data ToolThreadInput = ToolThreadInput { + -- | Wield points of all creatures that are on screen. + tti_wield_points :: Map.Map Integer CoordinateSystem } + +data CreatureThreadOutput = CreatureThreadOutput { + -- | Wield point for this creature. This is the coordinate system in which + -- a tool should be rendered, where the origin is the point at which the + -- creature is grasping the weapon. + cto_wield_point :: CoordinateSystem } + +class AbstractEmpty a where + abstractEmpty :: a + +instance AbstractEmpty () where + abstractEmpty = () + +instance AbstractEmpty (Maybe a) where + abstractEmpty = Nothing + +type AvatarSwitch i o m = RSwitch Enabled (Maybe Integer) i o m + +-- | Avatar for unrecognized objects. Basically this is a big conspicuous +-- warning that something is implemented in the engine but not in the client. +questionMarkAvatar :: (FRPModel m) => FRP e (AvatarSwitch i o m) i (Maybe CreatureThreadOutput) +questionMarkAvatar = proc _ -> + do visibleObjectHeader -< () + t <- threadTime -< () + m_object_type <- objectDetailsLookup ThisObject "object-type" -< () + m_species <- objectDetailsLookup ThisObject "species" -< () + m_tool <- objectDetailsLookup ThisObject "tool" -< () + m_building <- objectDetailsLookup ThisObject "building" -< () + debugOnce -< if any (isJust) [m_object_type,m_species,m_tool] + then (Just $ B.concat $ ["questionMarkAvatar: apparently didn't recognize object: ", + B.pack $ show m_object_type, ", ", B.pack $ show m_species, ", ", B.pack $ show m_tool, ", ", B.pack $ show m_building]) + else Nothing + m_position <- objectIdealPosition ThisObject -< () + let float_y = sine $ fromRotations $ t `cyclical'` (fromSeconds 5) + let m_transform = fmap (translate (Vector3D 0 (0.7 + float_y/10) 0)) m_position + transformA libraryA -< maybe (Affine id,(scene_layer_local,NullModel)) + (\p -> (Affine $ translateToFrom p origin_point_3d, + (scene_layer_local,SimpleModel QuestionMark))) m_transform + m_wield_point <- whenJust exportCoordinateSystem -< fmap (\p -> translate (vectorToFrom p origin_point_3d `add` Vector3D 0.4 0 0)) m_transform + returnA -< + do wield_point <- m_wield_point + return $ CreatureThreadOutput { + cto_wield_point = wield_point } + + +-- | Launch threads to represent every visible object. +visibleObjectThreadLauncher :: (FRPModel m,AbstractEmpty o) => + FRP e (AvatarSwitch i o m) i o -> + FRP e (AvatarSwitch i o m) i o +visibleObjectThreadLauncher avatarA = + arr (const abstractEmpty) <<< + spawnThreads <<< + arr (map (\x -> (Just x,avatarA))) <<< + newListElements <<< allObjects <<< + arr (const ()) + +-- | Kill a thread if an object has the wrong \"object-type\" field, e.g. anything that isn't a \"creature\". +objectTypeGuard :: (FRPModel m, StateOf m ~ AnimationState, ThreadingOf m ~ Enabled, ThreadIDOf m ~ Maybe Integer) => (B.ByteString -> Bool) -> FRP e m () () +objectTypeGuard f = proc () -> + do m_obj_type <- objectDetailsLookup ThisObject "object-type" -< () + killThreadIf -< maybe False (not . f) m_obj_type + +-- | Header function that just kills the current thread if it isn't a visible object. +visibleObjectHeader :: (FRPModel m, ThreadingOf m ~ Enabled, ThreadIDOf m ~ Maybe Integer, StateOf m ~ AnimationState) => FRP e m () () +visibleObjectHeader = proc () -> + do unique_id <- arr (fromMaybe (error "visibleObjectHeader: threadIdentity was Nothing")) <<< threadIdentity -< () + uids <- allObjects -< () + killThreadIf -< not $ unique_id `elem` uids + +-- | List all 'VisibleObject' records. +visibleObjects :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () [VisibleObject] +visibleObjects = proc () -> arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0") + +-- | List all object UIDs. +allObjects :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m () [Integer] +allObjects = proc () -> + do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped) + <<< sticky isJust Nothing + <<< driverGetTableA -< ("visible-objects","0") + wielded_object_ids <- arr (map wo_unique_id . maybe [] tableSelectTyped) + <<< sticky isJust Nothing + <<< driverGetTableA -< ("wielded-objects","0") + returnA -< Set.toList $ Set.fromList visible_object_ids `Set.union` + Set.fromList wielded_object_ids + +{------------------------------------------------------------------------------- + Retrieving information about specific visible objects. +-------------------------------------------------------------------------------} + +-- | Indirect or direct reference to a visible object. +data VisibleObjectReference = + ThisObject + | UniqueID Integer + | WieldedParent VisibleObjectReference + | WieldedTool VisibleObjectReference + | Attacker + +-- | As a Tool, who is wielding you? +wieldedParent :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m (Maybe Integer) (Maybe Integer) +wieldedParent = proc m_unique_id -> + do wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0") + returnA -< fmap wo_creature_id $ find ((== m_unique_id) . Just . wo_unique_id) wielded_pairs + +-- | As a creature, what tool are you wielding? +wieldedTool :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m (Maybe Integer) (Maybe Integer) +wieldedTool = proc m_unique_id -> + do wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0") + returnA -< fmap wo_unique_id $ find ((== m_unique_id) . Just . wo_creature_id) wielded_pairs + +-- | Get the unique ID of the object specified. +getVisibleObject :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Integer) +getVisibleObject (ThisObject) = threadIdentity +getVisibleObject (UniqueID unique_id) = proc () -> returnA -< Just unique_id +getVisibleObject (WieldedParent (WieldedTool ref)) = getVisibleObject ref +getVisibleObject (WieldedTool (WieldedParent ref)) = getVisibleObject ref +getVisibleObject (WieldedParent ref) = getVisibleObject ref >>> wieldedParent +getVisibleObject (WieldedTool ref) = getVisibleObject ref >>> wieldedTool +getVisibleObject Attacker = arr (const "who-attacks") >>> driverGetAnswerA >>> arr (maybe Nothing readInteger) + +-- | As a Tool, are you currently being wielded by anyone? +isBeingWielded :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () Bool +isBeingWielded obj = getVisibleObject (WieldedParent obj) >>> arr isJust + +-- | As a Creature, are you currently wielding a tool? +isWielding :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () Bool +isWielding obj = getVisibleObject (WieldedTool obj) >>> arr isJust + +-- | Get the 'VisibleObject' record for any object. +visibleObject :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe VisibleObject) +visibleObject obj = proc () -> + do m_unique_id <- getVisibleObject obj -< () + visible_objects <- visibleObjects -< () + returnA -< do find ((== m_unique_id) . Just . vo_unique_id) visible_objects + +-- | Get an "object-details" field for the specified visible object. +objectDetailsLookup :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> B.ByteString -> FRP e m () (Maybe B.ByteString) +objectDetailsLookup obj field = proc _ -> + do m_unique_id <- getVisibleObject obj -< () + m_details_table <- arr (fromMaybe Nothing) <<< whenJust (driverGetTableA <<< arr (\x -> ("object-details",B.pack $ show x))) -< m_unique_id + sticky isJust Nothing -< + do details_table <- m_details_table + tableLookup details_table ("property","value") field + +-- | Grid position to which the specified object should move. +objectDestination :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe (Integer,Integer)) +objectDestination obj = arr (fmap vo_xy) <<< visibleObject obj + +-- | Correct position of the specified object, with smooth translation. +objectIdealPosition :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Point3D) +objectIdealPosition obj = + whenJust (approachA 0.25 (perSecond 3)) <<< + arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< + objectDestination obj + +-- | Goal direction in which the specified object should be pointed. +objectFacing :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe BoundAngle) +objectFacing obj = arr (fmap vo_facing) <<< visibleObject obj + +-- | Direction in which the specified object should be pointed, with smooth rotation. +objectIdealFacing :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Angle) +objectIdealFacing obj = arr (fmap unboundAngle) <<< whenJust (approachA 0.1 (perSecond 1)) <<< objectFacing obj + +-- | Combine 'objectIdealPosition' and 'objectIdealFacing' to place an object. +objectIdealOrientation :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe CoordinateSystem) +objectIdealOrientation obj = proc () -> + do m_p <- objectIdealPosition obj -< () + m_a <- objectIdealFacing obj -< () + returnA -< do p <- m_p + a <- m_a + return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system + +-- | 'objectIdealOrientation' implementation that is aware of wield points for wieldable objects. If an object is being +-- wielded, it will snap to it's wield point. +wieldableObjectIdealOrientation :: (FRPModel m,StateOf m ~ AnimationState,ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m ToolThreadInput (Maybe CoordinateSystem) +wieldableObjectIdealOrientation obj = proc tti -> + do ideal_resting <- objectIdealOrientation obj -< () + m_wielded_parent <- getVisibleObject (WieldedParent obj) -< () + let wield_point = do wielded_parent <- m_wielded_parent + Map.lookup wielded_parent $ tti_wield_points tti + returnA -< wield_point `mplus` ideal_resting diff --git a/src/VisibleObject.lhs b/src/VisibleObject.lhs deleted file mode 100644 --- a/src/VisibleObject.lhs +++ /dev/null @@ -1,117 +0,0 @@ -\section{Visible Objects} - -\begin{code} -{-# LANGUAGE Arrows #-} - -module VisibleObject - (ToolThreadInput(..), - visibleObjects, - allObjects, - wieldedParent, - wieldedTool, - visibleObject, - visibleObjectUniqueID, - objectDetailsLookup, - objectDestination, - objectIdealPosition, - objectFacing, - objectIdealFacing, - objectIdealOrientation, - visibleObjectHeader, - wieldableObjectIdealOrientation) - where - -import RSAGL.FRP -import RSAGL.Edge -import Data.Maybe -import ProtocolTypes -import Animation -import Tables -import Control.Arrow -import Data.List -import RSAGL.Time -import RSAGL.InverseKinematics -import RSAGL.Vector -import RSAGL.Angle -import RSAGL.Affine -import RSAGL.CoordinateSystems -import qualified Data.Set as Set -import qualified Data.Map as Map -import Control.Monad - -data ToolThreadInput = ToolThreadInput { - tti_wield_points :: Map.Map Integer CoordinateSystem } - -visibleObjectHeader :: RSAnimA (Maybe Integer) i o () () -visibleObjectHeader = proc () -> - do unique_id <- arr (fromMaybe (error "visibleObjectHeader: threadIdentity was Nothing")) <<< threadIdentity -< () - uids <- allObjects -< () - killThreadIf -< isNothing $ find (== unique_id) uids - -visibleObjects :: RSAnimAX any t i o () [VisibleObject] -visibleObjects = proc () -> arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0") - -allObjects :: RSAnimAX any a i o () [Integer] -allObjects = proc () -> - do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("visible-objects","0") - wielded_object_ids <- arr (map wo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0") - returnA -< Set.toList $ Set.fromList visible_object_ids `Set.union` Set.fromList wielded_object_ids - -wieldedParent :: RSAnimA (Maybe Integer) i o () (Maybe Integer) -wieldedParent = proc () -> - do unique_id <- visibleObjectUniqueID -< () - wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0") - returnA -< fmap wo_creature_id $ find ((== unique_id) . wo_unique_id) wielded_pairs - -wieldedTool :: RSAnimA (Maybe Integer) i o () (Maybe Integer) -wieldedTool = proc () -> - do unique_id <- visibleObjectUniqueID -< () - wielded_pairs <- arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA -< ("wielded-objects","0") - returnA -< fmap wo_unique_id $ find ((== unique_id) . wo_creature_id) wielded_pairs - -visibleObjectUniqueID :: RSAnimA (Maybe Integer) i o () Integer -visibleObjectUniqueID = arr (fromMaybe (error "visibleObjectUniqueID: threadIdentity was Nothing")) <<< threadIdentity - -visibleObject :: RSAnimA (Maybe Integer) i o () (Maybe VisibleObject) -visibleObject = proc () -> - do unique_id <- visibleObjectUniqueID -< () - visible_objects <- visibleObjects -< () - returnA -< do find ((== unique_id) . vo_unique_id) visible_objects - -objectDetailsLookup :: String -> RSAnimA (Maybe Integer) i o () (Maybe String) -objectDetailsLookup field = proc _ -> - do unique_id <- visibleObjectUniqueID -< () - m_details_table <- driverGetTableA -< ("object-details",show unique_id) - sticky isJust Nothing -< (\x -> tableLookup x ("property","value") field) =<< m_details_table - -objectDestination :: RSAnimA (Maybe Integer) i o () (Maybe (Integer,Integer)) -objectDestination = arr (fmap vo_xy) <<< visibleObject - -objectIdealPosition :: RSAnimA (Maybe Integer) i o () (Maybe Point3D) -objectIdealPosition = - whenJust (approachA 0.25 (perSecond 3)) <<< - arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<< - objectDestination - -objectFacing :: RSAnimA (Maybe Integer) i o () (Maybe BoundAngle) -objectFacing = arr (fmap vo_facing) <<< visibleObject - -objectIdealFacing :: RSAnimA (Maybe Integer) i o () (Maybe Angle) -objectIdealFacing = arr (fmap unboundAngle) <<< whenJust (approachA 0.1 (perSecond 1)) <<< objectFacing - -objectIdealOrientation :: RSAnimA (Maybe Integer) i o () (Maybe CoordinateSystem) -objectIdealOrientation = proc () -> - do m_p <- objectIdealPosition -< () - m_a <- objectIdealFacing -< () - returnA -< do p <- m_p - a <- m_a - return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system - -wieldableObjectIdealOrientation :: RSAnimA (Maybe Integer) i o ToolThreadInput (Maybe CoordinateSystem) -wieldableObjectIdealOrientation = proc tti -> - do ideal_resting <- objectIdealOrientation -< () - m_wielded_parent <- wieldedParent -< () - let wield_point = do wielded_parent <- m_wielded_parent - Map.lookup wielded_parent $ tti_wield_points tti - returnA -< wield_point `mplus` ideal_resting -\end{code}