diff --git a/roguestar-gl.cabal b/roguestar-gl.cabal --- a/roguestar-gl.cabal +++ b/roguestar-gl.cabal @@ -1,5 +1,5 @@ name: roguestar-gl -version: 0.4.0.0 +version: 0.4.0.1 license: OtherLicense license-file: LICENSE author: Christopher Lane Hinson @@ -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 diff --git a/src/AnimationCreatures.hs b/src/AnimationCreatures.hs new file mode 100644 --- /dev/null +++ b/src/AnimationCreatures.hs @@ -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 } + diff --git a/src/AnimationEvents.hs b/src/AnimationEvents.hs new file mode 100644 --- /dev/null +++ b/src/AnimationEvents.hs @@ -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` ")" + + diff --git a/src/AnimationExtras.hs b/src/AnimationExtras.hs new file mode 100644 --- /dev/null +++ b/src/AnimationExtras.hs @@ -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 } + diff --git a/src/AnimationMenus.hs b/src/AnimationMenus.hs new file mode 100644 --- /dev/null +++ b/src/AnimationMenus.hs @@ -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 + diff --git a/src/AnimationTerrain.hs b/src/AnimationTerrain.hs new file mode 100644 --- /dev/null +++ b/src/AnimationTerrain.hs @@ -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 + diff --git a/src/AnimationTools.hs b/src/AnimationTools.hs new file mode 100644 --- /dev/null +++ b/src/AnimationTools.hs @@ -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) + diff --git a/src/EventUtils.hs b/src/EventUtils.hs new file mode 100644 --- /dev/null +++ b/src/EventUtils.hs @@ -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) + diff --git a/src/Globals.hs b/src/Globals.hs new file mode 100644 --- /dev/null +++ b/src/Globals.hs @@ -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 + diff --git a/src/MaybeArrow.hs b/src/MaybeArrow.hs new file mode 100644 --- /dev/null +++ b/src/MaybeArrow.hs @@ -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] diff --git a/src/Models/CyborgType4.hs b/src/Models/CyborgType4.hs new file mode 100644 --- /dev/null +++ b/src/Models/CyborgType4.hs @@ -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 diff --git a/src/Models/EnergySwords.hs b/src/Models/EnergySwords.hs new file mode 100644 --- /dev/null +++ b/src/Models/EnergySwords.hs @@ -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 diff --git a/src/Models/EnergyThings.hs b/src/Models/EnergyThings.hs new file mode 100644 --- /dev/null +++ b/src/Models/EnergyThings.hs @@ -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 + diff --git a/src/Models/Sky.hs b/src/Models/Sky.hs new file mode 100644 --- /dev/null +++ b/src/Models/Sky.hs @@ -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 + diff --git a/src/Models/Spheres.hs b/src/Models/Spheres.hs new file mode 100644 --- /dev/null +++ b/src/Models/Spheres.hs @@ -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 diff --git a/src/Scene.hs b/src/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Scene.hs @@ -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 diff --git a/src/Sky.hs b/src/Sky.hs new file mode 100644 --- /dev/null +++ b/src/Sky.hs @@ -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 }