roguestar-gl 0.4.0.3 → 0.6.0.0
raw patch · 51 files changed
+1616/−956 lines, 51 filesdep +OpenGLdep +rsagl-frpdep +rsagl-mathdep −old-timedep −processdep −statisticsdep ~GLUTdep ~bytestringdep ~rsagl
Dependencies added: OpenGL, rsagl-frp, rsagl-math
Dependencies removed: old-time, process, statistics, vector
Dependency ranges changed: GLUT, bytestring, rsagl
Files
- Main.hs +0/−167
- roguestar-gl.cabal +41/−46
- src/Actions.hs +40/−36
- src/Animation.hs +89/−39
- src/AnimationBuildings.hs +41/−4
- src/AnimationCreatures.hs +44/−50
- src/AnimationEvents.hs +71/−32
- src/AnimationExtras.hs +2/−2
- src/AnimationMenus.hs +8/−7
- src/AnimationTerrain.hs +9/−7
- src/AnimationTools.hs +5/−5
- src/AnimationVortex.hs +133/−0
- src/Config.hs +10/−2
- src/CreatureData.hs +24/−0
- src/DrawString.hs +31/−0
- src/Driver.hs +1/−0
- src/EventUtils.hs +4/−1
- src/Globals.hs +1/−1
- src/Initialization.hs +63/−0
- src/KeyStroke.hs +130/−0
- src/Keymaps/CommonKeymap.hs +14/−11
- src/Keymaps/Keymaps.hs +25/−27
- src/Keymaps/NumpadKeymap.hs +10/−10
- src/Limbs.hs +60/−13
- src/MainGLUT.hs +0/−143
- src/Models/Ascendant.hs +0/−13
- src/Models/Caduceator.hs +1/−0
- src/Models/Encephalon.hs +1/−0
- src/Models/EnergyThings.hs +1/−0
- src/Models/Glows.hs +29/−0
- src/Models/Hellion.hs +45/−0
- src/Models/Library.hs +9/−2
- src/Models/LibraryData.hs +7/−0
- src/Models/Materials.hs +34/−24
- src/Models/Monolith.hs +0/−14
- src/Models/Node.hs +33/−0
- src/Models/QuestionMark.hs +2/−1
- src/Models/Reptilian.hs +9/−8
- src/Models/Sky.hs +77/−46
- src/Models/Spheres.hs +3/−1
- src/Models/Terrain.hs +55/−12
- src/Models/Tree.hs +2/−1
- src/PrintText.hs +108/−80
- src/PrintTextData.hs +35/−8
- src/Processes.hs +118/−0
- src/RenderingControl.hs +36/−45
- src/Sky.hs +19/−14
- src/Statistics.hs +59/−43
- src/Strings.hs +1/−0
- src/VisibleObject.hs +75/−20
- src/WordGenerator.hs +1/−21
− Main.hs
@@ -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-
roguestar-gl.cabal view
@@ -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 <lane@downstairspeople.org> maintainer: Christopher Lane Hinson <lane@downstairspeople.org> 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 <http://www.downstairspeople.org/git/roguestar-gl.git>.+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
src/Actions.hs view
@@ -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.
src/Animation.hs view
@@ -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
src/AnimationBuildings.hs view
@@ -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)
src/AnimationCreatures.hs view
@@ -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 }+
src/AnimationEvents.hs view
@@ -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
src/AnimationExtras.hs view
@@ -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) ()
src/AnimationMenus.hs view
@@ -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")
src/AnimationTerrain.hs view
@@ -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
src/AnimationTools.hs view
@@ -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,
+ src/AnimationVortex.hs view
@@ -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 })++
src/Config.hs view
@@ -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)
+ src/CreatureData.hs view
@@ -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,())+
+ src/DrawString.hs view
@@ -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 }
src/Driver.hs view
@@ -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
src/EventUtils.hs view
@@ -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"
src/Globals.hs view
@@ -3,7 +3,7 @@ defaultGlobals) where -import RSAGL.Types+import RSAGL.Math.Types import Quality import Control.Concurrent.STM import Control.Applicative
+ src/Initialization.hs view
@@ -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 }+
+ src/KeyStroke.hs view
@@ -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+
src/Keymaps/CommonKeymap.hs view
@@ -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"),
src/Keymaps/Keymaps.hs view
@@ -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
src/Keymaps/NumpadKeymap.hs view
@@ -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")]
src/Limbs.hs view
@@ -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)
− src/MainGLUT.hs
@@ -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-
− src/Models/Ascendant.hs
@@ -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)
src/Models/Caduceator.hs view
@@ -9,6 +9,7 @@ import RSAGL.Modeling import Quality import Models.Materials+import RSAGL.Color.RSAGLColors caduceator :: Quality -> Modeling () caduceator _ = model $
src/Models/Encephalon.hs view
@@ -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 ()
src/Models/EnergyThings.hs view
@@ -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 $
+ src/Models/Glows.hs view
@@ -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)]+
+ src/Models/Hellion.hs view
@@ -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+
src/Models/Library.hs view
@@ -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 -- |
src/Models/LibraryData.hs view
@@ -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)
src/Models/Materials.hs view
@@ -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
− src/Models/Monolith.hs
@@ -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
+ src/Models/Node.hs view
@@ -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+
src/Models/QuestionMark.hs view
@@ -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 $
src/Models/Reptilian.hs view
@@ -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)
src/Models/Sky.hs view
@@ -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),
src/Models/Spheres.hs view
@@ -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
src/Models/Terrain.hs view
@@ -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
src/Models/Tree.hs view
@@ -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
src/PrintText.hs view
@@ -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
src/PrintTextData.hs view
@@ -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+
+ src/Processes.hs view
@@ -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 ()+
src/RenderingControl.hs view
@@ -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 () ->
src/Sky.hs view
@@ -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 }+
src/Statistics.hs view
@@ -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
src/Strings.hs view
@@ -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
src/VisibleObject.hs view
@@ -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) -< ()
src/WordGenerator.hs view
@@ -1,23 +1,3 @@------------------------------------------------------------------------------ roguestar-gl: the space-adventure roleplaying game OpenGL frontend. --- Copyright (C) 2006 Christopher Lane Hinson <lane@downstairspeople.org> --- --- 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,