roguestar-gl 0.4.0.0 → 0.4.0.1
raw patch · 17 files changed
+1370/−3 lines, 17 filesdep ~rsagl
Dependency ranges changed: rsagl
Files
- roguestar-gl.cabal +8/−3
- src/AnimationCreatures.hs +119/−0
- src/AnimationEvents.hs +223/−0
- src/AnimationExtras.hs +53/−0
- src/AnimationMenus.hs +122/−0
- src/AnimationTerrain.hs +113/−0
- src/AnimationTools.hs +117/−0
- src/EventUtils.hs +24/−0
- src/Globals.hs +23/−0
- src/MaybeArrow.hs +79/−0
- src/Models/CyborgType4.hs +60/−0
- src/Models/EnergySwords.hs +20/−0
- src/Models/EnergyThings.hs +16/−0
- src/Models/Sky.hs +206/−0
- src/Models/Spheres.hs +29/−0
- src/Scene.hs +55/−0
- src/Sky.hs +103/−0
roguestar-gl.cabal view
@@ -1,5 +1,5 @@ name: roguestar-gl-version: 0.4.0.0+version: 0.4.0.1 license: OtherLicense license-file: LICENSE author: Christopher Lane Hinson <lane@downstairspeople.org>@@ -15,7 +15,7 @@ homepage: http://roguestar.downstairspeople.org/ build-depends: base>=4&&<5,- rsagl==0.4.0.0,+ rsagl==0.4.0.1, containers>=0.3.0.0 && < 0.4, arrows>=0.4.1.2 && < 0.5, mtl>=1.1.0.2 && < 1.2,@@ -45,7 +45,12 @@ Models.Tree, Models.Encephalon, Models.PhaseWeapons, RenderingControl, Keymaps.BuiltinKeymaps, Keymaps.CommonKeymap, Keymaps.NumpadKeymap, Keymaps.Keymaps, Keymaps.VIKeymap, AnimationBuildings, Models.Monolith,- Models.Stargate, Statistics+ 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+ ghc-options: -threaded -fno-warn-type-defaults -fexcess-precision ghc-prof-options: -prof -auto-all
+ src/AnimationCreatures.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module AnimationCreatures+ (creatureAvatar)+ where++import RSAGL.FRP+import RSAGL.Math+import RSAGL.Animation+import RSAGL.Modeling.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)++-- | Avatar for any creature that automatically switches to the appropriate species-specific avatar thread.+creatureAvatar :: (FRPModel m) => CreatureAvatar e m+creatureAvatar = proc () ->+ do objectTypeGuard (== "creature") -< ()+ m_species <- objectDetailsLookup ThisObject "species" -< ()+ switchContinue -< (fmap switchTo m_species,())+ returnA -< Nothing+ where switchTo "encephalon" = encephalonAvatar+ switchTo "recreant" = recreantAvatar+ switchTo "androsynth" = androsynthAvatar+ switchTo "ascendant" = ascendantAvatar+ switchTo "caduceator" = caduceatorAvatar+ switchTo "reptilian" = reptilianAvatar+ switchTo _ = questionMarkAvatar++genericCreatureAvatar :: (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) <<< + bothArms MachineArmUpper MachineArmLower (Vector3D 0.66 0.66 0) (Point3D 0.145 0.145 0) 0.33 (Point3D 0.35 0.066 0.133) -< ()+ returnA -< CreatureThreadOutput {+ cto_wield_point = wield_point }++recreantAvatar :: (FRPModel m) => CreatureAvatar e m+recreantAvatar = genericCreatureAvatar $ floatBobbing 0.25 0.4 $ proc () ->+ do libraryA -< (scene_layer_local,Recreant)+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<+ bothArms MachineArmUpper MachineArmLower (Vector3D 0 (-1.0) 0) (Point3D 0.3 0.075 0) 0.5 (Point3D 0.5 0.075 0.2) -< ()+ returnA -< CreatureThreadOutput {+ cto_wield_point = wield_point }++androsynthAvatar :: (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) -< ()+ 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 }++caduceatorAvatar :: (FRPModel m) => CreatureAvatar e m+caduceatorAvatar = genericCreatureAvatar $ proc () ->+ do libraryA -< (scene_layer_local,Caduceator)+ wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<+ bothArms CaduceatorArmUpper CaduceatorArmLower (Vector3D 1.0 (-1.0) 1.0) (Point3D 0.1 0.15 0.257) 0.34 (Point3D 0.02 0.17 0.4) -< ()+ returnA -< CreatureThreadOutput {+ cto_wield_point = wield_point }++reptilianAvatar :: (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) -< ()+ 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 }+
+ src/AnimationEvents.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, RankNTypes, FlexibleContexts #-}++module AnimationEvents+ (eventMessager,recognized_events)+ where++import Animation+import Data.Maybe+import Control.Arrow+import AnimationExtras+import PrintTextData+import MaybeArrow+import Data.Monoid+import Tables+import RSAGL.FRP+import Strings+import qualified Data.ByteString.Char8 as B++eventStateHeader :: (FRPModel m) => (B.ByteString -> Bool) -> EventHandler e m () ()+eventStateHeader stateP = proc () ->+ do genericStateHeader switchTo stateP -< ()+ acs <- driverGetAnswerA -< "action-count"+ iacs <- initial -< acs+ switchContinue -< (if acs /= iacs then Just eventMessager else Nothing,())+ where switchTo s = fromMaybe eventMessager $ lookup s messages++type EventSwitch m = RSwitch Disabled () () () m+type EventHandler e m a b = FRP e (EventSwitch m) a b+type MessageHandler e m a b = MaybeArrow (FRP e (EventSwitch m)) a b++-- | Print messages about game events.+eventMessager :: (FRPModel m) => EventHandler e m () ()+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 s actionA = (s,eventStateHeader (== s) >>> (proc () ->+ do m_string <- runMaybeArrow actionA -< Just ()+ printTextOnce -< fmap ((,) Event) 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+ blockContinue -< isNothing m_string && not time_out))++-- | 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)++-- | 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 () ()+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.+timeout :: (FRPModel m) => Time -> b -> MessageHandler e m a b -> MessageHandler e m a b+timeout duration default_value handler = (>>>) (extract handler) $ MaybeArrow $ frp1Context $ proc m_m_o ->+ do let m_o = fromMaybe Nothing m_m_o+ t <- threadTime -< ()+ switchContinue -< (if isNothing m_o && t > duration then Just (arr $ const $ Just default_value) else Nothing,m_m_o)+ returnA -< m_o++-- | As 'driverGetAnswerA'+answer :: B.ByteString -> MessageHandler e m () B.ByteString +answer s = liftConst s driverGetAnswerA++-- | As 'driverGetTableA' that gets one element of the 'object-details' table.+detail :: (FRPModel m) => B.ByteString -> MessageHandler e m B.ByteString B.ByteString+detail field = proc unique_id ->+ MaybeArrow (arr $ maybe Nothing $ \x -> tableLookup x ("property","value") field) <<< + MaybeArrow (arr (fromMaybe Nothing) <<< whenJust driverGetTableA) -< ("object-details",unique_id)++-- | Switch to an alternate message handler constructed with 'alternateMessage'.+continueWith :: (FRPModel m) => MessageHandler e m (EventHandler e m () ()) ()+continueWith = liftJust $ switchContinue <<< arr (\x -> (x,()))++-- | Get a noun from a uid for any tool or character.+nameOf :: (FRPModel m) => B.ByteString -> MessageHandler e m () Noun+nameOf who = proc () ->+ do who_id <- answer who -< ()+ who_player <- answer "who-player" -< ()+ 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"++data Noun = X | You | Singular { _noun_id, _noun_word :: B.ByteString } deriving (Eq)++nounToString :: Noun -> B.ByteString+nounToString You = "you"+nounToString (Singular _ s) = "the " `B.append` s+nounToString X = "it"++possessiveToString :: Noun -> B.ByteString+possessiveToString You = "your"+possessiveToString (Singular _ s) = B.concat ["the ",s,"'s"]+possessiveToString X = "its"++possessivePronounToString :: Noun -> B.ByteString+possessivePronounToString You = "your"+possessivePronounToString (Singular {}) = "its"+possessivePronounToString X = "its"++nounToUID :: MessageHandler e m Noun B.ByteString+nounToUID = proc noun ->+ do you_id <- answer "who-player" -< ()+ returnA -< case noun of+ X -> "0"+ You -> you_id+ Singular uid _ -> uid++isPlural :: Noun -> Bool+isPlural You = True+isPlural (Singular {}) = False+isPlural X = False++sentence :: Noun -> Noun -> Noun -> B.ByteString -> B.ByteString+sentence subject he1 he2 = appEndo $ mconcat $ map Endo $+ he he2 ++ [replace "%" "$"] ++ he he1 +++ [replace "$you" $ nounToString subject,+ replace "$You" $ capitalize $ nounToString subject,+ replace "$your" $ possessiveToString subject,+ replace "$Your" $ capitalize $ possessiveToString subject,+ replace "$(your)" $ possessivePronounToString subject,+ replace "$(Your)" $ capitalize $ possessivePronounToString subject,+ replace "(s)" $ if isPlural subject then "" else "s",+ replace "(es)" $ if isPlural subject then "" else "es",+ replace "$have" $ if isPlural subject then "have" else "has",+ replace "$Have" $ if isPlural subject then "Have" else "has"]+ where he obj = [replace "$he" $ nounToString obj,+ replace "$He" $ capitalize $ nounToString obj,+ replace "$him" $ nounToString obj,+ replace "$Him" $ capitalize $ nounToString obj,+ replace "$his" $ possessiveToString obj,+ replace "$His" $ capitalize $ possessiveToString obj,+ replace "$(his)" $ possessivePronounToString obj,+ replace "$(His)" $ capitalize $ possessivePronounToString obj]++recognized_events :: [B.ByteString]+recognized_events = map fst (messages :: [(B.ByteString,EventHandler e () () ())])++messages :: (FRPModel m) => [(B.ByteString,EventHandler e m () ())]+messages = [+ 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 () -> + do who_attacks <- nameOf "who-attacks" -< ()+ returnA -< 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.",+ 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),+ 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,+ 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!",+ 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!",+ 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,+ messageState "expend-tool-event" $ proc () ->+ do returnA -< "That object has been used up.",+ messagePrompt "attack" "Attack. Direction:",+ messagePrompt "fire" "Fire. Direction:",+ messagePrompt "move" "Walk. Direction:",+ messagePrompt "jump" "Teleport jump. Direction:",+ messagePrompt "clear-terrain" "Clear terrain. Direction:",+ messagePrompt "turn" "Turn. Direction:"]++unarmedAttack :: (FRPModel m) => EventHandler e m () ()+unarmedAttack = alternateMessage "attack-event" $ proc () ->+ 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++armedAttack :: (FRPModel m) => EventHandler e m () ()+armedAttack = alternateMessage "attack-event" $ proc () ->+ do weapon_used <- answer "weapon-used" -< ()+ who_attacks <- nameOf "who-attacks" -< ()+ who_hit <- nameOf "who-hit" -< ()+ 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++-- | 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 ->+ do uid <- nounToUID -< noun+ hp <- detail "hp" -< uid+ maxhp <- detail "maxhp" -< uid+ returnA -< " (" `B.append` hp `B.append` "/" `B.append` maxhp `B.append` ")"++
+ src/AnimationExtras.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE Arrows,+ OverloadedStrings,+ TypeFamilies,+ Rank2Types,+ FlexibleContexts #-}++module AnimationExtras+ (genericStateHeader,+ floatBobbing,+ newListElements,+ basic_camera)+ where++import Animation+import RSAGL.Math+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) => + (B.ByteString -> FRP e m (SwitchInputOf m) (SwitchOutputOf m)) -> + (B.ByteString -> Bool) -> + FRP e m (SwitchInputOf m) ()+genericStateHeader switchTo f = proc i ->+ do m_state <- driverGetAnswerA -< "state"+ switchContinue -< (if fmap f m_state == Just True then Nothing else fmap switchTo m_state,i)+ returnA -< ()++-- | Animate something bobbing up and down.+floatBobbing :: (FRPModel m,StateOf m ~ AnimationState) => RSdouble -> RSdouble -> FRP e m j p -> FRP e m j p+floatBobbing ay by animationA = proc j ->+ do t <- threadTime -< ()+ let float_y = lerpBetween (-1,sine $ fromRotations $ t `cyclical'` (fromSeconds 5),1) (ay,by)+ transformA animationA -< (Affine $ translate (Vector3D 0 float_y 0),j)++-- | Get new elements in a list on a frame-by-frame basis.+newListElements :: (FRPModel m,Eq a) => FRP e m [a] [a]+newListElements = proc as ->+ do olds_as <- delay [] -< as+ returnA -< as \\ olds_as++-- | A simple default forward-looking camera.+basic_camera :: Camera+basic_camera = PerspectiveCamera {+ camera_position = Point3D 0 0 0,+ camera_lookat = Point3D 0 0 1,+ camera_up = Vector3D 0 1 0,+ camera_fov = fromDegrees 45 }+
+ src/AnimationMenus.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module AnimationMenus+ (menu_states,+ menuDispatch)+ where++import AnimationExtras+import Animation+import PrintText+import RSAGL.FRP+import Control.Arrow+import Strings+import Tables+import Data.Monoid+import Data.Maybe+import Actions+import Scene+import qualified Data.ByteString.Char8 as B++type MenuSwitch m = RSwitch Disabled () () SceneLayerInfo m+type MenuHandler e m = FRP e (MenuSwitch m) () SceneLayerInfo++-- 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+ switchTo "class-selection" = menuClassSelection+ switchTo "pickup" = toolMenuSelection+ switchTo "drop" = toolMenuSelection+ switchTo "wield" = toolMenuSelection+ switchTo "make" = toolMenuSelection+ switchTo "make-what" = makeWhatMenuSelection+ switchTo "make-finished" = makeFinishedMenuSelection+ switchTo unknown_state = menuStateHeader (== unknown_state)++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+ requestPrintTextMode -< Unlimited+ clearPrintTextA -< Just ()+ printMenuA select_race_action_names -< ()+ printTextA -< Just (Query,"Select a Race:")+ returnA -< result++menuClassSelection :: (FRPModel m) => MenuHandler e m+menuClassSelection = proc () -> + do result <- menuStateHeader (== "class-selection") -< ()+ stats <- sticky isJust Nothing <<< arr (fmap table_created) <<< driverGetTableA -< ("player-stats","0")+ initial_stats <- initial -< stats+ let change = stats /= initial_stats+ switchContinue -< (if change then Just menuClassSelection else Nothing,())+ requestPrintTextMode -< Unlimited+ clearPrintTextA -< Just ()+ printCharacterStats 0 -< ()+ printMenuA select_base_class_action_names -< ()+ printMenuItemA "reroll" -< ()+ printTextA -< Just (Query,"Select a Class:")+ returnA -< result++printCharacterStats :: (FRPModel m, StateOf m ~ AnimationState) => 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")+ print1CharacterStat -< (m_player_stats,"spd")+ print1CharacterStat -< (m_player_stats,"con")+ printTextA -< Just (Event,"-")+ print1CharacterStat -< (m_player_stats,"per")+ printTextA -< Just (Event,"-")+ print1CharacterStat -< (m_player_stats,"int")+ print1CharacterStat -< (m_player_stats,"cha")+ print1CharacterStat -< (m_player_stats,"mind")+ printTextA -< Just (Event,"-")+ print1CharacterStat -< (m_player_stats,"maxhp")+ +print1CharacterStat :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (Maybe RoguestarTable,B.ByteString) ()+print1CharacterStat = proc (m_player_stats,stat_str) ->+ do let m_stat_int = (\x -> tableLookupInteger x ("property","value") stat_str) =<< m_player_stats+ printTextA -< fmap (\x -> (Event,hrstring stat_str `B.append` ": " `B.append` (B.pack $ show x))) m_stat_int++makeWhatMenuSelection :: (FRPModel m) => MenuHandler e m+makeWhatMenuSelection = proc () ->+ do result <- menuStateHeader (== "make-what") -< ()+ requestPrintTextMode -< Unlimited+ clearPrintTextA -< Just ()+ printMenuA make_what_action_names -< ()+ printTextA -< Just (Query,"Build what?")+ returnA -< result++makeFinishedMenuSelection :: (FRPModel m) => MenuHandler e m+makeFinishedMenuSelection = proc () ->+ do result <- menuStateHeader (== "make-finished") -< ()+ clearPrintTextA -< Just ()+ printTextA -< Just (Query,"Confirm.")+ returnA -< result++toolMenuSelection :: (FRPModel m) => MenuHandler e m+toolMenuSelection = proc () ->+ do menuStateHeader (`elem` ["pickup","drop","wield","make"]) -< ()+ state <- sticky isJust Nothing <<< driverGetAnswerA -< "menu-state"+ m_menu_data <- sticky isJust Nothing <<< driverGetTableA -< ("menu","7")+ menu_state <- sticky isJust Nothing <<< driverGetAnswerA -< "menu-state"+ clearPrintTextA -< Just ()+ requestPrintTextMode -< Unlimited+ printTextA -< Just (Query, B.unlines $ flip (maybe []) m_menu_data $ \menu_data -> flip map (tableSelect menu_data ["n","name"]) $ \[n,name] ->+ case Just n == menu_state of+ True -> " ---> " `B.append` hrstring name+ False -> " " `B.append` hrstring name)+ printTextA -< Just (Query, case state of+ Just "pickup" -> "Select an item to pick up: "+ Just "drop" -> "Select an item to drop: "+ Just "wield" -> "Select an item to wield: "+ Just "make" -> "Select materials to craft an item: " -- FIXME should say what kind of item+ _ -> "Select an item: ")+ printMenuItemA "next" -< ()+ printMenuItemA "prev" -< ()+ printMenuItemA "escape" -< ()+ returnA -< roguestarSceneLayerInfo mempty basic_camera+
+ src/AnimationTerrain.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies, FlexibleContexts #-}++module AnimationTerrain+ (terrainThreadLauncher)+ where++import Data.List+import RSAGL.Types+import RSAGL.FRP+import RSAGL.Math+import RSAGL.Animation.InverseKinematics+import Animation+import Control.Arrow+import Control.Monad+import Control.Monad.Random+import Data.Maybe+import Models.LibraryData+import ProtocolTypes+import Scene+import AnimationExtras++type TerrainThreadSwitch m = RSwitch Enabled (Maybe ProtocolTypes.TerrainTile) () () m++-- | Thread that launches rendering threads for the terrain tiles.+terrainThreadLauncher :: (FRPModel m) => FRP e (TerrainThreadSwitch m) () ()+terrainThreadLauncher = spawnThreads <<<+ arr (map (\x -> (Just x,terrainTile x))) <<<+ newListElements <<< terrainElements++terrainTile :: (FRPModel m) => ProtocolTypes.TerrainTile ->+ FRP e (TerrainThreadSwitch m) () ()+terrainTile (tid@(ProtocolTypes.TerrainTile terrain_type (x,y))) = proc () ->+ do terrain_elements <- terrainElements -< ()+ let still_here = isJust $ find (== tid) terrain_elements+ let goal_size = if still_here then 1.25 else -0.25+ actual_size <- arr (max 0 . min 1) <<<+ approachFrom 0.5 (perSecond 1.0) 0 -< goal_size+ killThreadIf -< actual_size <= 0.0 && not still_here+ transformA (libraryA >>> terrainDecoration tid) -<+ (Affine $ translate+ (Vector3D (fromInteger x) 0 (negate $ fromInteger y)) .+ scale' actual_size,+ (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"))++terrainDecoration :: (FRPModel m, StateOf m ~ AnimationState) =>+ ProtocolTypes.TerrainTile ->+ FRP e m () ()+terrainDecoration (ProtocolTypes.TerrainTile "forest" (x,y)) =+ fst $ runRand (leafyTree 2 True)+ (mkStdGen $ fromInteger $ x + 1000*y)+terrainDecoration (ProtocolTypes.TerrainTile "deepforest" (x,y)) =+ fst $ runRand (leafyTree 3 True)+ (mkStdGen $ fromInteger $ 2*x + 1001*y + 7)+terrainDecoration _ = proc () -> returnA -< ()++leafyTree :: (FRPModel m, StateOf m ~ AnimationState) =>+ Int -> Bool -> Rand StdGen (FRP e m () ())+leafyTree recursion has_leaves =+ do dead_tree <- liftM (== 1) $ getRandomR (1,4 :: Integer)+ (x:y:_) <- getRandomRs (-0.4,0.4)+ thickness <- getRandomR (0.02*realToFrac recursion,+ 0.04*realToFrac recursion)+ push_up <- getRandomR (1.5/realToFrac recursion,+ 3.0/realToFrac recursion)+ leafyTreeBranch (Point3D x 0 y)+ (Vector3D 0 push_up 0)+ thickness+ recursion+ (has_leaves && not dead_tree)++leafyTreeBranch :: (FRPModel m, StateOf m ~ AnimationState) =>+ Point3D ->+ Vector3D ->+ RSdouble ->+ Int ->+ Bool ->+ Rand StdGen (FRP e m () ())+leafyTreeBranch point vector thickness recursion has_leaves | recursion <= 0 =+ do let leaves = translateToFrom point (Point3D 0 0 0) $+ scale' (vectorLength vector + thickness) $+ proc () -> libraryA -< (scene_layer_local,LeafyBlob)+ return $ if has_leaves then leaves else proc () -> returnA -< ()+leafyTreeBranch point vector thickness recursion has_leaves =+ do b <- getRandom+ let branch_inset = min 0.25 $ thickness / vectorLength vector+ takes <- getRandomR (1,recursion)+ us <- liftM (take takes) $ getRandomRs (2*branch_inset,1.0-branch_inset)+ other_branches <- mapM (leafyTreeBranchFrom $ b && has_leaves) us+ continue_trunk <- leafyTreeBranchFrom has_leaves $ 1.0 - branch_inset+ let this_branch = translateToFrom point (Point3D 0 0 0) $+ rotateToFrom vector (Vector3D 0 1 0) $+ 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) =>+ Bool -> RSdouble -> Rand StdGen (FRP e m () ())+ leafyTreeBranchFrom pass_leaves u =+ do let new_vector_constraint = vectorLength vector / 1.5+ (x:y:z:_) <- getRandomRs (-new_vector_constraint,+ new_vector_constraint)+ t <- getRandomR (thickness/3,thickness/2)+ leafyTreeBranch+ (lerp u (point,translate vector point))+ (vectorScaleTo new_vector_constraint $+ vector `add` (Vector3D x y z))+ t+ (recursion - 1)+ pass_leaves+
+ src/AnimationTools.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module AnimationTools+ (toolAvatar)+ where++import RSAGL.Math+import Scene+import Animation+import RSAGL.Animation+import RSAGL.FRP+import RSAGL.Modeling.Color+import Control.Arrow+import VisibleObject+import Models.LibraryData+import Control.Applicative+import EventUtils+import Control.Monad+import qualified Data.ByteString.Char8 as B++type ToolAvatarSwitch m = AvatarSwitch ToolThreadInput () m+type ToolAvatar e m = FRP e (ToolAvatarSwitch m) ToolThreadInput ()++-- | Avatar for any tool that automatically switched to the correct tool-specific thread.+toolAvatar :: (FRPModel m) => ToolAvatar e m+toolAvatar = proc tti ->+ do objectTypeGuard (== "tool") -< ()+ m_tool <- objectDetailsLookup ThisObject "tool" -< ()+ m_tool_type <- objectDetailsLookup ThisObject "tool-type" -< ()+ switchContinue -< (fmap switchTo $ (,) <$> m_tool_type <*> m_tool,tti)+ returnA -< ()+ where switchTo (_,"phase_pistol") = phaseWeaponAvatar PhasePistol 1+ switchTo (_,"phaser") = phaseWeaponAvatar Phaser 3+ switchTo (_,"phase_rifle") = phaseWeaponAvatar PhaseRifle 5+ switchTo (_,"kinetic_fleuret") = energySwordAvatar Yellow 2+ switchTo (_,"kinetic_sabre") = energySwordAvatar Yellow 4+ switchTo (_,"improvised_pistol") = phaseWeaponAvatar PhasePistol 1+ switchTo (_,"improvised_carbine") = phaseWeaponAvatar Phaser 3+ switchTo (_,"improvised_rifle") = phaseWeaponAvatar PhaseRifle 5+ switchTo (_,"improvised_fleuret") = energySwordAvatar Red 2+ switchTo (_,"improvised_sabre") = energySwordAvatar Red 4+ switchTo ("sphere-gas",gas) = gasSphereAvatar gas+ switchTo ("sphere-material",material) = materialSphereAvatar material+ switchTo ("sphere-chromalite",chromalite) = chromaliteSphereAvatar chromalite+ switchTo _ = questionMarkAvatar >>> arr (const ())++simpleToolAvatar :: (FRPModel m) => LibraryModel -> ToolAvatar e m+simpleToolAvatar phase_weapon_model = proc tti ->+ do visibleObjectHeader -< ()+ m_orientation <- wieldableObjectIdealOrientation ThisObject -< tti+ whenJust (transformA libraryA) -< fmap (\o -> (o,(scene_layer_local,phase_weapon_model))) m_orientation+ returnA -< ()++phaseWeaponAvatar :: (FRPModel m,LibraryModelSource lm) =>+ lm -> Integer -> ToolAvatar e m+phaseWeaponAvatar phase_weapon_model weapon_size = proc tti ->+ do visibleObjectHeader -< ()+ m_orientation <- wieldableObjectIdealOrientation ThisObject -< tti+ m_atk_time <- recentAttack (WieldedParent ThisObject) -< ()+ 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) ()+ 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 }+ _ | otherwise -> NoLight)+ returnA -< ()++energySwordAvatar :: (FRPModel m) => EnergyColor -> Integer -> ToolAvatar e m+energySwordAvatar energy_color sword_size = proc tti ->+ do visibleObjectHeader -< ()+ m_orientation <- wieldableObjectIdealOrientation ThisObject -< tti+ m_atk_time <- recentAttack (WieldedParent ThisObject) -< ()+ t_now <- threadTime -< ()+ is_being_wielded <- isBeingWielded ThisObject -< ()+ whenJust (transformA $ transformA displayA) -<+ do orientation <- m_orientation+ atk_time <- m_atk_time+ let atk_rotate = case toSeconds (t_now `sub` atk_time) of+ t | t < 1 -> fromRotations $ t*1.25 -- 1 and 1-quarter revolution in one second+ t | t >= 1 && t <= 1.5 -> fromRotations $ 1.25 - 0.25 * (t - 1) -- then swing back+ _ | otherwise -> fromRotations 0+ return $ (orientation,(Affine $ rotate (Vector3D 1 0 0) atk_rotate, is_being_wielded))+ `mplus`+ do orientation <- m_orientation+ return (orientation,(Affine id,is_being_wielded))+ returnA -< ()+ where displayA :: (FRPModel m, StateOf m ~ AnimationState) => 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,+ EnergyThing EnergySword energy_color)+ transformA libraryA -<+ (Affine $ translate (Vector3D 0 2.9 0) .+ scale (Vector3D 1 blade_length 1),+ (scene_layer_local,+ EnergyThing EnergyCylinder energy_color))++gasSphereAvatar :: (FRPModel m) => B.ByteString -> ToolAvatar e m+gasSphereAvatar = simpleToolAvatar . gasToModel+ where gasToModel :: B.ByteString -> LibraryModel+ gasToModel = const $ SimpleModel GasSphere++materialSphereAvatar :: (FRPModel m) => B.ByteString -> ToolAvatar e m+materialSphereAvatar = simpleToolAvatar . materialToModel+ where materialToModel :: B.ByteString -> LibraryModel+ materialToModel = const $ SimpleModel MetalSphere++chromaliteSphereAvatar :: (FRPModel m) => B.ByteString -> ToolAvatar e m+chromaliteSphereAvatar = simpleToolAvatar . const (SimpleModel ChromaliteSphere)+
+ src/EventUtils.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}+module EventUtils+ (recentAttack)+ where++import VisibleObject+import Animation+import Control.Arrow+import RSAGL.FRP+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 obj = proc () ->+ do state <- driverGetAnswerA -< "state"+ count <- driverGetAnswerA -< "action-count"+ who <- getVisibleObject Attacker -< ()+ am_i <- getVisibleObject obj -< ()+ t <- threadTime -< ()+ arr snd <<< accumulate (Nothing,Nothing) (\(is_me,new_state,new_count,new_t) old ->+ if new_state `elem` (map Just ["attack-event","miss-event","sunder-event","disarm-event"]) && + new_count /= fst old && is_me+ then (new_count,Just new_t) else old) -< (isJust who && who == am_i,state,count,t)+
+ src/Globals.hs view
@@ -0,0 +1,23 @@+module Globals+ (Globals(..),+ defaultGlobals)+ where++import RSAGL.Types+import Quality+import Control.Concurrent.STM+import Control.Applicative++data Globals = Globals {+ global_planar_camera_distance :: TVar RSdouble,+ global_sky_on :: TVar Bool,+ global_quality_setting :: TVar Quality,+ global_should_quit :: TVar Bool }++defaultGlobals :: IO Globals+defaultGlobals = Globals <$>+ newTVarIO 5.0 <*>+ newTVarIO True <*>+ newTVarIO Poor <*>+ newTVarIO False+
+ src/MaybeArrow.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}++-- | An Arrow supporting failure.+-- +-- Caveats:+--+-- 'MaybeArrow' is not necessarily an 'ArrowTransformer'. If the underlying arrow does not support 'ArrowChoice', then 'MaybeArrow' is still useful,+-- but the 'lift' operation is not supported.+--+-- Failed 'MaybeArrow's still call all underlying side effecting operations, except those wrapped with 'lift'.+--+module MaybeArrow+ (MaybeArrow(..),+ maybeA,+ guardA,+ extract,+ liftJust,+ liftConst,+ liftJustConst,+ example)+ where++import Prelude hiding (id,(.))+import Control.Arrow+import Control.Arrow.Transformer+import Data.Maybe+import Control.Category++newtype MaybeArrow a b c = MaybeArrow { runMaybeArrow :: (a (Maybe b) (Maybe c)) }++instance (Category a,Arrow a) => Category (MaybeArrow a) where+ (.) (MaybeArrow y) (MaybeArrow x) = MaybeArrow $ arr splitIt >>> first x >>> arr combineIt >>> y+ where splitIt m = (m,m)+ combineIt (n,Just _) = n+ combineIt _ = Nothing+ id = MaybeArrow id++instance (Arrow a) => Arrow (MaybeArrow a) where+ arr f = MaybeArrow $ arr $ fmap f+ first (MaybeArrow x) = MaybeArrow $ arr splitMaybe >>> first x >>> arr combineMaybe+ where splitMaybe (Just (m,n)) = (Just m,Just n)+ splitMaybe Nothing = (Nothing,Nothing)+ combineMaybe (Just m,Just n) = Just (m,n)+ combineMaybe _ = Nothing++instance (Arrow a,ArrowChoice a) => ArrowTransformer MaybeArrow a where+ lift a = MaybeArrow $ arr (maybe (Right Nothing) Left) >>> ((a >>> arr Just) ||| arr id)++-- | Embed a raw 'Maybe' value into a computation.+maybeA :: (Arrow a) => MaybeArrow a (Maybe b) b+maybeA = MaybeArrow $ arr (fromMaybe Nothing)++-- | Arbitrarily fail a computation.+guardA :: (Arrow a) => MaybeArrow a Bool ()+guardA = maybeA <<< arr (\x -> if x then Just () else Nothing)++-- | Get an explicit Maybe from a computation instead of failing. Inverse of 'maybeA'.+extract :: (Arrow a) => MaybeArrow a b c -> MaybeArrow a b (Maybe c)+extract (MaybeArrow actionA) = MaybeArrow $ actionA >>> arr Just++-- | Lift an action that always succeeds.+liftJust :: (Arrow a) => a (Maybe b) c -> MaybeArrow a b c+liftJust actionA = MaybeArrow $ actionA >>> arr Just++-- | Lift an action that accepts a constant input.+liftConst :: (Arrow a) => b -> a b (Maybe c) -> MaybeArrow a () c+liftConst k actionA = MaybeArrow $ actionA <<< (arr $ const k)++-- | Combine 'liftJust' and 'liftConst'.+liftJustConst :: (Arrow a) => b -> a b c -> MaybeArrow a () c+liftJustConst k actionA = MaybeArrow $ arr Just <<< actionA <<< (arr $ const k)++-- | Simple example that answers the sum of all four Integers, if they are all provided.+-- Try: runMaybeArrow (example 2 (Just 3)) $ Just (4,Just 5)+example :: Integer -> Maybe Integer -> MaybeArrow (->) (Integer,Maybe Integer) Integer+example a m_b = proc (c,m_d) ->+ do b <- maybeA -< m_b+ d <- maybeA -< m_d+ returnA -< sum [a,b,c,d]
+ src/Models/CyborgType4.hs view
@@ -0,0 +1,60 @@+module Models.CyborgType4+ (cyborg_type_4_dome,+ cyborg_type_4_base,+ cyborg_type_4_hyperspace_disc,+ cyborg_type_4_hyperspace_rotor,+ cyborg_type_4_hyperspace_stabilizer)+ where++import Models.Materials+import RSAGL.Math+import RSAGL.Modeling+import RSAGL.Math.CurveExtras+import Quality+import RSAGL.Scene.CoordinateSystems++cyborg_type_4_dome :: Quality -> Modeling ()+cyborg_type_4_dome q =+ do hemisphere (Point3D 0 0 0) (Vector3D 0 1 0) 9+ closedDisc (Point3D 0 0 0) (Vector3D 0 (-1) 0) 9.01+ affine $ scale $ Vector3D 1 (8/9) 1+ material cyborg_metal+ qualityToFixed q++cyborg_type_4_base :: Quality -> Modeling ()+cyborg_type_4_base q =+ do model $ + do openDisc (Point3D 0 0 0) (Vector3D 0 1 0) 0 10.01+ openCone (Point3D 0 (-6) 0,10) (Point3D 0 0 0,10)+ reverseOrientation $ openCone (Point3D 0 (-3) 0,9) (Point3D 0 (-5) 0,9)+ reverseOrientation $ openCone (Point3D 0 (-5) 0,7) (Point3D 0 (-6) 0,7)+ openDisc (Point3D 0 (-6) 0) (Vector3D 0 (-1) 0) 6.99 10.01+ qualityToFixed q+ sor $ linearInterpolation $ map ($ 0) $ reverse [+ Point3D 9 (-3),+ Point3D 4 (-5),+ Point3D 3 (-6),+ Point3D 1 (-16),+ Point3D 0 (-26)]+ material cyborg_metal++cyborg_type_4_hyperspace_disc :: Quality -> Modeling ()+cyborg_type_4_hyperspace_disc q =+ do closedCone (Point3D 0 0 0,10) (Point3D 0 10 0,10)+ material cyborg_glow+ qualityToFixed q++cyborg_type_4_hyperspace_rotor :: Quality -> Modeling ()+cyborg_type_4_hyperspace_rotor _ =+ do box (Point3D 15 4 (-0.5)) (Point3D 20 (-6) 0.5)+ material cyborg_glow+ fixed (3,3)++cyborg_type_4_hyperspace_stabilizer :: Quality -> Modeling ()+cyborg_type_4_hyperspace_stabilizer q =+ do box (Point3D 6 (-9) (-2)) (Point3D 10 (-16) 2)+ affine $ transformAbout (Point3D 8 (-16) 0) $ rotate (Vector3D 0 1 0) (fromDegrees 45)+ deform $ \(Point3D x _ _) -> Affine $ transformAbout (Point3D 10 (-16) 0) $ scaleAlong (Vector3D 0 1 0) $ lerpBetweenClampedMutated (^2) (6,x,10) (3/7,1)+ disregardSurfaceNormals+ material cyborg_glow+ qualityToFixed q
+ src/Models/EnergySwords.hs view
@@ -0,0 +1,20 @@+module Models.EnergySwords+ (energySword) where++import RSAGL.Modeling+import RSAGL.Math+import Quality+import Models.LibraryData+import Control.Monad+import Models.Materials++energySword :: EnergyColor -> Integer -> Quality -> Modeling ()+energySword energy_color size_count _ = model $+ do model $ do closedCone (Point3D 0 (negate $ realToFrac size_count) 0,1.0) (Point3D 0 3 0,1.0)+ concordance_metal+ model $ do closedDisc (Point3D 0 3.01 0) (Vector3D 0 1 0) 0.6+ when (size_count >= 2) $ openDisc (Point3D 0 3.01 0) (Vector3D 0 1 0) 0.75 1.0+ when (size_count >= 3) $ openCone (Point3D 0 2.75 0,1.1) (Point3D 0 2.25 0,1.1)+ when (size_count >= 4) $ openCone (Point3D 0 (-2.25) 0,1.1) (Point3D 0 (-2.75) 0,1.1)+ when (size_count >= 5) $ openCone (Point3D 0 (-4.25) 0,1.1) (Point3D 0 (-4.75) 0,1.1)+ energyMaterial energy_color
+ src/Models/EnergyThings.hs view
@@ -0,0 +1,16 @@+module Models.EnergyThings+ (energyCylinder) where++import Models.LibraryData+import RSAGL.Modeling+import RSAGL.Math+import Quality+import Data.Monoid+import Models.Materials++energyCylinder :: (Monoid attr) => EnergyColor -> Quality -> Modeling attr+energyCylinder c _ = model $+ do closedCone (Point3D 0 0 0,1.0) (Point3D 0 1 0,1.0)+ material $ do pigment $ pure blackbody+ emissive $ pure $ energyColor c+
+ src/Models/Sky.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}++module Models.Sky+ (SkyInfo(..),default_sky,+ SunInfo(..),default_sun,+ sunInfoOf,+ makeSky,+ makeSun,+ skyAbsorbtionFilter,+ sunVector,+ sunColor,+ LightingConfiguration(..),+ lightingConfiguration,+ ambientSkyRadiation)+ where++import RSAGL.Math+import RSAGL.Extras.Sky+import RSAGL.Extras.ColorPhysics+import RSAGL.Modeling+import RSAGL.Modeling.Noise+import Scene+import Data.Monoid+import RSAGL.Types+import qualified Data.ByteString as B++data SkyInfo = SkyInfo {+ sky_info_biome :: B.ByteString,+ sky_info_degrees_after_midnight :: Integer,+ sky_info_degrees_latitude :: Integer,+ sky_info_degrees_axial_tilt :: Integer,+ -- | indicates current season, where 0 degrees is summer in northern hemisphere (positive latitude)+ -- given positive axial tilt, and 180 degrees is winter.+ sky_info_degrees_orbital :: Integer,+ sky_info_solar_kelvins :: Integer }+ deriving (Eq,Ord,Show)++data SunInfo = SunInfo {+ -- | on a logarithmic scale base 1.01, i.e. 5 means multiply the size by 1.01**5+ sun_info_size_adjustment :: Integer,+ sun_info_kelvins :: Integer }+ deriving (Eq,Ord,Show)++default_sky :: SkyInfo+default_sky = SkyInfo {+ sky_info_biome = "oceanbiome",+ sky_info_degrees_after_midnight = 0,+ sky_info_degrees_latitude = 100,+ sky_info_degrees_axial_tilt = 0,+ sky_info_degrees_orbital = 90,+ sky_info_solar_kelvins = 5800 }++default_sun :: SunInfo+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 }++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 ]++thin_atmosphere :: Atmosphere+thin_atmosphere = [+ AtmosphereLayer Air 0.075 9.0e-5,+ AtmosphereLayer Vapor 0.025 2.5e-5 ]++thick_atmosphere :: Atmosphere+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 ]++arid_atmosphere :: Atmosphere+arid_atmosphere = [+ AtmosphereLayer Air 0.05 2.5e-3,+ AtmosphereLayer (Dust $ rust) 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,[])++-- | 'sunVectorOf' indicates vector pointing at the sun.+sunVector :: SkyInfo -> Vector3D+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)) $+ rotate (Vector3D 0 0 1) (fromDegrees $ realToFrac $ sky_info_degrees_after_midnight sky_info) $ + Vector3D 0 (-1) 0++-- | Apparent temperature of a color in kelvins.+temperatureColor :: Integer -> RGB+temperatureColor kelvins = lerpBetweenClamped (770,realToFrac kelvins,1060) + (gray 0,maximizeRGB $ blackBodyRGB $ realToFrac kelvins)++-- | Apparent color of light comming from the sun.+sunColor :: SunInfo -> RGB+sunColor sun_info = temperatureColor (sun_info_kelvins sun_info)++-- | The size of a very ordinary sun-like star as seen from a very temperate climate.+base_star_size :: RSdouble+base_star_size = 0.1++-- | Radius of the sun at a standard distance eye-to-center of 10 units.+sunSize :: SunInfo -> RSdouble+sunSize sun_info = base_star_size * (5800^2 / (realToFrac $ sun_info_kelvins sun_info ^2)) * 1.01 ** (realToFrac $ sun_info_size_adjustment sun_info)++-- | 'makeSky' generates a sky sphere.+makeSky :: SkyInfo -> Modeling ()+makeSky 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)++-- | 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+ () | 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+ 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))++-- | 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.+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.+ 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),+ 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 = 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)+ test_vectors = map vectorNormalize $ + do x <- [1,0,-1]+ y <- [1,0,-1]+ return $ Vector3D x 1 y++-- 'makeSun' generates a perspectiveSphere of the sun.+makeSun :: SunInfo -> Modeling ()+makeSun sun_info = model $+ do let size = sunSize sun_info+ let temp = sun_info_kelvins sun_info+ let temperaturePattern t = pattern (cloudy (fromInteger $ temp + sun_info_size_adjustment sun_info) base_star_size) + [(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+ emissive $ pattern (spherical (Point3D 0 (size-10) 0) size) [(0.0,temperaturePattern temp),+ (0.5,temperaturePattern $ temp - 200),+ (0.75,temperaturePattern $ temp - 500),+ (0.9,temperaturePattern $ temp - 800),+ (1.0,temperaturePattern $ temp - 1000)]++hilly_silhouette :: Modeling ()+hilly_silhouette = model $+ do heightDisc (0,0) 8 (\(x,z) -> perlinNoise (Point3D x 0 z) - 6.9 + distanceBetween origin_point_3d (Point3D x 0 z))+ affine $ scale (Vector3D 1 0.2 1)+ material $ pigment $ pure blackbody+ disregardSurfaceNormals+
+ src/Models/Spheres.hs view
@@ -0,0 +1,29 @@+module Models.Spheres+ (gasSphere,+ metalSphere,+ chromaliteSphere)+ where++import Quality+import RSAGL.Modeling+import RSAGL.Math+import Models.Materials+import Models.LibraryData++-- | An empty (or transparent) gas sphere.+gasSphere :: Quality -> Modeling ()+gasSphere _ = model $+ do sphere (Point3D 0 0.06 0) 0.06+ material $ + do transparent $ pure $ rgba 0.9 0.9 0.9 0.25+ specular 10 $ pure white++metalSphere :: Quality -> Modeling ()+metalSphere _ = model $+ do sphere (Point3D 0 0.05 0) 0.05+ concordance_metal++chromaliteSphere :: Quality -> Modeling ()+chromaliteSphere _ = model $+ do sphere (Point3D 0 0.04 0) 0.04+ energyMaterial Yellow
+ src/Scene.hs view
@@ -0,0 +1,55 @@+module Scene+ (module RSAGL.Scene,+ roguestarSceneLayerInfo,+ scene_layer_hud,+ scene_layer_cockpit,+ scene_layer_local,+ scene_layer_near_sky,+ scene_layer_clouds,+ scene_layer_sky_sphere,+ scene_layer_far_sky,+ scene_layer_orbit,+ scene_layer_distant)+ where++import RSAGL.Scene hiding (std_scene_layer_hud,std_scene_layer_cockpit,std_scene_layer_local,std_scene_layer_infinite)+import qualified RSAGL.Scene as SceneLayers (std_scene_layer_hud,std_scene_layer_cockpit,std_scene_layer_local,std_scene_layer_infinite)+import Data.Monoid++roguestarSceneLayerInfo :: LightSourceLayerTransform -> Camera -> SceneLayerInfo+roguestarSceneLayerInfo light_source_layer_transform c = SceneLayerInfo+ (stdSceneLayers c)+ (light_source_layer_transform `mappend` cameraLightSourceLayerTransform (stdSceneLayers c))++scene_layer_hud :: SceneLayer+scene_layer_hud = SceneLayers.std_scene_layer_hud++scene_layer_cockpit :: SceneLayer+scene_layer_cockpit = SceneLayers.std_scene_layer_cockpit++scene_layer_local :: SceneLayer+scene_layer_local = SceneLayers.std_scene_layer_local++-- | Infinite layer, under the clouds+scene_layer_near_sky :: SceneLayer+scene_layer_near_sky = SceneLayers.std_scene_layer_infinite++-- | Contains clouds only+scene_layer_clouds :: SceneLayer+scene_layer_clouds = SceneLayers.std_scene_layer_infinite + 1++-- | Infinite layer, above clouds+scene_layer_far_sky :: SceneLayer+scene_layer_far_sky = SceneLayers.std_scene_layer_infinite + 2++-- | Contains sky sphere only+scene_layer_sky_sphere :: SceneLayer+scene_layer_sky_sphere = SceneLayers.std_scene_layer_infinite + 3++-- | Infinite layer, above the sky+scene_layer_orbit :: SceneLayer+scene_layer_orbit = SceneLayers.std_scene_layer_infinite + 4++-- | Infinite layer, contains astronomical objects+scene_layer_distant :: SceneLayer+scene_layer_distant = SceneLayers.std_scene_layer_infinite + 5
+ src/Sky.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE Arrows, OverloadedStrings, TypeFamilies #-}++module Sky+ (getSkyInfo,+ sky,+ Models.Sky.default_sky,+ Models.Sky.default_sun,+ skyAbsorbtionFilter,+ SkyInfo,+ Models.Sky.LightingConfiguration(..),+ Sky.lightingConfiguration)+ where++import Models.Sky+import Animation+import Tables+import Scene+import Models.LibraryData+import RSAGL.Math+import RSAGL.FRP+import Data.Maybe+import Control.Arrow+import RSAGL.Modeling+import RSAGL.Animation+import System.Random ()+import Control.Monad.Random+import Globals+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 = proc () ->+ do random_id <- sticky isJust Nothing <<< driverGetAnswerA -< "plane-random-id"+ m_biome <- sticky isJust Nothing <<< driverGetAnswerA -< "biome"+ clingy Discrete (==) (uncurry generateSkyInfo) -< (random_id,m_biome)++generateSkyInfo :: Maybe B.ByteString -> Maybe B.ByteString -> SkyInfo+generateSkyInfo random_id m_biome = fst $ flip runRand (mkStdGen $ fromInteger $ fromMaybe 0 $ random_id >>= readInteger) $+ do temperature <- getRandomR (10000,2000)+ degrees_after_midnight <- getRandomR (0,360)+ 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,+ 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 = proc sky_info ->+ do sky_on <- readGlobal global_sky_on -< ()+ libraryA -< (scene_layer_sky_sphere,if sky_on then SkySphere sky_info else NullModel)+ let sun_vector = sunVector sky_info+ whenJust (transformA sun) -< if angleBetween sun_vector (Vector3D 0 1 0) < fromDegrees 135 && sky_on+ then Just (affineOf $ rotateToFrom (sunVector sky_info) (Vector3D 0 (-1) 0),sky_info)+ else Nothing+ returnA -< ()+ 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+ accumulateSceneA -< (scene_layer_local,lightSource $ case () of+ () | nightlight_intensity > 0.05 && sky_on ->+ mapLightSource (mapBoth $ scaleRGB nightlight_intensity) $+ DirectionalLight {+ lightsource_direction = Vector3D 0 1 0,+ lightsource_color = rgb 0.1 0.1 0.2,+ lightsource_ambient = rgb 0.0 0.0 0.3 }+ () | otherwise -> NoLight)+ accumulateSceneA -< (scene_layer_local,lightSource $ case () of+ () | skylight_intensity > 0.05 && sky_on ->+ mapLightSource (mapBoth $ scaleRGB 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 = proc sky_info ->+ do libraryA -< (scene_layer_distant,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 ->+ PointLight {+ lightsource_position = Point3D 0 (-10) 0,+ lightsource_radius = measure origin_point_3d+ (Point3D 0 (-10) 0),+ lightsource_color = sunColor $ sunInfoOf sky_info,+ lightsource_ambient = blackbody}+ () | otherwise -> NoLight)++lightingConfiguration :: (FRPModel m) => FRP e m SkyInfo LightingConfiguration+lightingConfiguration = proc sky_info ->+ do nightlight <- approachA 1.0 (perSecond 1.0) -< lighting_nightlight $ Models.Sky.lightingConfiguration sky_info+ 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 }