diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, OverloadedStrings #-} - -module Main (main) where - -import System.Process -import System.Exit -import System.Console.GetOpt -import Control.Concurrent -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 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 ++ ")" - _ -> return () - return () - roguestar_gl_exit <- waitForProcess roguestar_gl - case roguestar_gl_exit of - ExitFailure x -> putStrLn $ "roguestar-gl terminated unexpectedly (" ++ show x ++ ")" - _ -> return () - -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_ (setup . snd) tos - forever $ - do l <- B.hGetLine from - flip mapM_ tos $ \(name,to) -> send to $ name `B.append` l - -printChan :: Handle -> Chan B.ByteString -> IO () -printChan h c = forever $ - do s <- readChan c - B.hPutStrLn h s - hFlush h - diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal --- a/roguestar-gl.cabal +++ b/roguestar-gl.cabal @@ -1,59 +1,54 @@ name: roguestar-gl -version: 0.4.0.3 +version: 0.6.0.0 +cabal-version: >=1.2 license: OtherLicense license-file: LICENSE author: Christopher Lane Hinson maintainer: Christopher Lane Hinson category: Game -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. - . - The git repository is available at . +synopsis: Sci-fi roguelike game. Client library. +description: Roguestar-glut and roguestar-gtk depend on this library for the bulk of their functionality. homepage: http://roguestar.downstairspeople.org/ -build-depends: base>=4&&<5, - rsagl==0.4.0.3, - 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, - vector>=0.7.0.1 && < 0.8, - statistics>=0.8.0.4 && < 0.9, - stm>=2.1.1.2 && < 2.2, - priority-sync>=0.2.1.0 && < 0.2.2 - build-type: Simple tested-with: GHC==6.12.1 -executable: roguestar-gl -main-is: MainGLUT.hs -hs-source-dirs: src -other-modules: Quality, ProtocolTypes, VisibleObject, - Strings, WordGenerator, Driver, - PrintTextData, Animation, - Actions, Limbs, Tables, PrintText, CommandLine, - Models.Androsynth, Models.QuestionMark, Models.Terrain, Models.RecreantFactory, - Models.Recreant, Models.Ascendant, Models.Materials, Models.Reptilian, - 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, AnimationBuildings, Models.Monolith, - Models.Stargate, Statistics, Globals, Models.Sky, Scene, Models.Spheres, - Models.EnergySwords, Models.EnergyThings, Models.CyborgType4, - AnimationEvents, AnimationMenus, AnimationTerrain, AnimationTools, - AnimationExtras, AnimationCreatures, AnimationBuildings, MaybeArrow, - EventUtils, Sky, Config -ghc-options: -threaded -fno-warn-type-defaults -fexcess-precision -ghc-prof-options: -prof -auto-all +Library + hs-source-dirs: src + exposed-modules: Processes, Initialization, DrawString, Config, KeyStroke, PrintText, Globals + other-modules: Quality, ProtocolTypes, VisibleObject, + Strings, WordGenerator, Driver, + PrintTextData, Animation, + Actions, Limbs, Tables, CommandLine, + Models.Androsynth, Models.QuestionMark, Models.Terrain, Models.RecreantFactory, + Models.Recreant, Models.Glows, Models.Materials, Models.Reptilian, + Models.Hellion, + 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, AnimationBuildings, Models.Node, + Models.Stargate, Statistics, Models.Sky, Scene, Models.Spheres, + Models.EnergySwords, Models.EnergyThings, Models.CyborgType4, + AnimationEvents, AnimationMenus, AnimationTerrain, AnimationTools, + AnimationExtras, AnimationCreatures, AnimationBuildings, MaybeArrow, + EventUtils, Sky, CreatureData, AnimationVortex, + Paths_roguestar_gl + build-depends: base>=4&&<5, + GLUT>=2.2 && < 2.3, + rsagl==0.6.0.0, + rsagl-math==0.6.0.0, + rsagl-frp==0.6.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, + OpenGL>=2.4.0.1 && < 2.5, + filepath>=1.1.0.3 && < 1.2, + random>=1.0.0.2 && < 1.1, + bytestring>=0.9.1.5 && < 0.10, + stm>=2.1.1.2 && < 2.2, + priority-sync>=0.2.1.0 && < 0.2.2 + ghc-options: -fno-warn-type-defaults -fexcess-precision + ghc-prof-options: -prof -auto-all -executable: roguestar -main-is: Main.hs -build-depends: process, old-time, bytestring -ghc-options: -threaded diff --git a/src/Actions.hs b/src/Actions.hs --- a/src/Actions.hs +++ b/src/Actions.hs @@ -6,7 +6,7 @@ (takeUserInputAction, getValidActions, ActionInput(..), - select_race_action_names, + select_species_action_names, select_base_class_action_names, make_what_action_names, executeContinueAction, @@ -21,15 +21,12 @@ import Tables import Data.Maybe import Globals -import RSAGL.Types +import RSAGL.Math.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, @@ -60,7 +57,7 @@ ----------------------------------------------------------} actionValid :: ActionInput -> Action -> STM ActionValidity -actionValid action_input action = +actionValid action_input action = do result <- runErrorT $ action action_input return $ either Hold (const Go) result @@ -90,7 +87,7 @@ -- 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 @@ -101,14 +98,14 @@ -- 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 +-- In practice this function is used for things like the species-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. +-- 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] $ @@ -131,7 +128,7 @@ -- The action name is passed directly to the engine. -- stateLinkedAction :: [B.ByteString] -> B.ByteString -> (B.ByteString,Action) -stateLinkedAction allowed_state action_name = +stateLinkedAction allowed_state action_name = (action_name, stateGuard allowed_state $ \action_input -> return $ driverAction (action_driver_object action_input) [action_name]) @@ -152,7 +149,7 @@ 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"] +menu_states = ["species-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" @@ -182,12 +179,18 @@ normal_action :: (B.ByteString,Action) normal_action = ("normal", - stateGuard (menu_states ++ player_turn_states) $ \action_input -> + 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" +down_action :: (B.ByteString,Action) +down_action = stateLinkedAction player_turn_states "down" + +up_action :: (B.ByteString,Action) +up_action = stateLinkedAction player_turn_states "up" + jump_action :: (B.ByteString,Action) jump_action = stateLinkedAction player_turn_states "jump" @@ -238,12 +241,12 @@ 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) +selectSpeciesAction :: B.ByteString -> (B.ByteString,Action) +selectSpeciesAction s = + (s,selectTableAction ("player-species","0","name") "species-selection" "select-species" s) selectBaseClassAction :: B.ByteString -> (B.ByteString,Action) -selectBaseClassAction s = +selectBaseClassAction s = (s,selectTableAction ("base-classes","0","class") "class-selection" "select-class" s) zoomSize :: RSdouble -> RSdouble @@ -304,22 +307,22 @@ 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_species_action_names :: [B.ByteString] +select_species_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_species_actions :: [(B.ByteString,Action)] +select_species_actions = map selectSpeciesAction select_species_action_names select_base_class_action_names :: [B.ByteString] select_base_class_action_names = ["barbarian", @@ -337,18 +340,19 @@ select_base_class_actions :: [(B.ByteString,Action)] select_base_class_actions = map selectBaseClassAction select_base_class_action_names --- | List of every convievable action. +-- | List of every action in the game. 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 ++ + select_species_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, + [move_action,down_action,up_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. diff --git a/src/Animation.hs b/src/Animation.hs --- a/src/Animation.hs +++ b/src/Animation.hs @@ -12,6 +12,8 @@ module Animation (RSwitch, AnimationState, + FRPModes, + RoguestarModes, RoguestarAnimationObject, newRoguestarAnimationObject, runRoguestarAnimationObject, @@ -19,6 +21,7 @@ driverGetTableA, printTextA, printTextOnce, + statusA, debugA, debugOnce, donesA, @@ -30,22 +33,22 @@ libraryPointAtCamera, blockContinue, requestPrintTextMode, - readGlobal, - randomA) + readGlobal) 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.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 @@ -57,14 +60,19 @@ import Data.Ord import Strings import Globals +import PrintTextData +import Statistics import Control.Concurrent.STM -import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B +import qualified Data.Map as Map +import qualified KeyStroke as K data AnimationState = AnimationState { animstate_scene_accumulator :: SceneAccumulator IO, animstate_globals :: Globals, animstate_driver_object :: FrozenDriver, animstate_print_text_object :: PrintTextObject, + animstate_status_lines :: Map.Map StatusField B.ByteString, animstate_library :: Library, animstate_block_continue :: Bool, animstate_print_text_mode :: PrintTextMode, @@ -72,17 +80,17 @@ instance CoordinateSystemClass AnimationState where getCoordinateSystem = getCoordinateSystem . animstate_scene_accumulator - storeCoordinateSystem cs as = as { + storeCoordinateSystem cs as = as { animstate_scene_accumulator = storeCoordinateSystem cs $ animstate_scene_accumulator as } instance ScenicAccumulator AnimationState IO where - accumulateScene sl so as = as { + 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 { + 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 } @@ -93,6 +101,9 @@ instance (CoordinateSystemClass csc,StateOf m ~ csc) => AffineTransformable (FRP e m j p) where transform m actionA = proc x -> transformA actionA -< (Affine $ transform m,x) +type FRPModes m = (StateOf m,InputOutputOf m) +type RoguestarModes = (AnimationState,Enabled) + newtype RoguestarAnimationObject = RoguestarAnimationObject (FRPProgram AnimationState () SceneLayerInfo) newRoguestarAnimationObject :: (forall e. FRP e (FRP1 AnimationState () SceneLayerInfo) () SceneLayerInfo) -> IO RoguestarAnimationObject @@ -113,36 +124,44 @@ animstate_scene_accumulator = null_scene_accumulator, animstate_driver_object = frozen_driver_object, animstate_print_text_object = print_text_object, + animstate_status_lines = Map.empty, 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 $ + runStatistics animation_post_exec $ 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 + setStatus print_text_object $ + animstate_status_lines 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) +-- | Request an answer from the engine. This will return 'Nothing' until the +-- answer arrives, which may never happen. +driverGetAnswerA :: (StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + 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_) -< + runStatistics animation_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 :: (StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + 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 $ + runStatistics animation_query $ atomically $ getTable driver_object_ the_table_name the_table_id) -< (driver_object,query) @@ -156,7 +175,8 @@ -- | 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 :: (FRPModel m, StateOf m ~ AnimationState) => + FRP e m (Maybe (TextType,B.ByteString)) () printTextOnce = onceA printTextA printTextA :: (FRPModel m, StateOf m ~ AnimationState) => @@ -169,41 +189,67 @@ 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 +statusA :: (FRPModel m, StateOf m ~ AnimationState) => + FRP e m (Maybe (StatusField,B.ByteString)) () +statusA = proc status_data -> + do animstate <- fetch -< () + store -< case status_data of + Just (field,status) -> animstate { animstate_status_lines = + Map.insert field status $ + animstate_status_lines animstate } + Nothing -> animstate + +-- | Number of dones. (A done is a message from the engine that a change has occured in the game world.) +donesA :: (StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + FRP e m () Integer donesA = proc () -> do driver_object <- arr animstate_driver_object <<< fetch -< () - ioAction (atomically . driverDones) -< driver_object + ioAction (runStatistics animation_query . 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 :: (StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + 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 :: (FRPModel m, StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + 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] +-- | 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, + InputOutputOf m ~ Enabled) => + B.ByteString -> FRP e m () [K.KeyString] 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) + ioAction id -< runStatistics animation_query $ + 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 :: (FRPModel m, StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + [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 :: (FRPModel m, StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + 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 + printTextA -< fmap (\s -> (Query, + (B.pack $ K.prettyString s) `B.append` " - " `B.append` hrstring action_name)) $ + listToMaybe $ sortBy (comparing K.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 () () @@ -216,14 +262,19 @@ 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 :: (FRPModel m) => + (forall n. (FRPModel n, StateOf n ~ StateOf m, + InputOutputOf n ~ InputOutputOf 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) => +libraryA :: (StateOf m ~ AnimationState,LibraryModelSource lm, + InputOutputOf m ~ Enabled) => FRP e m (SceneLayer,lm) () libraryA = proc (layer,lm) -> do q <- readGlobal global_quality_setting -< () @@ -232,7 +283,8 @@ sceneObject $ lookupModel lib (toLibraryModel lm) q) -- | Display a library model that remains oriented toward the camera. -libraryPointAtCamera :: (StateOf m ~ AnimationState,LibraryModelSource lm) => +libraryPointAtCamera :: (StateOf m ~ AnimationState,LibraryModelSource lm, + InputOutputOf m ~ Enabled) => FRP e m (SceneLayer,lm) () libraryPointAtCamera = proc (layer,lm) -> do q <- readGlobal global_quality_setting -< () @@ -263,12 +315,10 @@ mergePrintTextModes m _ = m -- | Read a global variable. -readGlobal :: (StateOf m ~ AnimationState) => (Globals -> TVar g) -> FRP e m () g +readGlobal :: (StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => + (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 + ioAction (\globals_ -> runStatistics animation_query $ atomically $ readTVar $ f globals_) -< globals diff --git a/src/AnimationBuildings.hs b/src/AnimationBuildings.hs --- a/src/AnimationBuildings.hs +++ b/src/AnimationBuildings.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, FlexibleContexts, RankNTypes #-} module AnimationBuildings (buildingAvatar) where import RSAGL.FRP +import RSAGL.Math +import RSAGL.Animation +import RSAGL.Color.RSAGLColors import Animation import VisibleObject import Models.LibraryData @@ -14,6 +17,10 @@ type BuildingAvatarSwitch m = AvatarSwitch () () m type BuildingAvatar e m = FRP e (BuildingAvatarSwitch m) () () +-- | An avatar for a building. This function +-- detects the type of a building based on the +-- FRP Thread ID, and switches to the appropriate +-- type of building avatar. buildingAvatar :: (FRPModel m) => BuildingAvatar e m buildingAvatar = proc () -> do objectTypeGuard (== "building") -< () @@ -21,16 +28,46 @@ switchContinue -< (fmap switchTo m_building_type,()) returnA -< () where switchTo "monolith" = simpleBuildingAvatar Monolith + switchTo "anchor" = planetaryAnchorAvatar switchTo "portal" = simpleBuildingAvatar Portal switchTo _ = questionMarkAvatar >>> arr (const ()) simpleBuildingAvatar :: (FRPModel m, LibraryModelSource lm) => lm -> BuildingAvatar e m -simpleBuildingAvatar phase_weapon_model = proc () -> +simpleBuildingAvatar building_model = genericBuildingAvatar $ proc () -> + do libraryA -< (scene_layer_local,building_model) + returnA -< () + +genericBuildingAvatar :: (FRPModel m) => + (forall x y. FRP e (FRP1Context x y (BuildingAvatarSwitch m)) () ()) -> + BuildingAvatar e m +genericBuildingAvatar actionA = proc () -> do visibleObjectHeader -< () m_orientation <- objectIdealOrientation ThisObject -< () - whenJust (transformA libraryA) -< fmap - (\o -> (o,(scene_layer_local,phase_weapon_model))) m_orientation + whenJust (transformA actionA) -< fmap + (\o -> (o,())) m_orientation returnA -< () + +planetaryAnchorAvatar :: (FRPModel m) => BuildingAvatar e m +planetaryAnchorAvatar = genericBuildingAvatar $ translate (Vector3D 0 1.0 0) $ proc () -> + do libraryA -< (scene_layer_local,PlanetaryAnchorCore) + planetaryAnchorFlange (1.1^1) (fromDegrees 25) (fromDegrees 30) 10.0 -< () + planetaryAnchorFlange (1.1^2) (fromDegrees 50) (fromDegrees 60) 9.0 -< () + planetaryAnchorFlange (1.1^3) (fromDegrees 75) (fromDegrees 90) 7.0 -< () + planetaryAnchorFlange (1.1^4) (fromDegrees 100) (fromDegrees 120) 4.0 -< () + planetaryAnchorFlange (1.1^5) (fromDegrees 125) (fromDegrees 150) 1.0 -< () + accumulateSceneA -< (scene_layer_local, + lightSource $ PointLight (Point3D 0 1.0 0) + (measure (Point3D 0 1.0 0) (Point3D 1 0 1)) + white + violet) + +planetaryAnchorFlange :: (FRPModel m, StateOf m ~ AnimationState, InputOutputOf m ~ Enabled) => + RSdouble -> Angle -> Angle -> RSdouble -> FRP e m () () +planetaryAnchorFlange s rx rz x = scale' s $ proc () -> + do rotateA (Vector3D 0 1 0) (perSecond $ fromDegrees $ x*3.0) (rotate (Vector3D 0 0 1) rz $ + rotateA (Vector3D 0 0 1) (perSecond $ fromDegrees $ x*7.0) (rotate (Vector3D 1 0 0) rx $ + rotateA (Vector3D 1 0 0) (perSecond $ fromDegrees $ x*2.0) libraryA)) -< + (scene_layer_local,PlanetaryAnchorFlange) diff --git a/src/AnimationCreatures.hs b/src/AnimationCreatures.hs --- a/src/AnimationCreatures.hs +++ b/src/AnimationCreatures.hs @@ -7,18 +7,16 @@ import RSAGL.FRP import RSAGL.Math import RSAGL.Animation -import RSAGL.Modeling.RSAGLColors +import RSAGL.Color.RSAGLColors import Animation import Control.Arrow -import Data.Maybe import Models.LibraryData import VisibleObject import Limbs import Scene import AnimationExtras - -type CreatureAvatarSwitch m = AvatarSwitch () (Maybe CreatureThreadOutput) m -type CreatureAvatar e m = FRP e (AvatarSwitch () (Maybe CreatureThreadOutput) m) () (Maybe CreatureThreadOutput) +import AnimationVortex +import CreatureData -- | Avatar for any creature that automatically switches to the appropriate species-specific avatar thread. creatureAvatar :: (FRPModel m) => CreatureAvatar e m @@ -29,23 +27,18 @@ returnA -< Nothing where switchTo "encephalon" = encephalonAvatar switchTo "recreant" = recreantAvatar - switchTo "androsynth" = androsynthAvatar - switchTo "ascendant" = ascendantAvatar - switchTo "caduceator" = caduceatorAvatar - switchTo "reptilian" = reptilianAvatar + switchTo "androsynth" = androsynthAvatar + switchTo "ascendant" = ascendantAvatar + switchTo "caduceator" = caduceatorAvatar + switchTo "reptilian" = reptilianAvatar + switchTo "hellion" = hellionAvatar + switchTo "dustvortex" = dustVortexAvatar switchTo _ = questionMarkAvatar -genericCreatureAvatar :: (FRPModel m) => FRP e (CreatureAvatarSwitch m) () CreatureThreadOutput -> CreatureAvatar e m -genericCreatureAvatar creatureA = proc () -> - do visibleObjectHeader -< () - m_orientation <- objectIdealOrientation ThisObject -< () - switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar creatureA,Nothing) else (Nothing,Nothing) - arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_orientation,()) - encephalonAvatar :: (FRPModel m) => CreatureAvatar e m encephalonAvatar = genericCreatureAvatar $ proc () -> do libraryA -< (scene_layer_local,Encephalon) - wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< + 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 } @@ -61,45 +54,29 @@ androsynthAvatar :: (FRPModel m) => CreatureAvatar e m androsynthAvatar = genericCreatureAvatar $ proc () -> do libraryA -< (scene_layer_local,Androsynth) - bothLegs ThinLimb ThinLimb (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.7 (Point3D 0.07 0 0.0) -< () + bothLegs ThinLimb ThinLimb Upright (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.55 (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 :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => Point3D -> Vector3D -> FRP e m () () -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 -< (scene_layer_local,AscendantGlow))) -< - (translateToFrom local_origin origin_point_3d $ root_coordinate_system,()) - ascendantAvatar :: (FRPModel m) => CreatureAvatar e m -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 -< (scene_layer_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 } +ascendantAvatar = particleAvatar vortex 12 (SimpleModel AscendantGlow) $ Just light_blue +dust_vortex :: Vortex +dust_vortex = vortex { + vortex_rotation = \x -> if x > 0.001 then recip x else 0, + vortex_binding = 0, + vortex_containment = 0.0, + vortex_base_angle = fromDegrees 45, + vortex_repulsion = 0.4, + vortex_height = -0.1, + vortex_gravity = 15, + vortex_base_force = 120 } + +dustVortexAvatar :: (FRPModel m) => CreatureAvatar e m +dustVortexAvatar = particleAvatar dust_vortex 12 (SimpleModel DustPuff) Nothing + caduceatorAvatar :: (FRPModel m) => CreatureAvatar e m caduceatorAvatar = genericCreatureAvatar $ proc () -> do libraryA -< (scene_layer_local,Caduceator) @@ -111,9 +88,26 @@ reptilianAvatar :: (FRPModel m) => CreatureAvatar e m reptilianAvatar = genericCreatureAvatar $ proc () -> do libraryA -< (scene_layer_local,Reptilian) - bothLegs ReptilianLegUpper ReptilianLegLower (Vector3D 0 0 1) (Point3D (0.05) 0.25 (-0.1)) 0.29 (Point3D 0.07 0 0.0) -< () + bothLegs ReptilianLegUpper ReptilianLegLower Upright (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 } + +hellionAvatar :: (FRPModel m) => CreatureAvatar e m +hellionAvatar = genericCreatureAvatar $ proc () -> + do libraryA -< (scene_layer_local,Hellion) + bothEyeStalks (SimpleModel HellionAppendage) + (SimpleModel HellionAppendage) + (SimpleModel HellionEye) + (Vector3D (0.1) 0 (-1)) + (Point3D 0.06 0.55 0) + 1.2 + (Point3D 0.2 0.8 0.05) -< () + bothLegs HellionAppendage HellionAppendage Upright (Vector3D 0.5 0 (-1)) (Point3D 0.05 0.55 0) 0.8 (Point3D 0.05 0 0) -< () + wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<< + bothArms HellionAppendage HellionAppendage (Vector3D 1.0 0.0 (-0.5)) (Point3D 0.1 0.6 0) 0.4 (Point3D 0.3 0.25 0.3) -< () + returnA -< CreatureThreadOutput { + cto_wield_point = wield_point } + diff --git a/src/AnimationEvents.hs b/src/AnimationEvents.hs --- a/src/AnimationEvents.hs +++ b/src/AnimationEvents.hs @@ -30,18 +30,21 @@ -- | Print messages about game events. eventMessager :: (FRPModel m) => EventHandler e m () () -eventMessager = proc () -> - do eventStateHeader (not . (`elem` recognized_events)) -< () - blockContinue -< True +eventMessager = proc () -> + do eventStateHeader (not . (`elem` recognized_events)) -< () + blockContinue -< True -- | A handler for messages from a specific event state, such as \"attack-event\". -- Parameters are: -- * The name of the event (\"attack-event\") -- * The handler for the event. -messageState :: (FRPModel m) => B.ByteString -> MessageHandler e m () B.ByteString -> (B.ByteString,EventHandler e m () ()) +messageState :: (FRPModel m) => + B.ByteString -> + MessageHandler e m () (TextType,B.ByteString) -> + (B.ByteString,EventHandler e m () ()) messageState s actionA = (s,eventStateHeader (== s) >>> (proc () -> do m_string <- runMaybeArrow actionA -< Just () - printTextOnce -< fmap ((,) Event) m_string + printTextOnce -< m_string t <- threadTime -< () let time_out = t > fromSeconds 3 printTextOnce -< if time_out then Just (UnexpectedEvent,"Hmmmm . . . RogueStar is puzzled. (" `B.append` s `B.append` ")") else Nothing @@ -49,11 +52,14 @@ -- | As 'messageState', but just prints a simple string. messagePrompt :: (FRPModel m) => B.ByteString -> B.ByteString -> (B.ByteString,EventHandler e m () ()) -messagePrompt s prompt = messageState s $ arr (const prompt) +messagePrompt s prompt = messageState s $ arr (const (Query,prompt)) --- | As 'messageState', but constructs an alternate message handler to be switched --- via 'continueWith'. -alternateMessage :: (FRPModel m) => B.ByteString -> MessageHandler e m () B.ByteString -> EventHandler e m () () +-- | As 'messageState', but constructs an alternate message handler to be +-- switched via 'continueWith'. +alternateMessage :: (FRPModel m) => + B.ByteString -> + MessageHandler e m () (TextType,B.ByteString) -> + EventHandler e m () () alternateMessage s actionA = snd $ messageState s actionA -- | Provide a default value to substitute if a computation doesn't yield a value after the specified timeout period. @@ -65,7 +71,7 @@ returnA -< m_o -- | As 'driverGetAnswerA' -answer :: B.ByteString -> MessageHandler e m () B.ByteString +answer :: B.ByteString -> MessageHandler e m () B.ByteString answer s = liftConst s driverGetAnswerA -- | As 'driverGetTableA' that gets one element of the 'object-details' table. @@ -83,10 +89,11 @@ nameOf who = proc () -> do who_id <- answer who -< () who_player <- answer "who-player" -< () + species_name <- detail "species" -< who_id liftJust debugOnce <<< maybeA -< if who_player == "0" then Just "nameOf: I don't know who you are . . ." else Nothing returnA -< case () of () | who_id == who_player -> You - () | otherwise -> Singular who_id "recreant" + () | otherwise -> Singular who_id $ hrstring species_name data Noun = X | You | Singular { _noun_id, _noun_word :: B.ByteString } deriving (Eq) @@ -145,47 +152,73 @@ messages :: (FRPModel m) => [(B.ByteString,EventHandler e m () ())] messages = [ - messageState "attack-event" $ proc () -> + messageState "attack-event" $ proc () -> do weapon_used <- answer "weapon-used" -< () continueWith -< if weapon_used == "0" then unarmedAttack else armedAttack guardA -< False returnA -< error "messageState: \"attack-event\" unreachable", - messageState "miss-event" $ proc () -> + messageState "miss-event" $ proc () -> do who_attacks <- nameOf "who-attacks" -< () - returnA -< sentence who_attacks X X $ "$You miss(es).", - messageState "killed-event" $ proc () -> + returnA -< (Event,sentence who_attacks X X $ "$You miss(es)."), + messageState "killed-event" $ proc () -> do who_killed <- nameOf "who-killed" -< () - returnA -< sentence who_killed X X "$You $have been killed.", + returnA -< (Event,sentence who_killed X X "$You $have been killed."), messageState "weapon-overheats-event" $ proc () -> do who_surprised <- nameOf "who-attacks" -< () player_hp_string <- playerHPString -< who_surprised - returnA -< (if who_surprised == You then "Ouch! " else "") `B.append` (sentence who_surprised X X $ "$Your weapon overheats!" `B.append` player_hp_string), + returnA -< ((,) Event) $ + (if who_surprised == You then "Ouch! " else "") `B.append` + (sentence who_surprised X X $ + "$Your weapon overheats!" `B.append` player_hp_string), messageState "weapon-explodes-event" $ proc () -> do who_surprised <- nameOf "who-attacks" -< () weapon_type <- detail "tool-type" <<< answer "weapon-used" -< () player_hp_string <- playerHPString -< who_surprised - returnA -< sentence who_surprised X X $ (if who_surprised == You then "Ouch! Frak!\n" else "") `B.append` - "$Your weapon explodes in $(your) hand!" `B.append` - (if who_surprised == You && weapon_type == "gun" - then "\nAre you sure you're qualified to operate a directed energy firearm?" else "") `B.append` - (if who_surprised == You && weapon_type == "sword" - then "\nDo you have ANY training with that thing?" else "") `B.append` player_hp_string, + returnA -< ((,) Event) $ sentence who_surprised X X $ + (if who_surprised == You then "Ouch! Frak!\n" else "") + `B.append` + "$Your weapon explodes in $(your) hand!" + `B.append` + (if who_surprised == You && weapon_type == "gun" + then "\nAre you sure you're qualified to operate a " + `B.append` + "directed energy firearm?" + else "") + `B.append` + (if who_surprised == You && weapon_type == "sword" + then "\nDo you have ANY training with that thing?" else "") + `B.append` + player_hp_string, messageState "disarm-event" $ proc () -> do who_attacks <- nameOf "who-attacks" -< () who_hit <- nameOf "who-hit" -< () - returnA -< sentence who_attacks who_hit X "$You disarm(s) $him!", + returnA -< (Event, + sentence who_attacks who_hit X "$You disarm(s) $him!"), messageState "sunder-event" $ proc () -> do who_attacks <- nameOf "who-attacks" -< () who_hit <- nameOf "who-hit" -< () - returnA -< sentence who_attacks who_hit X "$You sunder(s) $his weapon!", + returnA -< (Event, + sentence who_attacks who_hit X "$You sunder(s) $his weapon!"), messageState "heal-event" $ proc () -> do who_healed <- nameOf "who-event" -< () player_hp_string <- playerHPString -< who_healed - returnA -< sentence who_healed X X "$You $have been healed!" `B.append` player_hp_string, + returnA -< (Event, + sentence who_healed X X "$You $have been healed!" + `B.append` + player_hp_string), messageState "expend-tool-event" $ proc () -> - do returnA -< "That object has been used up.", + do returnA -< (Update,"That object has been used up."), + messageState "bump-event" $ proc () -> + do new_level <- answer "new-level" -< () + new_class <- answer "new-character-class" -< () + returnA -< (Event, + case (new_level,new_class) of + ("nothing","nothing") -> "You feel one step closer to your goal." + ("nothing","starchild") -> "It's full of stars." + (_,"nothing") -> "Welcome to level " `B.append` new_level `B.append` "." + (_,_) -> "Roguestar is confused by this bump event."), messagePrompt "attack" "Attack. Direction:", messagePrompt "fire" "Fire. Direction:", messagePrompt "move" "Walk. Direction:", @@ -198,7 +231,10 @@ do who_attacks <- nameOf "who-attacks" -< () who_hit <- nameOf "who-hit" -< () player_hp_string <- playerHPString -< who_hit - returnA -< sentence who_attacks who_hit X $ "$You strike(s) $him!" `B.append` player_hp_string + returnA -< (Event, + sentence who_attacks who_hit X $ "$You strike(s) $him!" + `B.append` + player_hp_string) armedAttack :: (FRPModel m) => EventHandler e m () () armedAttack = alternateMessage "attack-event" $ proc () -> @@ -208,13 +244,16 @@ weapon_type <- detail "tool-type" -< weapon_used player_hp_string <- playerHPString -< who_hit returnA -< case weapon_type of - "gun" -> sentence who_attacks who_hit X $ "$You shoot(s) $him!" `B.append` player_hp_string - "sword" -> sentence who_attacks who_hit X $ "$You hit(s) $him!" `B.append` player_hp_string - _ -> sentence who_attacks who_hit X $ "$You attack(s) $him!" `B.append` player_hp_string + "gun" -> (Event, sentence who_attacks who_hit X $ + "$You shoot(s) $him!" `B.append` player_hp_string) + "sword" -> (Event, sentence who_attacks who_hit X $ + "$You hit(s) $him!" `B.append` player_hp_string) + _ -> (Event, sentence who_attacks who_hit X $ + "$You attack(s) $him!" `B.append` player_hp_string) -- | Generates a string for the hit points of a creature, if that information is available. playerHPString :: (FRPModel m) => MessageHandler e m Noun B.ByteString -playerHPString = timeout (fromSeconds 0.1) "" $ proc noun -> +playerHPString = timeout (fromSeconds 1.0) "" $ proc noun -> do uid <- nounToUID -< noun hp <- detail "hp" -< uid maxhp <- detail "maxhp" -< uid diff --git a/src/AnimationExtras.hs b/src/AnimationExtras.hs --- a/src/AnimationExtras.hs +++ b/src/AnimationExtras.hs @@ -16,12 +16,12 @@ import RSAGL.FRP import RSAGL.Scene import Control.Arrow -import RSAGL.Types import Data.List ((\\)) import qualified Data.ByteString.Char8 as B -- | Switch out if the driver \"state\" does match the specified predicate. -genericStateHeader :: (FRPModel m, StateOf m ~ AnimationState) => +genericStateHeader :: (FRPModel m, StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => (B.ByteString -> FRP e m (SwitchInputOf m) (SwitchOutputOf m)) -> (B.ByteString -> Bool) -> FRP e m (SwitchInputOf m) () diff --git a/src/AnimationMenus.hs b/src/AnimationMenus.hs --- a/src/AnimationMenus.hs +++ b/src/AnimationMenus.hs @@ -24,7 +24,7 @@ -- Header for menu states. This will automatically switch away to an approprate menu if the provided state predicate does not match. menuStateHeader :: (FRPModel m) => (B.ByteString -> Bool) -> MenuHandler e m menuStateHeader f = genericStateHeader switchTo f >>> arr (const $ roguestarSceneLayerInfo mempty basic_camera) - where switchTo "race-selection" = menuRaceSelection + where switchTo "species-selection" = menuSpeciesSelection switchTo "class-selection" = menuClassSelection switchTo "pickup" = toolMenuSelection switchTo "drop" = toolMenuSelection @@ -37,13 +37,13 @@ menuDispatch :: (FRPModel m) => MenuHandler e m menuDispatch = menuStateHeader (const False) >>> arr (const $ roguestarSceneLayerInfo mempty basic_camera) -menuRaceSelection :: (FRPModel m) => MenuHandler e m -menuRaceSelection = proc s -> - do result <- menuStateHeader (== "race-selection") -< s +menuSpeciesSelection :: (FRPModel m) => MenuHandler e m +menuSpeciesSelection = proc s -> + do result <- menuStateHeader (== "species-selection") -< s requestPrintTextMode -< Unlimited clearPrintTextA -< Just () - printMenuA select_race_action_names -< () - printTextA -< Just (Query,"Select a Race:") + printMenuA select_species_action_names -< () + printTextA -< Just (Query,"Select a Species:") returnA -< result menuClassSelection :: (FRPModel m) => MenuHandler e m @@ -61,7 +61,8 @@ printTextA -< Just (Query,"Select a Class:") returnA -< result -printCharacterStats :: (FRPModel m, StateOf m ~ AnimationState) => Integer -> FRP e m () () +printCharacterStats :: (FRPModel m, FRPModes m ~ RoguestarModes) => + Integer -> FRP e m () () printCharacterStats unique_id = proc () -> do m_player_stats <- driverGetTableA -< ("player-stats",B.pack $ show unique_id) print1CharacterStat -< (m_player_stats,"str") diff --git a/src/AnimationTerrain.hs b/src/AnimationTerrain.hs --- a/src/AnimationTerrain.hs +++ b/src/AnimationTerrain.hs @@ -5,7 +5,7 @@ where import Data.List -import RSAGL.Types +import RSAGL.Math.Types import RSAGL.FRP import RSAGL.Math import RSAGL.Animation.InverseKinematics @@ -43,10 +43,12 @@ (scene_layer_local,Models.LibraryData.TerrainTile terrain_type)) returnA -< () -terrainElements :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () [ProtocolTypes.TerrainTile] -terrainElements = arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< driverGetTableA <<< arr (const ("visible-terrain","0")) +terrainElements :: (FRPModel m, FRPModes m ~ RoguestarModes) => + FRP e m () [ProtocolTypes.TerrainTile] +terrainElements = arr (maybe [] tableSelectTyped) <<< sticky isJust Nothing <<< + driverGetTableA <<< arr (const ("visible-terrain","0")) -terrainDecoration :: (FRPModel m, StateOf m ~ AnimationState) => +terrainDecoration :: (FRPModel m, FRPModes m ~ RoguestarModes) => ProtocolTypes.TerrainTile -> FRP e m () () terrainDecoration (ProtocolTypes.TerrainTile "forest" (x,y)) = @@ -57,7 +59,7 @@ (mkStdGen $ fromInteger $ 2*x + 1001*y + 7) terrainDecoration _ = proc () -> returnA -< () -leafyTree :: (FRPModel m, StateOf m ~ AnimationState) => +leafyTree :: (FRPModel m, FRPModes m ~ RoguestarModes) => Int -> Bool -> Rand StdGen (FRP e m () ()) leafyTree recursion has_leaves = do dead_tree <- liftM (== 1) $ getRandomR (1,4 :: Integer) @@ -72,7 +74,7 @@ recursion (has_leaves && not dead_tree) -leafyTreeBranch :: (FRPModel m, StateOf m ~ AnimationState) => +leafyTreeBranch :: (FRPModel m, FRPModes m ~ RoguestarModes) => Point3D -> Vector3D -> RSdouble -> @@ -96,7 +98,7 @@ scale (Vector3D thickness (vectorLength vector) thickness) $ proc () -> libraryA -< (scene_layer_local,TreeBranch) return $ this_branch >>> continue_trunk >>> foldr1 (>>>) other_branches - where leafyTreeBranchFrom :: (FRPModel m, StateOf m ~ AnimationState) => + where leafyTreeBranchFrom :: (FRPModel m, FRPModes m ~ RoguestarModes) => Bool -> RSdouble -> Rand StdGen (FRP e m () ()) leafyTreeBranchFrom pass_leaves u = do let new_vector_constraint = vectorLength vector / 1.5 diff --git a/src/AnimationTools.hs b/src/AnimationTools.hs --- a/src/AnimationTools.hs +++ b/src/AnimationTools.hs @@ -9,7 +9,7 @@ import Animation import RSAGL.Animation import RSAGL.FRP -import RSAGL.Modeling.Color +import RSAGL.Color import Control.Arrow import VisibleObject import Models.LibraryData @@ -60,15 +60,15 @@ t_now <- threadTime -< () whenJust (transformA displayA) -< fmap (\o -> (o,(m_atk_time,t_now))) m_orientation returnA -< () - where displayA :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe Time,Time) () + where displayA :: (FRPModel m, FRPModes m ~ RoguestarModes) => FRP e m (Maybe Time,Time) () displayA = proc (m_atk_time,t_now) -> do libraryA -< (scene_layer_local,phase_weapon_model) accumulateSceneA -< (scene_layer_local,lightSource $ case fmap (toSeconds . (t_now `sub`)) m_atk_time of Just t | t < 1.0 -> PointLight { lightsource_position = Point3D 0 0 $ 0.15 + t*t*realToFrac weapon_size, lightsource_radius = measure (Point3D 0 0 $ 0.5*realToFrac weapon_size) (Point3D 0 0 0), - lightsource_color = gray $ 1.0 - t, - lightsource_ambient = gray $ (1.0 - t)^2 } + lightsource_color = grayscale $ 1.0 - t, + lightsource_ambient = grayscale $ (1.0 - t)^2 } _ | otherwise -> NoLight) returnA -< () @@ -91,7 +91,7 @@ do orientation <- m_orientation return (orientation,(Affine id,is_being_wielded)) returnA -< () - where displayA :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m Bool () + where displayA :: (FRPModel m, FRPModes m ~ RoguestarModes) => FRP e m Bool () displayA = scale' (1/75) $ proc is_being_wielded -> do blade_length <- approachFrom 1 (perSecond 65) 0 -< if is_being_wielded then 10 * realToFrac sword_size else 0 libraryA -< (scene_layer_local, diff --git a/src/AnimationVortex.hs b/src/AnimationVortex.hs new file mode 100644 --- /dev/null +++ b/src/AnimationVortex.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE Arrows, TypeFamilies #-} + +module AnimationVortex + (Vortex(..), + vortex, + particleAvatar) + where + +import RSAGL.FRP +import RSAGL.Animation +import RSAGL.Math +import RSAGL.Scene +import RSAGL.Color +import Animation +import Models.LibraryData +import Scene +import Control.Arrow +import CreatureData +import VisibleObject +import System.Random +import Data.List (genericTake) + +-- | A type to represent various vortex-like monsters. +data Vortex = Vortex { + -- | The height of the center of containment sphere of the vortex. + vortex_height :: RSdouble, + -- | The strength of the containment sphere of the vortex. + vortex_containment :: RSdouble, + -- | Atmospheric drag. + vortex_drag :: RSdouble, + -- | Mutual n-to-n attraction of the particles. (can be used at the same time as repulsion) + vortex_binding :: RSdouble, + -- | Mutual n-to-n repulsion of the particles. + vortex_repulsion :: RSdouble, + -- | Enforced rotation of the particles. This can vary as a function of distance + -- from the central axis. + vortex_rotation :: RSdouble -> RSdouble, + -- | The amount of force applied to a particle that violates + -- the base angle. + vortex_base_force :: RSdouble, + -- | A base. At 0 degrees, this simulates the ground, but + -- but at other angles it can enforce a funnel shape. + vortex_base_angle :: Angle, + -- | Gravitational force. + vortex_gravity :: RSdouble } + +vortex :: Vortex +vortex = Vortex { + vortex_height = 0.5, + vortex_containment = 100, + vortex_drag = 1.0, + vortex_binding = 0, + vortex_repulsion = 1.0, + vortex_rotation = const 1.0, + vortex_base_angle = fromDegrees 0, + vortex_base_force = 10, + vortex_gravity = 1.0 } + +vortexForceFunction :: Vortex -> [(Point3D,Rate Vector3D)] -> ForceFunction +vortexForceFunction v particles = + concatForces [ + -- Bind the entire system to the origin of the local coordinate system. + quadraticTrap (vortex_containment v) (Point3D 0 (vortex_height v) 0), + -- Damp down runaway behavior. + drag (vortex_drag v), + -- Repulse points that get too close. + concatForces $ map (\cloud_point -> + constrainForce (\_ p _ -> distanceBetween p cloud_point > 0.001) + (scalarMultiply (-1) $ inverseSquareLaw (vortex_repulsion v) cloud_point)) + (map fst particles), + -- Attract points that wonder too far away. + concatForces $ map (quadraticTrap (vortex_binding v) . fst) particles, + -- Swirl points around the y axis. + \_ p _ -> perSecond $ perSecond $ + (vectorNormalize $ vectorToFrom origin_point_3d p) `crossProduct` + (Vector3D 0 (vortex_rotation v $ distanceBetween origin_point_3d p) 0), + -- Bounce off the ground. + constrainForce (\ _ (Point3D x y z) _ -> + fromDegrees 90 `sub` + angleBetween (vectorToFrom (Point3D x y z) origin_point_3d) + (Vector3D 0 1 0) + < vortex_base_angle v) $ + \_ (Point3D x _ z) _ -> perSecond $ perSecond $ vectorScaleTo (vortex_base_force v) $ + vectorScaleTo (sine $ vortex_base_angle v) (Vector3D (-x) 0 (-z)) `add` + (Vector3D 0 (cosine $ vortex_base_angle v) 0), + \_ _ _ -> perSecond $ perSecond $ Vector3D 0 (negate $ vortex_gravity v) 0 + ] + +glower :: (FRPModel m, FRPModes m ~ RoguestarModes, + ThreadIDOf m ~ Maybe Integer) => + LibraryModel -> FRP e m (Point3D, Rate Vector3D, Acceleration Vector3D) () +glower library_model = proc (p,_,_) -> + do local_origin <- exportToA root_coordinate_system -< origin_point_3d + transformA libraryPointAtCamera -< + (translateToFrom p origin_point_3d $ -- use absolute positioning + translateToFrom local_origin origin_point_3d $ + root_coordinate_system, + (scene_layer_local,library_model)) + returnA -< () + +random_particles :: [(Point3D,Rate Vector3D)] +random_particles = makeAParticle vs + where makeAParticle (a:b:c:d:e:f:xs) = (Point3D a (b+0.5) c,perSecond $ Vector3D d e f) : makeAParticle xs + makeAParticle _ = error "Debauchery is perhaps an act of despair in the face of infinity." + vs = randomRs (-0.5,0.5) $ mkStdGen 5 + +particleAvatar :: (FRPModel m) => Vortex -> Integer -> LibraryModel -> (Maybe RGB) -> CreatureAvatar e m +particleAvatar vortex_spec num_particles library_model m_color = genericCreatureAvatar $ proc () -> + do a <- inertia root_coordinate_system origin_point_3d -< () + particles <- particleSystem fps120 (genericTake num_particles random_particles) -< + \particles -> concatForces [vortexForceFunction vortex_spec particles, \_ _ _ -> a] + glower library_model -< particles !! 0 + glower library_model -< particles !! 1 + glower library_model -< particles !! 2 + glower library_model -< particles !! 3 + glower library_model -< particles !! 4 + glower library_model -< particles !! 5 + glower library_model -< particles !! 6 + glower library_model -< particles !! 7 + accumulateSceneA -< (scene_layer_local, + lightSource $ + case m_color of + Just color -> PointLight (Point3D 0 0.5 0) + (measure (Point3D 0 0.5 0) (Point3D 0 0 0)) + color + color + Nothing -> NoLight) + 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 }) + + diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -1,13 +1,18 @@ module Config - (short_version_string, + (timer_callback_millis, + short_version_string, version_string, - window_name) + window_name, + default_window_size) where import Paths_roguestar_gl import Data.List import Data.Version +timer_callback_millis :: Int +timer_callback_millis = 30 + short_version_string :: String short_version_string = (concat $ intersperse "." $ map show $ versionBranch version) @@ -19,4 +24,7 @@ window_name :: String window_name = "Roguestar-GL " ++ version_string + +default_window_size :: (Integral i) => (i,i) +default_window_size = (800,600) diff --git a/src/CreatureData.hs b/src/CreatureData.hs new file mode 100644 --- /dev/null +++ b/src/CreatureData.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Arrows #-} + +module CreatureData + (CreatureAvatarSwitch, + CreatureAvatar, + genericCreatureAvatar) + where + +import RSAGL.FRP +import RSAGL.Scene +import VisibleObject +import Data.Maybe +import Control.Arrow + +type CreatureAvatarSwitch m = AvatarSwitch () (Maybe CreatureThreadOutput) m +type CreatureAvatar e m = FRP e (AvatarSwitch () (Maybe CreatureThreadOutput) m) () (Maybe CreatureThreadOutput) + +genericCreatureAvatar :: (FRPModel m) => FRP e (CreatureAvatarSwitch m) () CreatureThreadOutput -> CreatureAvatar e m +genericCreatureAvatar creatureA = proc () -> + do visibleObjectHeader -< () + m_orientation <- objectIdealOrientation ThisObject -< () + switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar creatureA,Nothing) else (Nothing,Nothing) + arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_orientation,()) + diff --git a/src/DrawString.hs b/src/DrawString.hs new file mode 100644 --- /dev/null +++ b/src/DrawString.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +module DrawString + (DrawString(..), + stderrDrawString, + glutDrawString + ) + where + +import System.IO + +import qualified Graphics.UI.GLUT as GLUT + +data DrawString = DrawString { + draw_string_font_width :: Int, + draw_string_font_height :: Int, + draw_string_padding :: Int, + drawString :: String -> IO () } + +stderrDrawString :: DrawString +stderrDrawString = DrawString { + draw_string_font_width = 0, + draw_string_font_height = 0, + draw_string_padding = 0, + drawString = hPutStrLn stderr } + +glutDrawString :: DrawString +glutDrawString = DrawString { + draw_string_font_width = 9, + draw_string_font_height = 15, + draw_string_padding = 5, + drawString = GLUT.renderString GLUT.Fixed9By15 } diff --git a/src/Driver.hs b/src/Driver.hs --- a/src/Driver.hs +++ b/src/Driver.hs @@ -19,6 +19,7 @@ import Data.Maybe import System.IO import Tables +import Statistics import RSAGL.FRP.Time import Control.Applicative import Control.Monad.Reader diff --git a/src/EventUtils.hs b/src/EventUtils.hs --- a/src/EventUtils.hs +++ b/src/EventUtils.hs @@ -10,7 +10,10 @@ import Data.Maybe -- | Indicates the most recent time at which the specified creature performed an attack, in thread time. -recentAttack :: (FRPModel m, StateOf m ~ AnimationState, ThreadIDOf m ~ Maybe Integer) => VisibleObjectReference -> FRP e m () (Maybe Time) +recentAttack :: (FRPModel m, + FRPModes m ~ RoguestarModes, + ThreadIDOf m ~ Maybe Integer) => + VisibleObjectReference -> FRP e m () (Maybe Time) recentAttack obj = proc () -> do state <- driverGetAnswerA -< "state" count <- driverGetAnswerA -< "action-count" diff --git a/src/Globals.hs b/src/Globals.hs --- a/src/Globals.hs +++ b/src/Globals.hs @@ -3,7 +3,7 @@ defaultGlobals) where -import RSAGL.Types +import RSAGL.Math.Types import Quality import Control.Concurrent.STM import Control.Applicative diff --git a/src/Initialization.hs b/src/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Initialization.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Arrows, OverloadedStrings #-} + +module Initialization + (initialize, + Initialization(..)) + where + +import PrintText +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 +import Config +import DrawString + +data Initialization = Initialization { + init_opts :: CommandLineOptions, + init_keymap :: Keymap, + init_scene_var :: TVar (Maybe Scene), + init_globals :: Globals, + init_driver_object :: DriverObject, + init_print_text_object :: PrintTextObject, + init_animation_object :: RoguestarAnimationObject, + init_library :: Library, + init_display_statistics :: Statistics, + init_scene_statistics :: Statistics } + +initialize :: DrawString -> [String] -> IO Initialization +initialize draw_strategy args = + do let opts = parseCommandLine args + let keymap = findKeymapOrDefault $ keymap_name opts + scene_var <- newTVarIO Nothing + globals <- defaultGlobals + driver_object <- newDriverObject + print_text_object <- newPrintTextObject draw_strategy + animation_object <- newRoguestarAnimationObject mainAnimationLoop + lib <- newLibrary + display_statistics <- newStatistics "rendering" + scene_statistics <- newStatistics "scene" + return $ Initialization { + init_opts = opts, + init_keymap = keymap, + init_scene_var = scene_var, + init_globals = globals, + init_driver_object = driver_object, + init_print_text_object = print_text_object, + init_animation_object = animation_object, + init_library = lib, + init_display_statistics = display_statistics, + init_scene_statistics = scene_statistics } + diff --git a/src/KeyStroke.hs b/src/KeyStroke.hs new file mode 100644 --- /dev/null +++ b/src/KeyStroke.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} + +module KeyStroke + (KeyStroke(..), + KeyString, + asString, + prettyString, + keyStroke, + KeyStroke.null, + KeyStroke.init, + KeyStroke.length, + KeyStroke.isSuffixOf, + KeyStroke.inits) + where + +import qualified Data.ByteString.Char8 as B +import Data.String +import Data.Char +import Data.Monoid +import qualified Data.List as List + +data KeyStroke = + Stroke Char + | KeyUp + | KeyDown + | KeyLeft + | KeyRight + | KeyActivate -- spacebar, and any enter key + | KeyEscape -- escape, delete, backspace, etc + | KeyTab -- tab and any key that might be used for completions + | KeyAmpersand + | KeySemicolon + | NumPad1 + | NumPad2 + | NumPad3 + | NumPad4 + | NumPad5 + | NumPad6 + | NumPad7 + | NumPad8 + | NumPad9 + | NumPad0 + | KeyIgnored + deriving (Eq,Read,Show) + +newtype KeyString = KeyString { fromKeyString :: [KeyStroke] } + deriving (Eq,Read,Show,Monoid) + +null :: KeyString -> Bool +null = Prelude.null . fromKeyString + +init :: KeyString -> KeyString +init = KeyString . Prelude.init . fromKeyString + +inits :: KeyString -> [KeyString] +inits = map KeyString . List.inits . fromKeyString + +length :: KeyString -> Int +length = Prelude.length . fromKeyString + +isSuffixOf :: KeyString -> KeyString -> Bool +isSuffixOf a b = fromKeyString a `List.isSuffixOf` fromKeyString b + +keyStroke :: KeyStroke -> KeyString +keyStroke s = KeyString [s] + +prettyString :: KeyString -> String +prettyString (KeyString ks) = concatMap f ks + where f (Stroke c) = [c] + f KeyUp = "[UP]" + f KeyDown = "[DOWN]" + f KeyLeft = "[LEFT]" + f KeyRight = "[RIGHT]" + f KeyActivate = "[ENTER]" + f KeyEscape = "[ESC]" + f KeyTab = "^T" + f KeyAmpersand = "&" + f KeySemicolon = ";" + f NumPad1 = "[1]" + f NumPad2 = "[2]" + f NumPad3 = "[3]" + f NumPad4 = "[4]" + f NumPad5 = "[5]" + f NumPad6 = "[6]" + f NumPad7 = "[7]" + f NumPad8 = "[8]" + f NumPad9 = "[9]" + f KeyIgnored = "[IGNORED]" + +asString :: (IsString s) => KeyString -> s +asString = fromString . asString_ + where asString_ (KeyString []) = [] + asString_ (KeyString (Stroke c: rest)) = c:asString (KeyString rest) + asString_ (KeyString (KeyIgnored:rest)) = asString_ (KeyString rest) + asString_ (KeyString (s:rest)) = "&" ++ show s ++ ";" ++ asString (KeyString rest) + +instance IsString KeyString where + fromString s = KeyString $ fromString_ s + +fromString_ :: String -> [KeyStroke] +fromString_ [] = [] +fromString_ ('\n':rest) = KeyActivate:fromString_ rest +fromString_ ('\r':rest) = KeyActivate:fromString_ rest +fromString_ ('\t':rest) = KeyTab:fromString_ rest +fromString_ ('\ESC':rest) = KeyEscape:fromString_ rest +fromString_ ('&':rest) | ';' `elem` rest = + key_string : fromString_ (drop 1 $ dropWhile (/= ';') rest) + where key_string = case map toUpper (takeWhile (/= ';') rest) of + "KEYUP" -> KeyUp + "KEYDOWN" -> KeyDown + "KEYLEFT" -> KeyLeft + "KEYRIGHT" -> KeyRight + "KEYACTIVATE" -> KeyActivate + "KEYESCAPE" -> KeyEscape + "KEYTAB" -> KeyTab + "NUMPAD1" -> NumPad1 + "NUMPAD2" -> NumPad2 + "NUMPAD3" -> NumPad3 + "NUMPAD4" -> NumPad4 + "NUMPAD5" -> NumPad5 + "NUMPAD6" -> NumPad6 + "NUMPAD7" -> NumPad7 + "NUMPAD8" -> NumPad8 + "NUMPAD9" -> NumPad9 + "NUMPAD0" -> NumPad0 + _ -> KeyIgnored +fromString_ ('&':rest) = KeyAmpersand:fromString_ rest +fromString_ (';':rest) = KeySemicolon:fromString_ rest +fromString_ (c:rest) = Stroke c:fromString_ rest + diff --git a/src/Keymaps/CommonKeymap.hs b/src/Keymaps/CommonKeymap.hs --- a/src/Keymaps/CommonKeymap.hs +++ b/src/Keymaps/CommonKeymap.hs @@ -4,6 +4,7 @@ (common_keymap) where +import PrintTextData import Keymaps.Keymaps common_keymap :: Keymap @@ -19,11 +20,14 @@ (":escape","escape"), (":next","next"), (":prev","prev"), - ("\n","select-menu"), - ("\r","select-menu"), - (">:::KeyDown","next"), - (">:::KeyUp","prev"), - ("\ESC","normal"), + (":down","down"), + (":up","up"), + (">","down"), + ("<","up"), + ("&KeyActivate;","select-menu"), + ("&KeyDown;","next"), + ("&KeyUp;","prev"), + ("&KeyEscape;","normal"), (":move","move"), ("t","turn"), (":turn","turn"), @@ -96,15 +100,14 @@ (":fleuret","fleuret"), ("s","sabre"), (":sabre","sabre"), - ("\n","make-end"), - ("\r","make-end"), + ("&KeyActivate;","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"), + ("#quality-bad","quality-bad"), + ("#quality-poor","quality-poor"), + ("#quality-good","quality-good"), + ("#quality-super","quality-super"), (",","pickup"), (":pickup","pickup"), ("d","drop"), diff --git a/src/Keymaps/Keymaps.hs b/src/Keymaps/Keymaps.hs --- a/src/Keymaps/Keymaps.hs +++ b/src/Keymaps/Keymaps.hs @@ -16,74 +16,72 @@ import Control.Monad import Control.Concurrent.STM import qualified Data.ByteString.Char8 as B +import qualified KeyStroke as K +import Data.Monoid -type Keymap = [(B.ByteString,B.ByteString)] +type Keymap = [(K.KeyString,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)] + () | K.null keystrokes -> [] + () | K.length keystrokes == 1 -> [(keystrokes,action_name)] + () -> [(keystrokes `mappend` "&KeyActivate;",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 :: ActionInput -> Keymap -> STM Keymap 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 +-- * blanking the input buffer if there is no possible completion and -- * performing tab complation -filterKeySequence :: ActionInput -> Keymap -> B.ByteString -> STM B.ByteString -filterKeySequence _ _ key_sequence | (length $ B.words key_sequence) /= 1 = return "" +filterKeySequence :: ActionInput -> Keymap -> K.KeyString -> STM K.KeyString +filterKeySequence _ _ key_sequence | + (length $ words $ K.asString 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 is_tab_key_completion = "&KeyTab;" `K.isSuffixOf` key_sequence && + key_sequence /= "&KeyTab;" + let stripped_key_sequence = if is_tab_key_completion + then K.init key_sequence + else key_sequence let possible_completions = - filter (\x -> elem stripped_key_sequence $ B.inits x) $ + filter (\x -> elem (stripped_key_sequence) $ K.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 + _ | not is_tab_key_completion -> 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 + then K.init $ head possible_completions + else stripped_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 + _ -> maximumBy (\x y -> compare (K.length x) (K.length y)) $ + foldr1 intersect $ map K.inits possible_completions --- | 'keysToActionNames' gets a list of the names of all action that could be +-- | 'keysToActionNames' gets a list of the names of all actions 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 :: ActionInput -> Keymap -> K.KeyString -> 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 :: ActionInput -> Keymap -> B.ByteString -> STM [K.KeyString] actionNameToKeys action_input keymap action_name = liftM (map fst . filter (\x -> snd x == action_name)) $ validKeyMap action_input keymap diff --git a/src/Keymaps/NumpadKeymap.hs b/src/Keymaps/NumpadKeymap.hs --- a/src/Keymaps/NumpadKeymap.hs +++ b/src/Keymaps/NumpadKeymap.hs @@ -9,13 +9,13 @@ numpad_keymap :: 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")] + [(">&NumPad8;","n"), + (">&NumPad2;","s"), + (">&NumPad4;","w"), + (">&NumPad6;","e"), + (">&NumPad7;","nw"), + (">&NumPad9;","ne"), + (">&NumPad1;","sw"), + (">&NumPad3;","se"), + (">&NumPad8;","prev"), + (">&NumPad2;","next")] diff --git a/src/Limbs.hs b/src/Limbs.hs --- a/src/Limbs.hs +++ b/src/Limbs.hs @@ -1,7 +1,8 @@ {-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-} module Limbs - (bothArms, + (bothEyeStalks, + bothArms, bothLegs) where @@ -14,25 +15,62 @@ 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 () +-- This scales the pieces of the joint, so that we can re-use the same model for +-- differently-lengthed appendages. +libraryJointAnimation :: (FRPModel m, FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, FRPModes m ~ RoguestarModes) => + 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 + 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 +eyeStalk :: (FRPModel m, FRPModes m ~ RoguestarModes) => + LibraryModel -> LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> + FRP e m () () +eyeStalk stalk_upper stalk_lower eyeball bend_vector root_point maximum_length eyeball_point = proc () -> + do a <- inertia root_coordinate_system eyeball_point -< () + (googly_eye,_,_) <- singleParticle fps120 (eyeball_point, zero) -< concatForces [ + \_ _ _ -> a, + drag 20, + quadraticTrap ((*2000) $ recip $ distanceBetween eyeball_point $ swapX eyeball_point) eyeball_point] + let joint_info = joint bend_vector root_point maximum_length googly_eye + libraryJointAnimation maximum_length stalk_upper stalk_lower -< joint_info + transformA libraryA -< (Affine $ transformation $ joint_arm_hand joint_info, + (std_scene_layer_local,eyeball)) + returnA -< () + +bothEyeStalks :: (FRPModel m, FRPModes m ~ RoguestarModes) => + LibraryModel -> LibraryModel -> LibraryModel -> Vector3D -> Point3D -> RSdouble -> Point3D -> + FRP e m () () +bothEyeStalks stalk_upper stalk_lower eyeball bend_vector root_point maximum_length eyeball_point = proc () -> + do eyeStalk stalk_upper stalk_lower eyeball + bend_vector root_point maximum_length eyeball_point -< () + eyeStalk stalk_upper stalk_lower eyeball + (swapX bend_vector) + (swapX root_point) + maximum_length + (swapX eyeball_point) -< () + +-- | 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 :: (FRPModel m, FRPModes m ~ RoguestarModes, + 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 -< () @@ -47,13 +85,18 @@ 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 :: (FRPModel m, FRPModes m ~ RoguestarModes, + 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. +-- | 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, + FRPModes m ~ RoguestarModes, ThreadIDOf m ~ Maybe Integer, LibraryModelSource lm1, LibraryModelSource lm2) => @@ -86,11 +129,12 @@ -- | Animate legs, which automatically know how to take steps when moved. bothLegs :: (FRPModel m, - StateOf m ~ AnimationState, + FRPModes m ~ RoguestarModes, LibraryModelSource lm1, LibraryModelSource lm2) => lm1 -> lm2 -> + LegStyle -> Vector3D -> Point3D -> RSdouble -> @@ -98,18 +142,21 @@ FRP e m () () bothLegs leg_upper leg_lower + style bend_vector hip_anchor maximum_length foot_rest = proc () -> - do legs [leg bend_vector + do legs [leg style + bend_vector hip_anchor maximum_length foot_rest (libraryJointAnimation maximum_length (toLibraryModel leg_upper) (toLibraryModel leg_lower)), - leg bend_vector + leg style + (swapX bend_vector) (swapX hip_anchor) maximum_length (swapX foot_rest) diff --git a/src/MainGLUT.hs b/src/MainGLUT.hs deleted file mode 100644 --- a/src/MainGLUT.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# 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 -import Config - -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 window_name - 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/Models/Ascendant.hs b/src/Models/Ascendant.hs deleted file mode 100644 --- a/src/Models/Ascendant.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Models.Ascendant - (ascendant_glow) - where - -import RSAGL.Modeling -import RSAGL.Math -import Quality - -ascendant_glow :: Quality -> Modeling () -ascendant_glow _ = - do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 0.25 - material $ emissive $ scaleRGB (1/5) <$> pattern (spherical (Point3D 0 0 0) 0.25 ) [(0.0,pure white),(0.25,pure azure),(1.0,pure blackbody)] - affine $ translate (Vector3D 0 0.25 0) diff --git a/src/Models/Caduceator.hs b/src/Models/Caduceator.hs --- a/src/Models/Caduceator.hs +++ b/src/Models/Caduceator.hs @@ -9,6 +9,7 @@ import RSAGL.Modeling import Quality import Models.Materials +import RSAGL.Color.RSAGLColors caduceator :: Quality -> Modeling () caduceator _ = model $ diff --git a/src/Models/Encephalon.hs b/src/Models/Encephalon.hs --- a/src/Models/Encephalon.hs +++ b/src/Models/Encephalon.hs @@ -6,6 +6,7 @@ import RSAGL.Math import RSAGL.Math.CurveExtras import RSAGL.Modeling +import RSAGL.Color.RSAGLColors import Models.Materials encephalon_head :: Quality -> Modeling () diff --git a/src/Models/EnergyThings.hs b/src/Models/EnergyThings.hs --- a/src/Models/EnergyThings.hs +++ b/src/Models/EnergyThings.hs @@ -7,6 +7,7 @@ import Quality import Data.Monoid import Models.Materials +import RSAGL.Color.RSAGLColors energyCylinder :: (Monoid attr) => EnergyColor -> Quality -> Modeling attr energyCylinder c _ = model $ diff --git a/src/Models/Glows.hs b/src/Models/Glows.hs new file mode 100644 --- /dev/null +++ b/src/Models/Glows.hs @@ -0,0 +1,29 @@ +module Models.Glows + (ascendant_glow, + dust_puff) + where + +import RSAGL.Modeling +import RSAGL.Color +import RSAGL.Color.RSAGLColors +import RSAGL.Math +import Quality + +ascendant_glow :: Quality -> Modeling () +ascendant_glow _ = model $ + do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 0.5 + material $ emissive $ scalarMultiply (1/2) <$> pattern (spherical (Point3D 0 0 0) 0.5 ) + [(0.0,pure white),(0.1,pure light_blue),(1.0,pure blackbody)] + affine $ translate (Vector3D 0 0.25 0) + +dust_puff :: Quality -> Modeling () +dust_puff _ = model $ + do let radius = 0.5 + hemisphere (Point3D 0 0 0) (Vector3D 0 1 0) radius + material $ + do emissive $ scalarMultiply (2/10) <$> pattern (spherical (Point3D 0 (2*radius/3) 0) radius ) + [(0.0,pure light_pink),(0.25,pure light_brown),(1.0,pure blackbody)] + transparent $ pattern (spherical (Point3D 0 (2*radius/3) 0) radius) + [(0.0,pure $ alpha 1.0 $ transformColor light_brown), + (1.0,pure $ alpha 0.0 $ transformColor light_brown)] + diff --git a/src/Models/Hellion.hs b/src/Models/Hellion.hs new file mode 100644 --- /dev/null +++ b/src/Models/Hellion.hs @@ -0,0 +1,45 @@ +module Models.Hellion + (hellion, + hellion_appendage, + hellion_eye) + where + +import RSAGL.Math +import RSAGL.Modeling +import Quality +import Models.Materials +import RSAGL.Math.CurveExtras +import RSAGL.Color.RSAGLColors + +hellion :: Quality -> Modeling () +hellion _ = model $ + do sphere (Point3D 0 0.6 0) 0.1 + hellion_skin + +hellion_appendage :: Quality -> Modeling () +hellion_appendage _ = model $ rotate (Vector3D 1 0 0) (fromDegrees 90) $ + do sor $ linearInterpolation $ + points2d [(0 ,0), + (0.02,0.25), + (0.03,0.5), + (0.02,0.75), + (0.0,1.0)] + hellion_skin + +hellion_eye :: Quality -> Modeling () +hellion_eye _ = model $ + do model $ + do openCone (Point3D 0 0 (-0.1),0) (Point3D 0 0 0.1, 0.1) + hellion_skin + model $ + do hemisphere (Point3D 0 0 0.1) (Vector3D 0 0 1.0) 0.1 + material $ pigment $ pure white + model $ + do perspectiveSphere (Point3D 0 0 0.1) 0.103 (Point3D 0 0 0.25) + material $ pigment $ pure blue -- TODO: vary the eye color! Beware the rare red-eyed hellion! + twoSided True + model $ + do perspectiveSphere(Point3D 0 0 0.1) 0.106 (Point3D 0 0 0.22) + material $ pigment $ pure black + twoSided True + diff --git a/src/Models/Library.hs b/src/Models/Library.hs --- a/src/Models/Library.hs +++ b/src/Models/Library.hs @@ -25,9 +25,10 @@ import Models.Encephalon import Models.Recreant import Models.Androsynth -import Models.Ascendant +import Models.Glows import Models.Caduceator import Models.Reptilian +import Models.Hellion import Models.PhaseWeapons import Models.MachineParts import Models.Sky @@ -35,7 +36,7 @@ import Models.EnergyThings import Models.EnergySwords import Models.Spheres -import Models.Monolith +import Models.Node import Models.Stargate -- | @@ -54,7 +55,9 @@ toModel (SimpleModel Androsynth) = androsynth toModel (SimpleModel Caduceator) = caduceator toModel (SimpleModel Reptilian) = reptilian +toModel (SimpleModel Hellion) = hellion toModel (SimpleModel AscendantGlow) = ascendant_glow +toModel (SimpleModel DustPuff) = dust_puff toModel (SimpleModel PhasePistol) = phase_pistol toModel (SimpleModel Phaser) = phaser toModel (SimpleModel PhaseRifle) = phase_rifle @@ -69,6 +72,8 @@ toModel (SimpleModel ReptilianLegUpper) = reptilian_leg_upper toModel (SimpleModel ReptilianArmLower) = reptilian_arm_lower toModel (SimpleModel ReptilianArmUpper) = reptilian_arm_upper +toModel (SimpleModel HellionAppendage) = hellion_appendage +toModel (SimpleModel HellionEye) = hellion_eye toModel (SimpleModel ThinLimb) = thin_limb toModel (SimpleModel CyborgType4Dome) = cyborg_type_4_dome toModel (SimpleModel CyborgType4Base) = cyborg_type_4_base @@ -80,6 +85,8 @@ toModel (EnergyThing EnergyCylinder c) = energyCylinder c toModel (EnergyThing EnergySword c) = energySword c 3 toModel (SimpleModel Monolith) = monolith +toModel (SimpleModel PlanetaryAnchorCore) = planetary_anchor_core +toModel (SimpleModel PlanetaryAnchorFlange) = planetary_anchor_flange toModel (SimpleModel Portal) = portal -- | diff --git a/src/Models/LibraryData.hs b/src/Models/LibraryData.hs --- a/src/Models/LibraryData.hs +++ b/src/Models/LibraryData.hs @@ -21,8 +21,10 @@ | Recreant | Androsynth | AscendantGlow + | DustPuff | Caduceator | Reptilian + | Hellion -- Tools | PhasePistol | Phaser @@ -39,7 +41,10 @@ | ReptilianLegLower | ReptilianArmUpper | ReptilianArmLower + | HellionAppendage | ThinLimb + -- Other bodyparts + | HellionEye -- Space Ship Parts | CyborgType4Dome | CyborgType4Base @@ -48,6 +53,8 @@ | CyborgType4HyperspaceStabilizer -- Buildings | Monolith + | PlanetaryAnchorCore + | PlanetaryAnchorFlange | Portal deriving (Eq,Ord,Show,Enum,Bounded) diff --git a/src/Models/Materials.hs b/src/Models/Materials.hs --- a/src/Models/Materials.hs +++ b/src/Models/Materials.hs @@ -16,12 +16,16 @@ reptilian_skin, reptilian_pigment, reptilian_specular, + hellion_skin, -- | Material by Energy Type energyColor, energyMaterial) where import RSAGL.Modeling +import RSAGL.Math.AbstractVector +import RSAGL.Color +import RSAGL.Color.RSAGLColors import Models.LibraryData {--------------------------------------------------------- @@ -32,43 +36,42 @@ treaty_metal :: MaterialM attr () treaty_metal = material $ - do pigment $ pure camouflage_green - specular 1 $ pure $ viridian + do pigment $ pure turquoise + specular 1 $ pure $ teal treaty_glow :: MaterialM attr () treaty_glow = material $ do pigment $ pure black - emissive $ pure brass + emissive $ pure mustard treaty_energy_field :: MaterialM attr () treaty_energy_field = material $ - do emissive $ pure brass - specular 1 $ pure saffron + do emissive $ pure mustard -- 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 + do pigment $ pure $ scalarMultiply 0.6 yellow + specular 7 $ pure yellow -- Concordance Materials (violet solid colors, blue energy colors) concordance_metal :: Modeling () concordance_metal = material $ - do pigment $ pure slate_gray + do pigment $ pure mauve specular 4 $ pure lilac concordance_dark_glass :: Modeling () concordance_dark_glass = material $ do pigment $ pure black - specular 8 $ pure eggplant + specular 8 $ pure royal_blue concordance_bright_glass :: Modeling () concordance_bright_glass = material $ do pigment $ pure black - emissive $ pure puce - specular 8 $ pure eggplant + emissive $ pure royal_blue + specular 8 $ pure blue -- Pirates (green solid colors, red energy colors) @@ -81,12 +84,12 @@ -- Cyborg Materials (white solid colors, green energy colors) cyborg_metal :: MaterialM attr () -cyborg_metal = metallic $ pure wheat +cyborg_metal = metallic $ pure beige cyborg_glow :: MaterialM attr () -cyborg_glow = +cyborg_glow = do pigment $ pure blackbody - emissive $ pure $ scaleRGB 1.0 green + emissive $ pure $ scalarMultiply 1.0 pale_green {------------------------------------------------------- - Materials by Species @@ -95,39 +98,46 @@ -- 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)] +caduceator_skin = material $ pigment $ pattern (cloudy 75 0.01) [(0.0,pure red),(0.5,pure 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_pigment = pattern (cloudy 75 0.1) [(0.0,pure lavender),(1.0,pure periwinkle)] reptilian_specular :: ColorFunction RGB -reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure firebrick),(1.0,pure chartreuse)] +reptilian_specular = pattern (cloudy 75 0.1) [(0.0,pure red),(1.0,pure mustard)] reptilian_skin :: Modeling () reptilian_skin = material $ do pigment $ reptilian_pigment specular 5.0 $ reptilian_specular +-- Hellion Skin + +hellion_skin :: Modeling () +hellion_skin = material $ + do pigment $ pattern (cloudy 75 0.1) [(0.0,pure sea_green),(1.0,pure lime)] + specular 5.0 $ scalarMultiply (1/5) pure white + -- Encephalon Skins encephalon_skin :: Modeling () -encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure sepia),(1.0,pure amethyst)] +encephalon_skin = material $ pigment $ pattern (cloudy 32 0.1) [(0.0,pure mauve),(1.0,pure salmon)] {-------------------------------------------------------- - Material by Energy Type - ------------------------------------------------------} energyColor :: EnergyColor -> RGB -energyColor Blue = cobalt -energyColor Yellow = saffron +energyColor Blue = blue +energyColor Yellow = yellow energyColor Red = red -energyColor Green = shamrock +energyColor Green = bright_green 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 + do pigment $ pure $ scalarMultiply 0.33 $ energyColor c + specular 1.0 $ pure $ scalarMultiply 0.33 $ energyColor c + emissive $ pure $ scalarMultiply 0.33 $ energyColor c diff --git a/src/Models/Monolith.hs b/src/Models/Monolith.hs deleted file mode 100644 --- a/src/Models/Monolith.hs +++ /dev/null @@ -1,14 +0,0 @@ -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/Node.hs b/src/Models/Node.hs new file mode 100644 --- /dev/null +++ b/src/Models/Node.hs @@ -0,0 +1,33 @@ +module Models.Node + (monolith, + planetary_anchor_core, + planetary_anchor_flange) + where + +import RSAGL.Math +import RSAGL.Modeling +import RSAGL.Color +import RSAGL.Color.RSAGLColors +import Quality + +monolith :: Quality -> Modeling () +monolith _ = model $ + do box (Point3D (-1/2) 0 (-1/8)) (Point3D (1/2) (9/4) (1/8)) + material $ + do pigment $ pure blackbody + specular 100 $ pure white + +planetary_anchor_core :: Quality -> Modeling () +planetary_anchor_core _ = model $ + do sphere (Point3D 0 0 0) 0.05 + material $ emissive $ pure $ grayscale 0.75 + +planetary_anchor_flange :: Quality -> Modeling () +planetary_anchor_flange _ = model $ + do openDisc (Point3D 0 0 0) + (Vector3D 0 1 0) + 0.20 + 0.21 + material $ emissive $ pure violet + twoSided True + diff --git a/src/Models/QuestionMark.hs b/src/Models/QuestionMark.hs --- a/src/Models/QuestionMark.hs +++ b/src/Models/QuestionMark.hs @@ -3,13 +3,14 @@ where import RSAGL.Modeling +import RSAGL.Color.RSAGLColors import RSAGL.Math import RSAGL.Math.CurveExtras question_mark_material :: Modeling () question_mark_material = material $ do pigment $ pure blackbody - emissive $ pure fuchsia + emissive $ pure hot_pink question_mark :: Modeling () question_mark = model $ scale' 0.1 $ diff --git a/src/Models/Reptilian.hs b/src/Models/Reptilian.hs --- a/src/Models/Reptilian.hs +++ b/src/Models/Reptilian.hs @@ -10,6 +10,7 @@ import RSAGL.Modeling import Quality import Models.Materials +import RSAGL.Color.RSAGLColors import RSAGL.Math.CurveExtras reptilian :: Quality -> Modeling () @@ -54,8 +55,8 @@ (0.75,10.6), (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)] + do pigment $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_pigment),(1.0,pure dark_pink)] + specular 5.0 $ pattern (gradient origin_point_3d (Vector3D 0 10 0)) [(0.0,reptilian_specular),(1.0,pure red)] affine $ scale' (1/10) reptilian_leg_lower :: Quality -> Modeling () @@ -71,8 +72,8 @@ 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) material $ - do pigment $ pure burgundy - specular 5.0 $ pure crimson + do pigment $ pure dark_pink + specular 5.0 $ pure red affine $ scale' (1/10) reptilian_arm_upper :: Quality -> Modeling () @@ -86,8 +87,8 @@ (1.0,9.9), (0 ,0.0)] material $ - do pigment $ pure burgundy - specular 5.0 $ pure crimson + do pigment $ pure dark_pink + specular 5.0 $ pure red affine $ scale' (1/10) reptilian_arm_lower :: Quality -> Modeling () @@ -100,7 +101,7 @@ (0.5,9.9), (0 ,0.0)] material $ - do pigment $ pure burgundy - specular 5.0 $ pure crimson + do pigment $ pure dark_pink + specular 5.0 $ pure red affine $ scale' (1/10) diff --git a/src/Models/Sky.hs b/src/Models/Sky.hs --- a/src/Models/Sky.hs +++ b/src/Models/Sky.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, PatternGuards #-} module Models.Sky (SkyInfo(..),default_sky, @@ -19,10 +19,12 @@ import RSAGL.Extras.ColorPhysics import RSAGL.Modeling import RSAGL.Modeling.Noise +import RSAGL.Color +import RSAGL.Color.RSAGLColors import Scene import Data.Monoid -import RSAGL.Types import qualified Data.ByteString as B +import Data.Maybe data SkyInfo = SkyInfo { sky_info_biome :: B.ByteString, @@ -51,19 +53,21 @@ sky_info_solar_kelvins = 5800 } default_sun :: SunInfo -default_sun = sunInfoOf default_sky +default_sun = fromMaybe (error "Nothing: default_sun") $ sunInfoOf default_sky -- | generates a 'SunInfo' from a 'SkyInfo' -sunInfoOf :: SkyInfo -> SunInfo -sunInfoOf sky_info = SunInfo { - sun_info_size_adjustment = abs (sky_info_degrees_latitude sky_info) + (fst $ biomeAtmosphere $ sky_info_biome sky_info), - sun_info_kelvins = sky_info_solar_kelvins sky_info } +sunInfoOf :: SkyInfo -> Maybe SunInfo +sunInfoOf sky_info = + do temperature_adjustment <- fst $ biomeAtmosphere $ sky_info_biome sky_info + return $ SunInfo { + sun_info_size_adjustment = abs (sky_info_degrees_latitude sky_info) + temperature_adjustment, + sun_info_kelvins = sky_info_solar_kelvins sky_info } medium_atmosphere :: Atmosphere medium_atmosphere = [ AtmosphereLayer Air 0.75 9.0e-4, AtmosphereLayer Vapor 0.25 2.5e-4, - AtmosphereLayer (Dust $ gray 0.5) 0.01 1.0e-4 ] + AtmosphereLayer (Dust $ grayscale 0.5) 0.01 1.0e-4 ] thin_atmosphere :: Atmosphere thin_atmosphere = [ @@ -74,27 +78,40 @@ thick_atmosphere = [ AtmosphereLayer Air 1.5 9.0e-4, AtmosphereLayer Vapor 1.0 2.5e-4, - AtmosphereLayer (Dust $ gray 0.5) 0.02 1.0e-4 ] + AtmosphereLayer (Dust $ grayscale 0.5) 0.02 1.0e-4 ] arid_atmosphere :: Atmosphere arid_atmosphere = [ AtmosphereLayer Air 0.05 2.5e-3, - AtmosphereLayer (Dust $ rust) 0.1 1.0e-3 ] + AtmosphereLayer (Dust maroon) 0.1 1.0e-3 ] -biomeAtmosphere :: B.ByteString -> (Integer,Atmosphere) -biomeAtmosphere "rockbiome" = (0,arid_atmosphere) -biomeAtmosphere "icyrockbiome" = (-100,thin_atmosphere) -biomeAtmosphere "grasslandbiome" = (35,medium_atmosphere) -biomeAtmosphere "tundrabiome" = (-75,thin_atmosphere) -biomeAtmosphere "desertbiome" = (100,arid_atmosphere) -biomeAtmosphere "oceanbiome" = (5,medium_atmosphere) -biomeAtmosphere "mountainbiome" = (-15,thin_atmosphere) -biomeAtmosphere "swampbiome" = (35,thick_atmosphere) -biomeAtmosphere _ = (0,[]) +hot_pink_atmosphere :: Atmosphere +hot_pink_atmosphere = [ + AtmosphereLayer (Fog hot_pink) 0.1 1.0e-3] +-- Answers a temperature adjustment and a atmospheric model, for rendering the sun and sky. +-- If there is no temperature adjustment, there will be no sun, and likewise if there +-- is no atmosphere model, there will be no (rendered) atmosphere. +biomeAtmosphere :: B.ByteString -> (Maybe Integer,Maybe Atmosphere) +biomeAtmosphere "shallowdungeon" = (Nothing,Nothing) +biomeAtmosphere "deepdungeon" = (Nothing,Nothing) +biomeAtmosphere "frozendungeon" = (Nothing,Nothing) +biomeAtmosphere "abyssaldungeon" = (Nothing,Nothing) +biomeAtmosphere "infernaldungeon" = (Nothing,Nothing) +biomeAtmosphere "rockbiome" = (Just 0,Just arid_atmosphere) +biomeAtmosphere "icyrockbiome" = (Just (-100),Just thin_atmosphere) +biomeAtmosphere "grasslandbiome" = (Just 35,Just medium_atmosphere) +biomeAtmosphere "tundrabiome" = (Just (-75),Just thin_atmosphere) +biomeAtmosphere "desertbiome" = (Just 100,Just arid_atmosphere) +biomeAtmosphere "oceanbiome" = (Just 5,Just medium_atmosphere) +biomeAtmosphere "mountainbiome" = (Just (-15),Just thin_atmosphere) +biomeAtmosphere "swampbiome" = (Just 35,Just thick_atmosphere) +biomeAtmosphere "nothing" = (Nothing,Nothing) +biomeAtmosphere _ = (Nothing,Just hot_pink_atmosphere) + -- | 'sunVectorOf' indicates vector pointing at the sun. sunVector :: SkyInfo -> Vector3D -sunVector sky_info = +sunVector sky_info = rotate (Vector3D 1 0 0) (fromDegrees $ (realToFrac $ sky_info_degrees_latitude sky_info) + (cosine $ fromDegrees $ realToFrac $ sky_info_degrees_orbital sky_info) * (realToFrac $ sky_info_degrees_axial_tilt sky_info)) $ @@ -104,7 +121,8 @@ -- | Apparent temperature of a color in kelvins. temperatureColor :: Integer -> RGB temperatureColor kelvins = lerpBetweenClamped (770,realToFrac kelvins,1060) - (gray 0,maximizeRGB $ blackBodyRGB $ realToFrac kelvins) + (grayscale 0,adjustColor channel_value maximize $ + blackBodyRGB $ realToFrac kelvins) -- | Apparent color of light comming from the sun. sunColor :: SunInfo -> RGB @@ -120,62 +138,75 @@ -- | 'makeSky' generates a sky sphere. makeSky :: SkyInfo -> Modeling () -makeSky sky_info = model $ - do hilly_silhouette +makeSky sky_info | Just atmo <- snd $ biomeAtmosphere $ sky_info_biome sky_info = model $ + do hilly_silhouette model $ do let v = sunVector sky_info skyHemisphere origin_point_3d (Vector3D 0 1 0) 5.0 affine $ scale (Vector3D 2 1 2) - material $ atmosphereScatteringMaterial (snd $ biomeAtmosphere $ sky_info_biome sky_info) - [(v,maximizeRGB $ blackBodyRGB $ realToFrac $ sky_info_solar_kelvins sky_info)] - (dynamicSkyFilter 0.05 0.5) + material $ atmosphereScatteringMaterial + atmo + [(v,adjustColor channel_value maximize $ + blackBodyRGB $ realToFrac $ + sky_info_solar_kelvins sky_info)] + (dynamicSkyFilter 0.05 0.5) +makeSky _ = return () --- | Implements absorbtion of light sources passing through the sky sphere. In particular, this turns off all lights --- inside 'scene_layer_sky_sphere'. +-- | Implements absorbtion of light sources passing through the sky sphere. +-- In particular, this turns off all lights inside 'scene_layer_sky_sphere'. skyAbsorbtionFilter :: SkyInfo -> LightSourceLayerTransform skyAbsorbtionFilter sky_info = LightSourceLayerTransform $ \entering_layer originating_layer ls -> let v = direction ls in case () of () | entering_layer == scene_layer_sky_sphere || isNoLight ls -> NoLight () | originating_layer <= scene_layer_sky_sphere || entering_layer > scene_layer_sky_sphere || originating_layer <= entering_layer -> ls - () | originating_layer == scene_layer_distant && entering_layer == scene_layer_orbit -> mapLightSource (mapBoth $ scaleRGB $ sunlightFadeFactor (fromDegrees 30) v) ls + () | originating_layer == scene_layer_distant && entering_layer == scene_layer_orbit -> mapLightSource (mapBoth $ scalarMultiply $ sunlightFadeFactor (fromDegrees 30) v) ls () | entering_layer == scene_layer_far_sky -> sunFade (fromDegrees 10) v ls () | entering_layer == scene_layer_clouds -> sunFade (fromDegrees 5) v ls () | entering_layer == scene_layer_near_sky -> sunFade (fromDegrees 2) v ls () | otherwise -> sunFade (fromDegrees 0) v ls - where absorbtion v = filterRGB $ (absorbtionFilter . absorbtionFilter) $ atmosphereAbsorbtion (snd $ biomeAtmosphere $ sky_info_biome sky_info) (Point3D 0 1 0) v + where absorbtion v = filterRGB $ (absorbtionFilter . absorbtionFilter) $ atmosphereAbsorbtion (fromMaybe mempty $ snd $ biomeAtmosphere $ sky_info_biome sky_info) (Point3D 0 1 0) v direction (PointLight { lightsource_position = p }) = vectorToFrom p origin_point_3d direction (DirectionalLight { lightsource_direction = d }) = d direction NoLight = Vector3D 0 1 0 - sunFade tolerance v = mapLightSource (mapBoth (absorbtion v) `mappend` mapBoth (scaleRGB $ sunlightFadeFactor tolerance v)) + sunFade tolerance v = mapLightSource (mapBoth (absorbtion v) `mappend` mapBoth (scalarMultiply $ sunlightFadeFactor tolerance v)) -- | The amount of fade of the sun based on falling below the horizon. sunlightFadeFactor :: Angle -> Vector3D -> RSdouble sunlightFadeFactor tolerance v = max 0 $ lerpBetweenClamped (85,toDegrees $ angleBetween v (Vector3D 0 1 0),95+toDegrees tolerance) (1.0,0.0) --- | Information about the lighting environment. All values are between 0 and 1, indicating a relative scale compared to the normal, full brightness. +-- | Information about the lighting environment. All values are between 0 and 1, indicating a +-- relative scale compared to the normal, full brightness. data LightingConfiguration = LightingConfiguration { - -- | Apparent brightness of the sun. This will fade to zero along the horizon and equal zero at night. - lighting_sunlight, - -- | Apparent brightness of ambient sky radiation. This will fade to black more slowly than 'lighting_sunlight', lingering after the sun has set. - lighting_skylight, - -- | Apparent brightness of the nightlight. This is a blue light with heavy ambient component that simulates human night vision. - lighting_nightlight, - -- | Brightness of artificial lights. Typically all artificial lights intended for nighttime illumination should be scaled based on this value. + -- | Apparent brightness of the sun. This will fade to zero along the horizon and equal zero at + -- night. + lighting_sunlight, + -- | Apparent brightness of ambient sky radiation. This will fade to black more slowly than + -- 'lighting_sunlight', lingering after the sun has set. + lighting_skylight, + -- | Apparent brightness of the nightlight. This is a blue light with heavy ambient component + -- that simulates human night vision. + lighting_nightlight, + -- | Brightness of artificial lights. Typically all artificial lights intended for nighttime + -- illumination should be scaled based on this value. lighting_artificial :: RSdouble } lightingConfiguration :: SkyInfo -> LightingConfiguration lightingConfiguration sky_info = result - where result = LightingConfiguration { - lighting_sunlight = sunlightFadeFactor (fromDegrees 0) (sunVector sky_info), - lighting_skylight = sunlightFadeFactor (fromDegrees 10) (sunVector sky_info), + where sunlight_intensity = linear_value $ viewChannel channel_luminance $ + maybe blackbody sunColor $ sunInfoOf sky_info + result = LightingConfiguration { + lighting_sunlight = sunlightFadeFactor (fromDegrees 0) (sunVector sky_info) * sunlight_intensity, + lighting_skylight = sunlightFadeFactor (fromDegrees 10) (sunVector sky_info) * sunlight_intensity, lighting_nightlight = max 0 $ 1.0 - lighting_sunlight result - lighting_skylight result, lighting_artificial = min 1 $ max 0 $ 1.0 - lighting_sunlight result - (lighting_nightlight result/4) + (1000 / realToFrac (sky_info_solar_kelvins sky_info))^3 } -- | Get the color of the ambient sky radiation by sampling a very small number vectors into the sky. ambientSkyRadiation :: SkyInfo -> RGB +ambientSkyRadiation sky_info | Nothing <- snd $ biomeAtmosphere $ sky_info_biome sky_info = blackbody +ambientSkyRadiation sky_info | Nothing <- fst $ biomeAtmosphere $ sky_info_biome sky_info = blackbody ambientSkyRadiation sky_info = abstractAverage $ map (atmosphereScattering atmosphere [sun_info] (Point3D 0 1 0)) test_vectors - where atmosphere = snd $ biomeAtmosphere $ sky_info_biome sky_info - sun_info = (sunVector sky_info,sunColor $ sunInfoOf sky_info) + where atmosphere = fromMaybe mempty $ snd $ biomeAtmosphere $ sky_info_biome sky_info + sun_info = (sunVector sky_info,maybe blackbody sunColor $ sunInfoOf sky_info) test_vectors = map vectorNormalize $ do x <- [1,0,-1] y <- [1,0,-1] @@ -190,7 +221,7 @@ [(0.0,pure $ temperatureColor $ t + 700),(0.5,pure $ temperatureColor t),(1.0,pure $ temperatureColor $ t - 700)] perspectiveSphere (Point3D 0 (-10) 0) size origin_point_3d material $ - do pigment $ pure $ gray 0 + do pigment $ pure $ grayscale 0 emissive $ pattern (spherical (Point3D 0 (size-10) 0) size) [(0.0,temperaturePattern temp), (0.5,temperaturePattern $ temp - 200), (0.75,temperaturePattern $ temp - 500), diff --git a/src/Models/Spheres.hs b/src/Models/Spheres.hs --- a/src/Models/Spheres.hs +++ b/src/Models/Spheres.hs @@ -9,12 +9,14 @@ import RSAGL.Math import Models.Materials import Models.LibraryData +import RSAGL.Color +import RSAGL.Color.RSAGLColors -- | An empty (or transparent) gas sphere. gasSphere :: Quality -> Modeling () gasSphere _ = model $ do sphere (Point3D 0 0.06 0) 0.06 - material $ + material $ do transparent $ pure $ rgba 0.9 0.9 0.9 0.25 specular 10 $ pure white diff --git a/src/Models/Terrain.hs b/src/Models/Terrain.hs --- a/src/Models/Terrain.hs +++ b/src/Models/Terrain.hs @@ -5,11 +5,15 @@ terrainTile) where +import Prelude hiding (tan) import Quality import Models.RecreantFactory import RSAGL.Modeling import RSAGL.Math -import RSAGL.Types +import RSAGL.Math.Types +import RSAGL.Color +import RSAGL.Color.RSAGLColors +import RSAGL.Extras.ColorPhysics import qualified Data.ByteString.Char8 as B -- | @@ -31,7 +35,9 @@ "rockyground", "rubble", "rockface", - "recreantfactory"] + "recreantfactory", + "downstairs", + "upstairs"] -- | -- A simple 1-by-1 square patch, centered at the origin, and raised on a slope toward it's center. @@ -68,6 +74,41 @@ terrainTile "rockface" q = model $ do terrainTileShape (terrainHeight "rockface") (terrainHeight "rockface") q material $ terrainTexture "rockface" +terrainTile "downstairs" q = model $ + do basicTerrainTile "downstairs" q + model $ + do box (Point3D (-0.5) 0 (-0.5)) (Point3D 0.5 0.05 (-0.45)) + box (Point3D (-0.5) 0 0.5) (Point3D 0.5 0.05 0.45) + box (Point3D (-0.5) 0 0.5) (Point3D (-0.45) 0.05 (-0.5)) + box (Point3D 0.5 0 0.5) (Point3D 0.45 0.05 (-0.5)) + material $ pigment $ pure tan +terrainTile "upstairs" q = model $ + do basicTerrainTile "rockyground" q + model $ + do quadralateral (Point3D (-0.5) 0 (-0.5)) + (Point3D 0.5 0 (-0.5)) + (Point3D 0.5 4 (-0.5)) + (Point3D (-0.5) 4 (-0.5)) + quadralateral (Point3D (-0.5) 0 0.5) + (Point3D 0.5 0 0.5) + (Point3D 0.5 4 0.5) + (Point3D (-0.5) 4 0.5) + quadralateral (Point3D (-0.5) 0 (-0.5)) + (Point3D (-0.5) 0 0.5) + (Point3D (-0.5) 4 0.5) + (Point3D (-0.5) 4 (-0.5)) + quadralateral (Point3D 0.5 0 (-0.5)) + (Point3D 0.5 0 0.5) + (Point3D 0.5 4 0.5) + (Point3D 0.5 4 (-0.5)) + twoSided True + material $ emissive $ pattern + (gradient (Point3D 0 0 0) (Vector3D 0 4 0)) + [(0.00,pure $ scalarMultiply 0.4 $ adjustColor channel_value maximize $ blackBodyRGB 4800), + (0.25,pure $ scalarMultiply 0.3 $ adjustColor channel_value maximize $ blackBodyRGB 5050), + (0.50,pure $ scalarMultiply 0.2 $ adjustColor channel_value maximize $ blackBodyRGB 5300), + (0.75,pure $ scalarMultiply 0.1 $ adjustColor channel_value maximize $ blackBodyRGB 5550), + (1.00,pure $ scalarMultiply 0.0 $ adjustColor channel_value maximize $ blackBodyRGB 5800)] terrainTile s q = basicTerrainTile s q -- | @@ -91,6 +132,7 @@ terrainHeight "rockyground" = 0.18 terrainHeight "rubble" = 0.2 terrainHeight "rockface" = 1.0 +terrainHeight "downstairs" = 0.01 terrainHeight _ = 5.0 -- | @@ -103,26 +145,27 @@ do pigment $ pure blue specular 100 $ pure white terrainTexture "deepwater" = - do pigment $ pure $ scaleRGB 0.8 blue + do pigment $ pure royal_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 "sand" = pigment $ pure beige +terrainTexture "desert" = pigment $ pure $ lerp 0.5 (light_brown,white) +terrainTexture "grass" = pigment $ pure green terrainTexture "dirt" = pigment $ pure brown -terrainTexture "forest" = pigment $ pure fern_green -terrainTexture "deepforest" = pigment $ pure fern_green +terrainTexture "forest" = pigment $ pure olive_green +terrainTexture "deepforest" = pigment $ pure olive_green terrainTexture "ice" = do pigment $ pure white specular 1 $ pure teal terrainTexture "lava" = do pigment $ pure blackbody - emissive $ pure coral + emissive $ pure red 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 "rockyground" = pigment $ pure grey +terrainTexture "rubble" = pigment $ pure grey +terrainTexture "rockface" = pigment $ pure grey +terrainTexture "downstairs" = pigment $ pure blackbody terrainTexture _ = do pigment $ pure blackbody emissive $ pure magenta diff --git a/src/Models/Tree.hs b/src/Models/Tree.hs --- a/src/Models/Tree.hs +++ b/src/Models/Tree.hs @@ -3,6 +3,7 @@ where import RSAGL.Modeling +import RSAGL.Color.RSAGLColors import RSAGL.Math leafy_blob :: ModelingM () () @@ -13,5 +14,5 @@ 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 + material $ pigment $ pure brown diff --git a/src/PrintText.hs b/src/PrintText.hs --- a/src/PrintText.hs +++ b/src/PrintText.hs @@ -5,51 +5,50 @@ module PrintText (newPrintTextObject, printText, + setStatus, PrintTextObject, renderText, PrintTextMode(..), TextType(..), getInputBuffer, + pushInputBuffer, pullInputBuffer, setInputBuffer, setPrintTextMode, clearOutputBuffer, - clearInputBuffer, - keyCallback) + clearInputBuffer) where import Control.Concurrent.STM -import Graphics.UI.GLUT as GLUT +import Graphics.Rendering.OpenGL as GL import PrintTextData import Control.Monad import Control.Concurrent.Chan import qualified Data.ByteString.Char8 as B +import qualified Data.Map as Map +import RSAGL.Color +import RSAGL.Color.RSAGLColors +import qualified KeyStroke as K +import DrawString +import Data.Monoid 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 + text_input_buffer :: K.KeyString, + text_status_lines :: Map.Map StatusField B.ByteString, + text_output_mode :: PrintTextMode, + text_draw_strategy :: DrawString } -font :: BitmapFont -font = Fixed9By15 +data PrintTextObject = PrintTextObject (TVar PrintTextData) (Chan K.KeyString) -newPrintTextObject :: IO PrintTextObject -newPrintTextObject = +newPrintTextObject :: DrawString -> IO PrintTextObject +newPrintTextObject draw_strategy = do pt_data <- newTVarIO $ PrintTextData { text_output_buffer = [], - text_input_buffer = B.empty, - text_output_mode = Unlimited } + text_input_buffer = mempty, + text_status_lines = Map.empty, + text_output_mode = Unlimited, + text_draw_strategy = draw_strategy } pt_chan <- newChan return $ PrintTextObject pt_data pt_chan @@ -60,14 +59,21 @@ 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 () +setStatus :: PrintTextObject -> Map.Map StatusField B.ByteString -> STM () +setStatus p@(PrintTextObject pto _) status_lines = + do print_text <- readTVar pto + let changes = Map.differenceWith + (\new old -> if new==old then Nothing else Just new) + status_lines + (text_status_lines print_text) + forM_ (Map.toAscList changes) $ \(field,string) -> + printText p Update $ onChange field string + writeTVar pto . (\x -> x { text_status_lines = status_lines }) =<< readTVar pto -getInputBuffer :: PrintTextObject -> IO B.ByteString +pushInputBuffer :: PrintTextObject -> K.KeyStroke -> IO () +pushInputBuffer (PrintTextObject _ chan) stroke = writeChan chan (K.keyStroke stroke) + +getInputBuffer :: PrintTextObject -> IO K.KeyString getInputBuffer (PrintTextObject pto _) = liftM text_input_buffer $ atomically $ readTVar pto @@ -76,15 +82,15 @@ pullInputBuffer (PrintTextObject pto chan) = do e <- isEmptyChan chan when (not e) $ - do r <- readChan chan + do stroke <- readChan chan atomically $ do print_text <- readTVar pto writeTVar pto $ print_text { text_input_buffer = text_input_buffer print_text - `B.append` r } + `mappend` stroke } return () -setInputBuffer :: PrintTextObject -> B.ByteString -> IO () +setInputBuffer :: PrintTextObject -> K.KeyString -> IO () setInputBuffer (PrintTextObject pto _) new_input_buffer = atomically $ do print_text <- readTVar pto writeTVar pto $ print_text { text_input_buffer = new_input_buffer } @@ -102,74 +108,96 @@ clearInputBuffer :: PrintTextObject -> IO () clearInputBuffer (PrintTextObject pto _) = atomically $ do print_text <- readTVar pto - writeTVar pto $ print_text { text_input_buffer = B.empty } + writeTVar pto $ print_text { text_input_buffer = mempty } -renderText :: PrintTextObject -> IO () -renderText (PrintTextObject pto _) = +renderText :: Size -> PrintTextObject -> IO () +renderText (Size width height) (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 draw_strategy = text_draw_strategy ptd let max_characters_height = - (fromIntegral height - 2 * fromIntegral padding_pixels) `div` - (fromIntegral font_height_pixels) + (fromIntegral height - 2 * fromIntegral (draw_string_padding draw_strategy)) `div` + (fromIntegral (draw_string_font_height draw_strategy)) let max_characters_width = - (fromIntegral width - 2 * fromIntegral padding_pixels) `div` - (fromIntegral font_width_pixels) + (fromIntegral width - 2 * fromIntegral (draw_string_padding draw_strategy)) `div` + (fromIntegral (draw_string_font_width draw_strategy)) let lines_to_print = restrictLines max_characters_height max_characters_width $ (case (text_output_mode ptd) of PrintTextData.Disabled -> [] - Limited -> reverse $ take 3 $ reverse $ + Limited -> reverse $ take 5 $ reverse $ text_output_buffer ptd Unlimited -> (text_output_buffer ptd)) ++ - (if B.length (text_input_buffer ptd) > 0 || + (if K.length (text_input_buffer ptd) > 0 || text_output_mode ptd /= PrintTextData.Disabled - then [(Query,"> " `B.append` (text_input_buffer ptd))] + then [(Input,"> " `B.append` (B.pack $ K.prettyString $ 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 + let status_lines = flip map (Map.toAscList $ text_status_lines ptd) $ + \(field,string) -> (Update,whileActive field string) + drawLines (Size width height) (reverse lines_to_print) Log draw_strategy + drawLines (Size width height) (reverse status_lines) Status draw_strategy + +data PrintTextPosition = Status | Log + +drawLines :: Size -> + [(TextType,B.ByteString)] -> + PrintTextPosition -> + DrawString -> + IO () +drawLines (Size width height) lines_to_print position draw_strategy = + do save_depth_func <- get depthFunc + save_depth_mask <- get depthMask + save_blend <- get blend + depthFunc $= Nothing + depthMask $= GL.Disabled + blend $= Enabled + matrixMode $= Projection + loadIdentity + ortho2D 0 (fromIntegral width) 0 (fromIntegral height) + matrixMode $= Modelview 0 + loadIdentity + let actual_width_pixels :: Int + actual_width_pixels = draw_string_font_width draw_strategy * + (maximum $ map (B.length . snd) $ (undefined,""):lines_to_print) + let actual_height_pixels :: Int + actual_height_pixels = draw_string_font_height draw_strategy * (length lines_to_print) + let y_position :: Int + y_position = case position of + Status -> fromIntegral height - actual_height_pixels - (draw_string_padding draw_strategy) + Log -> draw_string_padding draw_strategy + color $ (Color4 0 0 0 0.92 :: Color4 GLfloat) + (rect :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()) + (Vertex2 (fromIntegral (draw_string_padding draw_strategy)) + (fromIntegral y_position)) + (Vertex2 (fromIntegral (actual_width_pixels + + (draw_string_padding draw_strategy))) + (fromIntegral (actual_height_pixels + + y_position + + (draw_string_padding draw_strategy)*2))) + currentRasterPosition $= (Vertex4 (fromIntegral $ draw_string_padding draw_strategy) + (fromIntegral $ y_position + draw_string_padding draw_strategy) + 0 1) + mapM_ (drawLine draw_strategy) 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) +drawLine :: DrawString -> (TextType,B.ByteString) -> IO () +drawLine draw_strategy (textType,str) = + do (Vertex4 x y _ _) <- get currentRasterPosition + color $ colorToOpenGL $ textTypeToColor textType + currentRasterPosition $= (Vertex4 x y 0 1) + drawString draw_strategy $ B.unpack str + currentRasterPosition $= (Vertex4 x (y + fromIntegral (draw_string_font_height draw_strategy)) 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 +textTypeToColor :: TextType -> RGB +textTypeToColor UnexpectedEvent = orange +textTypeToColor Event = yellow +textTypeToColor Input = white +textTypeToColor Query = grey +textTypeToColor Update = light_brown diff --git a/src/PrintTextData.hs b/src/PrintTextData.hs --- a/src/PrintTextData.hs +++ b/src/PrintTextData.hs @@ -1,19 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + module PrintTextData (PrintTextMode(..), - TextType(..)) + TextType(..), + StatusField(..), + onChange, + whileActive) where +import qualified Data.ByteString.Char8 as B + -- | 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) + | 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 +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 + | Update -- ^ a change in an ongoing status condition + +data StatusField = + PlanetName + | CompassHeading + | DungeonDepth + deriving (Eq,Ord) + +-- | Message to print when a piece of status information changes. +onChange :: StatusField -> B.ByteString -> B.ByteString +onChange PlanetName s = "Welcome to " `B.append` s `B.append` "." +onChange CompassHeading s = "Your compass is now pointing " `B.append` s `B.append` "." +onChange DungeonDepth s = "You are now on dungeon level: " `B.append` s `B.append` "." + +-- | Continuous status messages. +whileActive :: StatusField -> B.ByteString -> B.ByteString +whileActive PlanetName s = "Planet: " `B.append` s +whileActive CompassHeading s = "Compass: " `B.append` s +whileActive DungeonDepth s = "Depth: " `B.append` s + diff --git a/src/Processes.hs b/src/Processes.hs new file mode 100644 --- /dev/null +++ b/src/Processes.hs @@ -0,0 +1,118 @@ +module Processes + (sceneLoop, + watchQuit, + display) + where + +import Initialization +import Globals +import Control.Concurrent +import Control.Concurrent.STM +import System.Timeout +import Control.Monad +import Data.Maybe +import Statistics +import Animation +import System.IO +import System.Exit +import Graphics.Rendering.OpenGL.GL +import RSAGL.Scene +import PrintText +import Actions +import Keymaps.Keymaps + +-- | Performs the listen-animate loop. Should be called +-- exactly once per program instance. +sceneLoop :: Initialization -> IO () +sceneLoop init_vars = liftM (const ()) $ forkIO $ forever $ + do dispatchKeyInput init_vars + atomically $ + do b <- liftM isJust $ readTVar $ init_scene_var init_vars + when b retry + result <- timeout 20000000 $ + do scene <- runStatistics (init_scene_statistics init_vars) $ + runRoguestarAnimationObject + (init_library init_vars) + (init_globals init_vars) + (init_driver_object init_vars) + (init_print_text_object init_vars) + (init_animation_object init_vars) + atomically $ writeTVar (init_scene_var init_vars) $ 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 () + +-- | Update aspect ratio, when it changes. +reshape :: Size -> IO () +reshape (Size width height) = + do mat_mode <- get matrixMode + matrixMode $= Projection + loadIdentity + viewport $= (Position 0 0,Size width height) + matrixMode $= mat_mode + +-- | Monitors the 'global_should_quit' variable, +-- and forcably terminates the application if +-- it is set. +-- +-- Needs to be called from the main thread, or has +-- no effect. +watchQuit :: Initialization -> IO () +watchQuit init_values = + do q <- atomically $ readTVar $ global_should_quit $ init_globals init_values + when q $ exitWith ExitSuccess + +-- | Performs the display action. This must +-- be executed in the event loop of the widget toolkit, +-- since OpenGL isn't thread safe. +display :: Size -> Initialization -> IO () +display (Size width height) init_vars = + do reshape (Size width height) + scene <- atomically $ + do result <- maybe retry return =<< readTVar (init_scene_var init_vars) + writeTVar (init_scene_var init_vars) Nothing + return result + result <- timeout 20000000 $ + do color (Color4 0 0 0 0 :: Color4 GLfloat) + clear [ColorBuffer] + runStatistics (init_display_statistics init_vars) $ + do sceneToOpenGL (fromIntegral width / fromIntegral height) + (0.1,80.0) + scene + renderText (Size width height) $ + init_print_text_object init_vars + 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 () + +dispatchKeyInput :: Initialization -> IO () +dispatchKeyInput init_vars = + do result <- timeout 20000000 $ + do let action_input = ActionInput (init_globals init_vars) + (init_driver_object init_vars) + (init_print_text_object init_vars) + pullInputBuffer (init_print_text_object init_vars) + buffer_contents <- getInputBuffer (init_print_text_object init_vars) + (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 + (init_keymap init_vars) + buffer_contents + else return False + filtered <- filterKeySequence action_input + (init_keymap init_vars) + buffer_contents + return $ if worked + then clearInputBuffer (init_print_text_object init_vars) + else setInputBuffer (init_print_text_object init_vars) + filtered + 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 () + diff --git a/src/RenderingControl.hs b/src/RenderingControl.hs --- a/src/RenderingControl.hs +++ b/src/RenderingControl.hs @@ -8,6 +8,7 @@ import RSAGL.FRP import RSAGL.Math import RSAGL.Modeling +import RSAGL.Color import Animation import Control.Arrow import Data.Maybe @@ -26,8 +27,7 @@ import AnimationMenus import AnimationExtras import AnimationEvents -import Strings -import RSAGL.Types +import PrintTextData import qualified Data.ByteString.Char8 as B -- | Enters the top-level animation loop. @@ -39,14 +39,24 @@ returnA -< roguestarSceneLayerInfo mempty basic_camera where mainWelcome = proc () -> do printTextOnce -< Just (Event,"Welcome to Roguestar-GL.") - returnA -< () + 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 -< () + do result <- frp1Context (mainStateHeader (const False) >>> + arr (const $ roguestarSceneLayerInfo mempty basic_camera)) -< () + m_planet_name <- sticky isJust Nothing <<< driverGetAnswerA -< "planet-name" + statusA -< fmap ((,) PlanetName) $ case m_planet_name of + Just "nothing" -> Nothing + x -> x + m_dungeon_depth <- sticky isJust Nothing <<< driverGetAnswerA -< "dungeon-depth" + statusA -< fmap ((,) DungeonDepth) m_dungeon_depth + m_compass <- sticky isJust Nothing <<< driverGetAnswerA -< "compass" + statusA -< fmap ((,) CompassHeading) $ case m_compass of + Just "nothing" -> Nothing + Just "here" -> Nothing + x -> x returnA -< result -- | Forces the current RSAnim thread to switch whenever the current state does not match the specified predicate. @@ -65,32 +75,6 @@ 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 () -> @@ -105,7 +89,7 @@ planarGameplayDispatch :: (FRPModel m) => FRP e (RSwitch Disabled () () SceneLayerInfo m) () SceneLayerInfo planarGameplayDispatch = proc () -> do -- setup/get infos - mainStateHeader (`elem` planar_states) -< () + mainStateHeader (`elem` planar_states) -< () clearPrintTextOnce -< () frp1Context eventMessager -< () -- terrain threads @@ -113,14 +97,14 @@ -- building threads frpContext (allowAnonymous forbidDuplicates) [(Nothing,visibleObjectThreadLauncher buildingAvatar)] -< () -- creature threads - ctos <- arr (catMaybes . map (uncurry $ liftA2 (,))) <<< - frpContext (allowAnonymous forbidDuplicates) + 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 + -- camera/lighting stuff, including sky sphere sky_info <- getSkyInfo -< () sky -< sky_info m_lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<< @@ -131,16 +115,16 @@ 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 { + mapLightSource (mapBoth $ scalarMultiply 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 } + lightsource_color = grayscale 0.8, + lightsource_ambient = grayscale 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 } + lightsource_color = grayscale 0.5, + lightsource_ambient = grayscale 0.5 } () | otherwise -> NoLight) returnA -< roguestarSceneLayerInfo (skyAbsorbtionFilter sky_info) planar_camera @@ -151,10 +135,11 @@ 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 } + camera_fov = fromDegrees 75 } -- | Retrieve the look-at point from the engine. -centerCoordinates :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m () (Maybe (Integer,Integer)) +centerCoordinates :: (FRPModel m, FRPModes m ~ RoguestarModes) => + 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 @@ -164,14 +149,20 @@ -- | 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"] +blanking_states = ["teleport-event","climb-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) -< () + do mainStateHeader (== "teleport-event") -< () clearPrintTextOnce -< () printTextOnce -< Just (Event,"Whoosh!") + blockContinue <<< arr ((< 0.5) . toSeconds) <<< threadTime -< () + returnA -< roguestarSceneLayerInfo mempty basic_camera +blankingDispatch "climb-event" = proc () -> + do mainStateHeader (== "climb-event") -< () + clearPrintTextOnce -< () + printTextOnce -< Just (Event,"You climb through a network of underground tunnels . . .") blockContinue <<< arr ((< 0.5) . toSeconds) <<< threadTime -< () returnA -< roguestarSceneLayerInfo mempty basic_camera blankingDispatch blanking_state = proc () -> diff --git a/src/Sky.hs b/src/Sky.hs --- a/src/Sky.hs +++ b/src/Sky.hs @@ -20,7 +20,8 @@ import RSAGL.FRP import Data.Maybe import Control.Arrow -import RSAGL.Modeling +import RSAGL.Color +import RSAGL.Color.RSAGLColors import RSAGL.Animation import System.Random () import Control.Monad.Random @@ -28,7 +29,8 @@ import qualified Data.ByteString.Char8 as B -- | Get the current SkyInfo data for the current planet. -getSkyInfo :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m () SkyInfo +getSkyInfo :: (FRPModel m,StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => FRP e m () SkyInfo getSkyInfo = proc () -> do random_id <- sticky isJust Nothing <<< driverGetAnswerA -< "plane-random-id" m_biome <- sticky isJust Nothing <<< driverGetAnswerA -< "biome" @@ -41,14 +43,15 @@ degrees_latitude <- getRandomR(-90,90) degrees_axial_tilt <- getRandomR (0,90) degrees_orbital <- getRandomR (0,360) - return $ default_sky { sky_info_biome = fromMaybe "" m_biome, + return $ default_sky { sky_info_biome = fromMaybe "nothing" m_biome, sky_info_solar_kelvins = temperature, sky_info_degrees_after_midnight = degrees_after_midnight, sky_info_degrees_latitude = degrees_latitude, sky_info_degrees_axial_tilt = degrees_axial_tilt, sky_info_degrees_orbital = degrees_orbital } -sky :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m SkyInfo () +sky :: (FRPModel m,StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => FRP e m SkyInfo () sky = proc sky_info -> do sky_on <- readGlobal global_sky_on -< () libraryA -< (scene_layer_sky_sphere,if sky_on then SkySphere sky_info else NullModel) @@ -60,10 +63,10 @@ lighting_configuration <- Sky.lightingConfiguration -< sky_info let nightlight_intensity = lighting_nightlight lighting_configuration let skylight_intensity = lighting_skylight lighting_configuration - skylight_color <- clingy HashedDiscrete (==) ambientSkyRadiation -< sky_info + skylight_color <- clingy Discrete (==) ambientSkyRadiation -< sky_info accumulateSceneA -< (scene_layer_local,lightSource $ case () of () | nightlight_intensity > 0.05 && sky_on -> - mapLightSource (mapBoth $ scaleRGB nightlight_intensity) $ + mapLightSource (mapBoth $ scalarMultiply nightlight_intensity) $ DirectionalLight { lightsource_direction = Vector3D 0 1 0, lightsource_color = rgb 0.1 0.1 0.2, @@ -71,28 +74,29 @@ () | otherwise -> NoLight) accumulateSceneA -< (scene_layer_local,lightSource $ case () of () | skylight_intensity > 0.05 && sky_on -> - mapLightSource (mapBoth $ scaleRGB skylight_intensity) $ + mapLightSource (mapBoth $ scalarMultiply skylight_intensity) $ skylight (Vector3D 0 1 0) skylight_color () | lighting_artificial lighting_configuration <= 0.05 && not sky_on -> skylight (Vector3D 0 1 0) white () | otherwise -> NoLight) -sun :: (FRPModel m,StateOf m ~ AnimationState) => FRP e m SkyInfo () +sun :: (FRPModel m,StateOf m ~ AnimationState, + InputOutputOf m ~ Enabled) => FRP e m SkyInfo () sun = proc sky_info -> - do libraryA -< (scene_layer_distant,SunDisc $ sunInfoOf sky_info) + do libraryA -< (scene_layer_distant,maybe NullModel SunDisc $ sunInfoOf sky_info) lighting_configuration <- Sky.lightingConfiguration -< sky_info sky_on <- readGlobal global_sky_on -< () let sunlight_intensity = lighting_sunlight lighting_configuration - accumulateSceneA -< (scene_layer_distant,lightSource $ case () of - () | sunlight_intensity > 0.05 && sky_on -> + accumulateSceneA -< (scene_layer_distant,lightSource $ case sunInfoOf sky_info of + Just sun_info | sunlight_intensity > 0.05 && sky_on -> PointLight { lightsource_position = Point3D 0 (-10) 0, lightsource_radius = measure origin_point_3d (Point3D 0 (-10) 0), - lightsource_color = sunColor $ sunInfoOf sky_info, + lightsource_color = sunColor sun_info, lightsource_ambient = blackbody} - () | otherwise -> NoLight) + _ | otherwise -> NoLight) lightingConfiguration :: (FRPModel m) => FRP e m SkyInfo LightingConfiguration lightingConfiguration = proc sky_info -> @@ -100,4 +104,5 @@ artificial <- approachA 1.0 (perSecond 1.0) -< lighting_artificial $ Models.Sky.lightingConfiguration sky_info returnA -< (Models.Sky.lightingConfiguration sky_info) { lighting_nightlight = nightlight, - lighting_artificial = artificial } + lighting_artificial = artificial } + diff --git a/src/Statistics.hs b/src/Statistics.hs --- a/src/Statistics.hs +++ b/src/Statistics.hs @@ -1,21 +1,29 @@ module Statistics - (Statistics,newStatistics,runStatistics) + (Statistics,newStatistics,runStatistics, + animation_query, + animation_post_exec) 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 RSAGL.Math.Types import Text.Printf import Control.Exception +import Data.Maybe +{-# NOINLINE animation_query #-} +animation_query :: Statistics +animation_query = unsafePerformIO $ newStatistics "animation-query" + +{-# NOINLINE animation_post_exec #-} +animation_post_exec :: Statistics +animation_post_exec = unsafePerformIO $ newStatistics "animation-post-exec" + {-# NOINLINE error_pump #-} error_pump :: Chan String error_pump = unsafePerformIO $ @@ -24,56 +32,64 @@ do hPutStrLn stderr =<< readChan pump return pump +data StatisticsBlock = StatisticsBlock { + statistics_max :: !RSdouble, + statistics_min :: !RSdouble, + -- The running average. + statistics_total :: !RSdouble, + statistics_count :: !Integer } + +empty_stats :: StatisticsBlock +empty_stats = StatisticsBlock { + statistics_max = 0.0, + statistics_min = 0.0, + statistics_total = 0.0, + statistics_count = 0 } + +contributeSample :: RSdouble -> Maybe StatisticsBlock -> Maybe StatisticsBlock +contributeSample v Nothing = Just $ StatisticsBlock { + statistics_max = v, + statistics_min = v, + statistics_total = v, + statistics_count = 1 } +contributeSample v (Just stats) = Just $ stats { + statistics_max = statistics_max stats `max` v, + statistics_min = statistics_min stats `min` v, + statistics_total = v + statistics_total stats, + statistics_count = succ $ statistics_count stats } + 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 + -- time since last flushing of statistics + statistics_block :: MVar (Time,Maybe StatisticsBlock), statistics_name :: String } newStatistics :: String -> IO Statistics newStatistics name = - do sample <- newMVar [] - t <- newMVar =<< getTime - s_max <- newMVar 0 - s_avg <- newMVar 1000 + do t <- getTime + new_block <- newMVar (t,Nothing) return $ Statistics { - statistics_sample = sample, - statistics_max = s_max, - statistics_avg = s_avg, - statistics_time = t, + statistics_block = new_block, statistics_name = name } runStatistics :: Statistics -> IO a -> IO a -runStatistics stats action = +runStatistics stats_object 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 + modifyMVar_ (statistics_block stats_object) $ \(t,m_stats) -> + do let should_report = toSeconds (t_end `sub` t) > 60 && isJust m_stats + stats = fromMaybe empty_stats m_stats + when should_report $ + do let f = printf "%.4f" . (f2f :: RSdouble -> Double) :: RSdouble -> String + writeChan error_pump $ "\nSTATISTICS " ++ statistics_name stats_object ++ + "\nMEAN " ++ f (statistics_total stats / fromInteger (statistics_count stats)) ++ + "\nMAX " ++ f (statistics_max stats) ++ + "\nMIN " ++ f (statistics_min stats) ++ + "\nN " ++ show (statistics_count stats) ++ + "\n% TIME " ++ f (statistics_total stats / toSeconds (t_end `sub` t) * 100.0) ++ + "\nTHROUGHPUT " ++ f (fromInteger (statistics_count stats) / statistics_total stats) ++ + "\nEVENTS PER SECOND " ++ f (fromInteger (statistics_count stats) / toSeconds (t_end `sub` t)) + seq stats $ return $ if should_report then (t_end,Nothing) else (t,contributeSample t_diff m_stats) return a diff --git a/src/Strings.hs b/src/Strings.hs --- a/src/Strings.hs +++ b/src/Strings.hs @@ -30,6 +30,7 @@ hrstring "mind" = "Mindfulness " hrstring "maxhp" = "Health " hrstring "forceadept" = "force adept" +hrstring "dustvortex" = "dust vortex" hrstring x = B.map (\c -> if c == '_' then ' ' else c) x diff --git a/src/VisibleObject.hs b/src/VisibleObject.hs --- a/src/VisibleObject.hs +++ b/src/VisibleObject.hs @@ -107,24 +107,37 @@ 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 :: (FRPModel m, + ThreadingOf m ~ Enabled, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + (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 :: (FRPModel m, + ThreadingOf m ~ Enabled, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + FRPModes m ~ RoguestarModes) => + FRP e m () [Integer] allObjects = proc () -> do visible_object_ids <- arr (map vo_unique_id . maybe [] tableSelectTyped) <<< sticky isJust Nothing @@ -148,19 +161,26 @@ | 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 -> +wieldedParent :: (FRPModel m, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + VisibleObjectReference -> FRP e m () (Maybe Integer) getVisibleObject (ThisObject) = threadIdentity getVisibleObject (UniqueID unique_id) = proc () -> returnA -< Just unique_id getVisibleObject (WieldedParent (WieldedTool ref)) = getVisibleObject ref @@ -170,22 +190,36 @@ 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 :: (FRPModel m,StateOf m ~ AnimationState, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m,StateOf m ~ AnimationState, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m,StateOf m ~ AnimationState, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m,StateOf m ~ AnimationState, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 @@ -194,26 +228,43 @@ 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 :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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)) <<< +objectIdealPosition :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + 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 :: (FRPModel m, + ThreadIDOf m ~ Maybe Integer, + FRPModes m ~ RoguestarModes) => + VisibleObjectReference -> + FRP e m () (Maybe CoordinateSystem) objectIdealOrientation obj = proc () -> do m_p <- objectIdealPosition obj -< () m_a <- objectIdealFacing obj -< () @@ -223,7 +274,11 @@ -- | '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 :: + (FRPModel m,FRPModes m ~ RoguestarModes, + 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) -< () diff --git a/src/WordGenerator.hs b/src/WordGenerator.hs --- a/src/WordGenerator.hs +++ b/src/WordGenerator.hs @@ -1,23 +1,3 @@ --------------------------------------------------------------------------- --- roguestar-gl: the space-adventure roleplaying game OpenGL frontend. --- Copyright (C) 2006 Christopher Lane Hinson --- --- This program is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License along --- with this program; if not, write to the Free Software Foundation, Inc., --- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. --- --------------------------------------------------------------------------- - module WordGenerator (HardOrSoft(..), WordGenerator(..), @@ -39,7 +19,7 @@ -- patterns.) -- data HardOrSoft = Hard - | Soft + | Soft -- | -- Specifies the hard letter patterns, soft letter patterns,