Permalink
Browse files

Add cyborg stargate.

  • Loading branch information...
1 parent 0f4b3f5 commit 413fd12e58b69fdeb78f05ca972fe9066436532f @clanehin committed May 18, 2011
Showing with 321 additions and 357 deletions.
  1. +4 −0 .gitignore
  2. +1 −10 roguestar-engine/roguestar-engine.cabal
  3. +1 −1 roguestar-engine/src/Building.hs
  4. +0 −33 roguestar-engine/src/Stats.hs
  5. +0 −98 roguestar-engine/src/StatsData.hs
  6. +2 −1 roguestar-gl/src/Animation.hs
  7. +61 −3 roguestar-gl/src/AnimationBuildings.hs
  8. +19 −18 roguestar-gl/src/AnimationCreatures.hs
  9. +4 −4 roguestar-gl/src/AnimationExtras.hs
  10. +10 −7 roguestar-gl/src/AnimationTerrain.hs
  11. +3 −3 roguestar-gl/src/AnimationTools.hs
  12. +19 −23 roguestar-gl/src/AnimationVortex.hs
  13. +24 −4 roguestar-gl/src/CreatureData.hs
  14. +4 −3 roguestar-gl/src/Limbs.hs
  15. +6 −4 roguestar-gl/src/Models/Androsynth.hs
  16. +2 −1 roguestar-gl/src/Models/Caduceator.hs
  17. +2 −1 roguestar-gl/src/Models/Encephalon.hs
  18. +6 −3 roguestar-gl/src/Models/EnergyThings.hs
  19. +12 −0 roguestar-gl/src/Models/FactionData.hs
  20. +1 −1 roguestar-gl/src/Models/Hellion.hs
  21. +2 −0 roguestar-gl/src/Models/Library.hs
  22. +2 −0 roguestar-gl/src/Models/LibraryData.hs
  23. +9 −4 roguestar-gl/src/Models/Materials.hs
  24. +2 −2 roguestar-gl/src/Models/Node.hs
  25. +3 −3 roguestar-gl/src/Models/Recreant.hs
  26. +3 −2 roguestar-gl/src/Models/RecreantFactory.hs
  27. +2 −1 roguestar-gl/src/Models/Reptilian.hs
  28. +16 −16 roguestar-gl/src/Models/Sky.hs
  29. +23 −2 roguestar-gl/src/Models/Stargate.hs
  30. +5 −3 roguestar-gl/src/Models/Terrain.hs
  31. +1 −1 roguestar-gl/src/Models/Tree.hs
  32. +8 −8 roguestar-gl/src/ProtocolTypes.hs
  33. +4 −4 roguestar-gl/src/RenderingControl.hs
  34. +7 −7 roguestar-gl/src/Sky.hs
  35. +3 −6 roguestar-gl/src/VisibleObject.hs
  36. +0 −1 rsagl/RSAGL/Animation/AnimationExtras.hs
  37. +7 −6 rsagl/RSAGL/Animation/InverseKinematics.hs
  38. +4 −4 rsagl/RSAGL/Animation/Joint.hs
  39. +6 −6 rsagl/RSAGL/Extras/Sky.hs
  40. +2 −1 rsagl/RSAGL/Modeling/Model.hs
  41. +6 −7 rsagl/RSAGL/Modeling/ModelingExtras.hs
  42. +25 −55 rsagl/RSAGL/Scene/{Scene.lhs → Scene.hs}
View
4 .gitignore
@@ -1 +1,5 @@
.vim.makehere.sh
+.dist-scion
+.hsproject
+.project
+dist
View
11 roguestar-engine/roguestar-engine.cabal
@@ -23,16 +23,7 @@ executable roguestar-engine
mtl >=1.1.0.2, random >=1.0.0.2 && <1.1,
old-time >=1.0.0.3 && <1.1, array >=0.3.0.0 && <0.3.1,
containers >=0.3.0.0, base >=4 && <5
- other-modules: TravelData VisibilityData Stats FactionData Behavior
- Alignment PlaneData Grids Perception PlaneVisibility Turns Plane
- CreatureData StatsData Protocol Character Tool Substances
- HierarchicalDatabase Travel ToolData CharacterData Creature Facing
- DBPrivate RNG Species Position TerrainData Combat Tests DBData
- GridRayCaster BeginGame SpeciesData TimeCoordinate DB
- AttributeGeneration CreatureAttribute Building BuildingData Town
- Random PlayerState MakeData DBErrorFlag Construction Make Activate
- Contact DeviceActivation WorkCluster Planet PlanetData Logging
- NodeData CharacterAdvancement
+ other-modules: TravelData, VisibilityData, FactionData, Behavior, Alignment, PlaneData, Grids, Perception, PlaneVisibility, Turns, Plane, CreatureData, Protocol, Character, Tool, Substances, HierarchicalDatabase, Travel, ToolData, CharacterData, Creature, Facing, DBPrivate, RNG, Species, Position, TerrainData, Combat, Tests, DBData, GridRayCaster, BeginGame, SpeciesData, TimeCoordinate, DB, AttributeGeneration, CreatureAttribute, Building, BuildingData, Town, Random, PlayerState, MakeData, DBErrorFlag, Construction, Make, Activate, Contact, DeviceActivation, WorkCluster, Planet, PlanetData, Logging, NodeData, CharacterAdvancement
ghc-prof-options: -prof -auto-all
ghc-shared-options: -prof -auto-all
if impl(ghc >= 7.0)
View
2 roguestar-engine/src/Building.hs
@@ -86,7 +86,7 @@ portalCreatureTo :: BuildingType -> Integer -> CreatureRef -> PlaneRef -> DB (Lo
portalCreatureTo building_type offset creature_ref plane_ref =
do portals <- filterM (liftM (== building_type) . buildingType) =<< dbGetContents plane_ref
ideal_position <- if null portals
- then liftM2 (\x y -> Position (x,y)) (getRandomR (-100,100)) (getRandomR (-100,100))
+ then liftM2 (\x y -> Position (x,y)) (getRandomR (-40,40)) (getRandomR (-40,40))
else do portal <- pickM portals
m_position <- liftM (fmap (offsetPosition (0,offset)) . extractParent) $ dbWhere portal
return $ fromMaybe (Position (0,0)) m_position
View
33 roguestar-engine/src/Stats.hs
@@ -1,33 +0,0 @@
-
-module Stats (generateStats)
- where
-
-import Dice
-import StatsData
-import DB
-
---
--- Randomly generate 1 statistic.
---
-generate1Stat :: Integer -> Integer -> DB Integer
-generate1Stat minimal range = roll $ concat [[minimal..minimal+i] | i <- [0..range]]
-
---
--- Randomly generate statistics.
---
-generateStats :: Stats -> Stats -> DB Stats
-generateStats minimums ranges =
- do new_str <- generate1Stat (str minimums) (str ranges)
- new_dex <- generate1Stat (dex minimums) (dex ranges)
- new_con <- generate1Stat (con minimums) (con ranges)
- new_int <- generate1Stat (int minimums) (int ranges)
- new_per <- generate1Stat (per minimums) (per ranges)
- new_cha <- generate1Stat (cha minimums) (cha ranges)
- new_mind <- generate1Stat (mind minimums) (mind ranges)
- return Stats { strength = new_str,
- dexterity = new_dex,
- constitution = new_con,
- intelligence = new_int,
- perception = new_per,
- charisma = new_cha,
- mindfulness = new_mind }
View
98 roguestar-engine/src/StatsData.hs
@@ -1,98 +0,0 @@
-
-module StatsData
- (Stats(..),
- StatisticsBlock(..),
- Statistic(..),
- stats,
- getStatistic,
- setStatistic)
- where
-
-class StatisticsBlock a where
- str :: a -> Integer
- dex :: a -> Integer
- con :: a -> Integer
- int :: a -> Integer
- per :: a -> Integer
- cha :: a -> Integer
- mind :: a -> Integer
-
--- |
--- Represents the seven roguestar creature statistics:
--- Strength (str)
--- Dexterity (dex)
--- Constitution (con)
--- Intelligence (int)
--- Perception (per)
--- Charisma (cha)
--- Mindfulness (min)
---
-
-data Stats = Stats {strength, dexterity, constitution, intelligence, perception, charisma, mindfulness :: Integer} deriving (Show, Read)
-
-instance StatisticsBlock Stats where
- str = strength
- dex = dexterity
- con = constitution
- int = intelligence
- per = perception
- cha = charisma
- mind = mindfulness
-
-data Statistic = Strength
- | Dexterity
- | Constitution
- | Intelligence
- | Perception
- | Charisma
- | Mindfulness
- deriving (Eq,Read,Show)
-
-getStatistic :: StatisticsBlock a => Statistic -> a -> Integer
-getStatistic Strength = str
-getStatistic Dexterity = dex
-getStatistic Constitution = con
-getStatistic Intelligence = int
-getStatistic Perception = per
-getStatistic Charisma = cha
-getStatistic Mindfulness = mind
-
-setStatistic :: Statistic -> Integer -> Stats -> Stats
-setStatistic Strength = setStr
-setStatistic Dexterity = setDex
-setStatistic Constitution = setCon
-setStatistic Intelligence = setInt
-setStatistic Perception = setPer
-setStatistic Charisma = setCha
-setStatistic Mindfulness = setMind
-
--- |
--- Used to generate a Stats object with all the same stats (i.e. stats 1 => Stats 1 1 1 1 1 1 1)
---
-
-stats :: Integer -> Stats
-stats x = (Stats {strength=x, dexterity=x, constitution=x, intelligence=x, perception=x, charisma=x, mindfulness=x})
-
--- |
--- Functions to modify a single stat in a Stats block.
---
-setStr :: Integer -> Stats -> Stats
-setStr x st = st { strength = x }
-
-setDex :: Integer -> Stats -> Stats
-setDex x st = st { dexterity = x }
-
-setCon :: Integer -> Stats -> Stats
-setCon x st = st { constitution = x }
-
-setInt :: Integer -> Stats -> Stats
-setInt x st = st { intelligence = x }
-
-setPer :: Integer -> Stats -> Stats
-setPer x st = st { perception = x }
-
-setCha :: Integer -> Stats -> Stats
-setCha x st = st { charisma = x }
-
-setMind :: Integer -> Stats -> Stats
-setMind x st = st { mindfulness = x }
View
3 roguestar-gl/src/Animation.hs
@@ -174,11 +174,11 @@ suspendedSTMAction action = proc i ->
animstate_suspended_stm_action s >> action i }
-- | Print a line of text to the game console. This will print exactly once.
--- Accepts 'Nothing' and prints once immediately when a value is supplied.
printTextOnce :: (FRPModel m, StateOf m ~ AnimationState) =>
FRP e m (Maybe (TextType,B.ByteString)) ()
printTextOnce = onceA printTextA
+-- | Print a line of text to the game console on every frame of animation.
printTextA :: (FRPModel m, StateOf m ~ AnimationState) =>
FRP e m (Maybe (TextType,B.ByteString)) ()
printTextA = proc pt_data ->
@@ -189,6 +189,7 @@ printTextA = proc pt_data ->
printText print_text_object pt_type pt_string)
-< (print_text_object,pt_data)
+-- | Print a line of text to the status window (e.g. current hit points, compass).
statusA :: (FRPModel m, StateOf m ~ AnimationState) =>
FRP e m (Maybe (StatusField,B.ByteString)) ()
statusA = proc status_data ->
View
64 roguestar-gl/src/AnimationBuildings.hs
@@ -30,6 +30,7 @@ buildingAvatar = proc () ->
where switchTo "monolith" = simpleBuildingAvatar Monolith
switchTo "anchor" = planetaryAnchorAvatar
switchTo "portal" = simpleBuildingAvatar Portal
+ switchTo "cybergate" = cybergateBuildingAvatar
switchTo _ = questionMarkAvatar >>> arr (const ())
simpleBuildingAvatar :: (FRPModel m, LibraryModelSource lm) =>
@@ -48,17 +49,74 @@ genericBuildingAvatar actionA = proc () ->
(\o -> (o,())) m_orientation
returnA -< ()
+cybergateBuildingAvatar :: (FRPModel m) =>
+ BuildingAvatar e m
+cybergateBuildingAvatar = genericBuildingAvatar $ proc () ->
+ do transformA libraryA -< (affineOf $ translate (Vector3D 0 (-0.5) 0),
+ (scene_layer_local,SimpleModel Cybergate))
+ transformA libraryA -< (affineOf $ translate (Vector3D (-1) (-1) 0) . scale (Vector3D 1 1 1.5),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ transformA libraryA -< (affineOf $ translate (Vector3D (-2) (-2) 0) . scale (Vector3D 1 1 1),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ transformA libraryA -< (affineOf $ translate (Vector3D (-3) (-3) 0) . scale (Vector3D 1 1 0.5),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ transformA libraryA -< (affineOf $ translate (Vector3D 1 (-1) 0) . scale (Vector3D 1 1 1.5),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ transformA libraryA -< (affineOf $ translate (Vector3D 2 (-2) 0) . scale (Vector3D 1 1 1),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ transformA libraryA -< (affineOf $ translate (Vector3D 3 (-3) 0) . scale (Vector3D 1 1 0.5),
+ (scene_layer_local,SimpleModel Cyberpylon))
+ lightningBolt -< (Green, Point3D (-3) (-3) 0.5,Point3D (-2) (-2) 1.0)
+ lightningBolt -< (Green, Point3D (-2) (-2) 1.0,Point3D (-1) (-1) 1.5)
+ lightningBolt -< (Green, Point3D (3) (-3) 0.5,Point3D (2) (-2) 1.0)
+ lightningBolt -< (Green, Point3D (2) (-2) 0.5,Point3D (1) (-1) 1.5)
+ random_height <- randomA -< (-0.5,0.99 :: RSdouble)
+ let width = sqrt $ 1.0 - random_height^2
+ lightningBolt -< (Green, Point3D (-1) (-1) 0.5,Point3D (-width) (-0.5) (random_height*1.5+1.5))
+ lightningBolt -< (Green, Point3D (1) (-1) 0.5, Point3D width (-0.5) (random_height*1.5+1.5))
+
+lightningBolt :: (FRPModel m, StateOf m ~ AnimationState, InputOutputOf m ~ Enabled) =>
+ FRP e m (EnergyColor, Point3D, Point3D) ()
+lightningBolt = proc (e,p1,p5) ->
+ do let radius = 0.01
+ p2 <- randomLightningPoint -< (0.25,1,p1,p5)
+ p3 <- randomLightningPoint -< (0.25,2,p1,p5)
+ p4 <- randomLightningPoint -< (0.25,3,p1,p5)
+ lightningBoltSegment -< (e,radius,p1,p2)
+ lightningBoltSegment -< (e,radius,p2,p3)
+ lightningBoltSegment -< (e,radius,p3,p4)
+ lightningBoltSegment -< (e,radius,p4,p5)
+
+randomLightningPoint :: (FRPModel m, StateOf m ~ AnimationState) => FRP e m (RSdouble,Integer,Point3D,Point3D) Point3D
+randomLightningPoint = proc (interval,u,a,b) ->
+ do let p_base = lerp (max 0 $ min 1 $ fromInteger u*interval) (a,b)
+ let scale_factor = interval * (distanceBetween a b)
+ x <- randomA -< (-1,1)
+ y <- randomA -< (-1,1)
+ z <- randomA -< (-1,1)
+ returnA -< translate (vectorScaleTo scale_factor $ Vector3D x y z) p_base
+
+lightningBoltSegment :: (FRPModel m, StateOf m ~ AnimationState, InputOutputOf m ~ Enabled) =>
+ FRP e m (EnergyColor,RSdouble,Point3D,Point3D) ()
+lightningBoltSegment = proc (e,radius,a,b) ->
+ do transformA libraryA -< (affineOf $ translate (vectorToFrom b origin_point_3d) .
+ rotateToFrom (vectorToFrom a b) (Vector3D 0 1 0) .
+ scale (Vector3D radius (distanceBetween a b) radius),
+ (scene_layer_local,EnergyThing EnergyCylinder e))
+
+
+
planetaryAnchorAvatar :: (FRPModel m) => BuildingAvatar e m
-planetaryAnchorAvatar = genericBuildingAvatar $ translate (Vector3D 0 1.0 0) $ proc () ->
+planetaryAnchorAvatar = genericBuildingAvatar $ translate (Vector3D 0 0.0 1.0) $ proc () ->
do libraryA -< (scene_layer_local,PlanetaryAnchorCore)
planetaryAnchorFlange (1.1^1) (fromDegrees 25) (fromDegrees 30) 10.0 -< ()
planetaryAnchorFlange (1.1^2) (fromDegrees 50) (fromDegrees 60) 9.0 -< ()
planetaryAnchorFlange (1.1^3) (fromDegrees 75) (fromDegrees 90) 7.0 -< ()
planetaryAnchorFlange (1.1^4) (fromDegrees 100) (fromDegrees 120) 4.0 -< ()
planetaryAnchorFlange (1.1^5) (fromDegrees 125) (fromDegrees 150) 1.0 -< ()
accumulateSceneA -< (scene_layer_local,
- lightSource $ PointLight (Point3D 0 1.0 0)
- (measure (Point3D 0 1.0 0) (Point3D 1 0 1))
+ lightSource $ PointLight (Point3D 0 0.0 1.0)
+ (measure (Point3D 0 0.0 1.0) (Point3D 0 0 0))
white
violet)
View
37 roguestar-gl/src/AnimationCreatures.hs
@@ -17,6 +17,7 @@ import Scene
import AnimationExtras
import AnimationVortex
import CreatureData
+import qualified Data.ByteString.Char8 as B
-- | Avatar for any creature that automatically switches to the appropriate species-specific avatar thread.
creatureAvatar :: (FRPModel m) => CreatureAvatar e m
@@ -36,30 +37,30 @@ creatureAvatar = proc () ->
switchTo _ = questionMarkAvatar
encephalonAvatar :: (FRPModel m) => CreatureAvatar e m
-encephalonAvatar = genericCreatureAvatar $ proc () ->
+encephalonAvatar = genericCreatureAvatar normal $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Encephalon)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D 0.66 0.66 0) (Point3D 0.145 0.145 0) 0.33 (Point3D 0.35 0.066 0.133) -< (FactionedModel faction MachineArmUpper,FactionedModel faction MachineArmLower)
+ bothArms (Vector3D 0.66 0 0.66) (Point3D 0.145 0 0.145) 0.33 (Point3D 0.35 0.133 0.0666) -< (FactionedModel faction MachineArmUpper,FactionedModel faction MachineArmLower)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
recreantAvatar :: (FRPModel m) => CreatureAvatar e m
-recreantAvatar = genericCreatureAvatar $ floatBobbing 0.25 0.4 $ proc () ->
+recreantAvatar = genericCreatureAvatar normal $ floatBobbing 0.25 0.4 $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Recreant)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D 0 (-1.0) 0) (Point3D 0.3 0.075 0) 0.5 (Point3D 0.5 0.075 0.2) -< (FactionedModel faction MachineArmUpper,FactionedModel faction MachineArmLower)
+ bothArms (Vector3D 0 0 (-1.0)) (Point3D 0.3 0 0.075) 0.5 (Point3D 0.5 0.2 0.075) -< (FactionedModel faction MachineArmUpper,FactionedModel faction MachineArmLower)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
androsynthAvatar :: (FRPModel m) => CreatureAvatar e m
-androsynthAvatar = genericCreatureAvatar $ proc () ->
+androsynthAvatar = genericCreatureAvatar normal $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Androsynth)
- bothLegs Upright (Vector3D 0 0 1) (Point3D (0.07) 0.5 (-0.08)) 0.55 (Point3D 0.07 0 0.0) -< (FactionedModel faction ThinLimb, FactionedModel faction ThinLimb)
+ bothLegs Upright (Vector3D 0 1 0) (Point3D 0.07 0 0.5) 0.54 (Point3D 0.07 0 0) -< (FactionedModel faction ThinLimb, FactionedModel faction ThinLimb)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D (1.0) (-1.0) (-1.0)) (Point3D 0.05 0.65 0.0) 0.45 (Point3D 0.15 0.34 0.1) -< (FactionedModel faction ThinLimb,FactionedModel faction ThinLimb)
+ bothArms (Vector3D (1.0) (-1.0) (-1.0)) (Point3D 0.05 0.0 0.65) 0.45 (Point3D 0.15 0.1 0.34) -< (FactionedModel faction ThinLimb,FactionedModel faction ThinLimb)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
@@ -81,37 +82,37 @@ dustVortexAvatar :: (FRPModel m) => CreatureAvatar e m
dustVortexAvatar = particleAvatar dust_vortex 12 (SimpleModel DustPuff) Nothing
caduceatorAvatar :: (FRPModel m) => CreatureAvatar e m
-caduceatorAvatar = genericCreatureAvatar $ proc () ->
+caduceatorAvatar = genericCreatureAvatar normal $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Caduceator)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D 1.0 (-1.0) 1.0) (Point3D 0.1 0.15 0.257) 0.34 (Point3D 0.02 0.17 0.4) -< (FactionedModel faction CaduceatorArmUpper, FactionedModel faction CaduceatorArmLower)
+ bothArms (Vector3D 1.0 1.0 (-1.0)) (Point3D 0.1 0.257 0.15) 0.34 (Point3D 0.02 0.4 0.17) -< (FactionedModel faction CaduceatorArmUpper, FactionedModel faction CaduceatorArmLower)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
reptilianAvatar :: (FRPModel m) => CreatureAvatar e m
-reptilianAvatar = genericCreatureAvatar $ proc () ->
+reptilianAvatar = genericCreatureAvatar normal $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Reptilian)
- bothLegs Upright (Vector3D 0 0 1) (Point3D (0.05) 0.25 (-0.1)) 0.29 (Point3D 0.07 0 0.0) -< (FactionedModel faction ReptilianLegUpper,FactionedModel faction ReptilianLegLower)
+ bothLegs Upright (Vector3D 0 1 0) (Point3D (0.05) (-0.1) 0.25) 0.29 (Point3D 0.07 0 0) -< (FactionedModel faction ReptilianLegUpper,FactionedModel faction ReptilianLegLower)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D 1.0 0.0 1.0) (Point3D (0.05) 0.35 (-0.1)) 0.25 (Point3D 0.07 0.25 0.12) -< (FactionedModel faction ReptilianArmUpper, FactionedModel faction ReptilianArmLower)
+ bothArms (Vector3D 1.0 1.0 0.0) (Point3D (0.05) (-0.1) 0.35) 0.25 (Point3D 0.07 0.12 0.25) -< (FactionedModel faction ReptilianArmUpper, FactionedModel faction ReptilianArmLower)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
hellionAvatar :: (FRPModel m) => CreatureAvatar e m
-hellionAvatar = genericCreatureAvatar $ proc () ->
+hellionAvatar = genericCreatureAvatar normal $ proc () ->
do faction <- objectFaction ThisObject -< ()
libraryA -< (scene_layer_local,FactionedModel faction Hellion)
- bothEyeStalks (Vector3D (0.1) 0 (-1))
- (Point3D 0.06 0.55 0)
+ bothEyeStalks (Vector3D (0.1) (-1) 0)
+ (Point3D 0.06 0 0.55)
1.2
- (Point3D 0.2 0.8 0.05) -< (FactionedModel faction HellionAppendage,
+ (Point3D 0.2 0.05 0.8) -< (FactionedModel faction HellionAppendage,
FactionedModel faction HellionAppendage,
FactionedModel faction HellionEye)
- bothLegs Upright (Vector3D 0.5 0 (-1)) (Point3D 0.05 0.55 0) 0.8 (Point3D 0.05 0 0) -< (FactionedModel faction HellionAppendage,FactionedModel faction HellionAppendage)
+ bothLegs Upright (Vector3D 0.5 (-1) 0) (Point3D 0.05 0 0.55) 0.8 (Point3D 0.05 0 0) -< (FactionedModel faction HellionAppendage,FactionedModel faction HellionAppendage)
wield_point <- exportCoordinateSystem <<< arr (joint_arm_hand . snd) <<<
- bothArms (Vector3D 1.0 0.0 (-0.5)) (Point3D 0.1 0.6 0) 0.4 (Point3D 0.3 0.25 0.3) -< (FactionedModel faction HellionAppendage,FactionedModel faction HellionAppendage)
+ bothArms (Vector3D 1.0 (-0.5) 0) (Point3D 0.1 0 0.6) 0.4 (Point3D 0.3 0.3 0.25) -< (FactionedModel faction HellionAppendage,FactionedModel faction HellionAppendage)
returnA -< CreatureThreadOutput {
cto_wield_point = wield_point }
View
8 roguestar-gl/src/AnimationExtras.hs
@@ -34,8 +34,8 @@ genericStateHeader switchTo f = proc i ->
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)
+ let float_z = lerpBetween (-1,sine $ fromRotations $ t `cyclical'` (fromSeconds 5),1) (ay,by)
+ transformA animationA -< (Affine $ translate (Vector3D 0 0 float_z),j)
-- | Get new elements in a list on a frame-by-frame basis.
newListElements :: (FRPModel m,Eq a) => FRP e m [a] [a]
@@ -47,7 +47,7 @@ newListElements = proc as ->
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_lookat = Point3D 0 1 0,
+ camera_up = Vector3D 0 0 1,
camera_fov = fromDegrees 45 }
View
17 roguestar-gl/src/AnimationTerrain.hs
@@ -18,6 +18,9 @@ import Models.LibraryData
import ProtocolTypes
import Scene
import AnimationExtras
+import qualified Data.ByteString.Char8 as B
+import RSAGL.Scene
+import Control.Arrow.Operations
type TerrainThreadSwitch m = RSwitch Enabled (Maybe ProtocolTypes.TerrainTile) () () m
@@ -38,7 +41,7 @@ terrainTile (tid@(ProtocolTypes.TerrainTile terrain_type (x,y))) = proc () ->
killThreadIf -< actual_size <= 0.0 && not still_here
transformA (libraryA >>> terrainDecoration tid) -<
(Affine $ translate
- (Vector3D (fromInteger x) 0 (negate $ fromInteger y)) .
+ (Vector3D (fromInteger x) (fromInteger y) 0) .
scale' actual_size,
(scene_layer_local,Models.LibraryData.TerrainTile terrain_type))
returnA -< ()
@@ -68,8 +71,8 @@ leafyTree recursion has_leaves =
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)
+ leafyTreeBranch (Point3D x y 0)
+ (Vector3D 0 0 push_up)
thickness
recursion
(has_leaves && not dead_tree)
@@ -93,9 +96,9 @@ leafyTreeBranch point vector thickness recursion has_leaves =
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) $
+ let this_branch = translateToFrom point origin_point_3d $
+ rotateToFrom vector (Vector3D 0 0 1) $
+ scale (Vector3D thickness thickness (vectorLength vector)) $
proc () -> libraryA -< (scene_layer_local,TreeBranch)
return $ this_branch >>> continue_trunk >>> foldr1 (>>>) other_branches
where leafyTreeBranchFrom :: (FRPModel m, FRPModes m ~ RoguestarModes) =>
@@ -106,7 +109,7 @@ leafyTreeBranch point vector thickness recursion has_leaves =
new_vector_constraint)
t <- getRandomR (thickness/3,thickness/2)
leafyTreeBranch
- (lerp u (point,translate vector point))
+ (lerp u (point,translate (scale' 0.66 vector) point))
(vectorScaleTo new_vector_constraint $
vector `add` (Vector3D x y z))
t
View
6 roguestar-gl/src/AnimationTools.hs
@@ -65,8 +65,8 @@ phaseWeaponAvatar phase_weapon_model weapon_size = proc tti ->
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_position = Point3D 0 0 (0.15 + t*t*realToFrac weapon_size),
+ lightsource_radius = measure (Point3D 0 (0.5*realToFrac weapon_size) 0) (Point3D 0 0 0),
lightsource_color = grayscale $ 1.0 - t,
lightsource_ambient = grayscale $ (1.0 - t)^2 }
_ | otherwise -> NoLight)
@@ -97,7 +97,7 @@ energySwordAvatar energy_color sword_size = proc tti ->
libraryA -< (scene_layer_local,
EnergyThing EnergySword energy_color)
transformA libraryA -<
- (Affine $ translate (Vector3D 0 2.9 0) .
+ (Affine $ translate (Vector3D 0 0 2.9) .
scale (Vector3D 1 blade_length 1),
(scene_layer_local,
EnergyThing EnergyCylinder energy_color))
View
42 roguestar-gl/src/AnimationVortex.hs
@@ -47,10 +47,10 @@ data Vortex = Vortex {
vortex :: Vortex
vortex = Vortex {
vortex_height = 0.5,
- vortex_containment = 100,
+ vortex_containment = 20,
vortex_drag = 1.0,
vortex_binding = 0,
- vortex_repulsion = 1.0,
+ vortex_repulsion = 0.25,
vortex_rotation = const 1.0,
vortex_base_angle = fromDegrees 0,
vortex_base_force = 10,
@@ -60,7 +60,7 @@ vortexForceFunction :: Vortex -> [(Point3D,Rate Vector3D)] -> ForceFunction
vortexForceFunction v particles =
concatForces [
-- Bind the entire system to the origin of the local coordinate system.
- quadraticTrap (vortex_containment v) (Point3D 0 (vortex_height v) 0),
+ quadraticTrap (vortex_containment v) (Point3D 0 0 (vortex_height v)),
-- Damp down runaway behavior.
drag (vortex_drag v),
-- Repulse points that get too close.
@@ -70,20 +70,20 @@ vortexForceFunction v particles =
(map fst particles),
-- Attract points that wonder too far away.
concatForces $ map (quadraticTrap (vortex_binding v) . fst) particles,
- -- Swirl points around the y axis.
+ -- Swirl points around the z axis.
\_ p _ -> perSecond $ perSecond $
(vectorNormalize $ vectorToFrom origin_point_3d p) `crossProduct`
- (Vector3D 0 (vortex_rotation v $ distanceBetween origin_point_3d p) 0),
+ (Vector3D 0 0 (vortex_rotation v $ distanceBetween origin_point_3d p)),
-- Bounce off the ground.
constrainForce (\ _ (Point3D x y z) _ ->
fromDegrees 90 `sub`
angleBetween (vectorToFrom (Point3D x y z) origin_point_3d)
- (Vector3D 0 1 0)
+ (Vector3D 0 0 1)
< vortex_base_angle v) $
- \_ (Point3D x _ z) _ -> perSecond $ perSecond $ vectorScaleTo (vortex_base_force v) $
- vectorScaleTo (sine $ vortex_base_angle v) (Vector3D (-x) 0 (-z)) `add`
- (Vector3D 0 (cosine $ vortex_base_angle v) 0),
- \_ _ _ -> perSecond $ perSecond $ Vector3D 0 (negate $ vortex_gravity v) 0
+ \_ (Point3D x y _) _ -> perSecond $ perSecond $ vectorScaleTo (vortex_base_force v) $
+ vectorScaleTo (sine $ vortex_base_angle v) (Vector3D (-x) (-y) 0) `add`
+ (Vector3D 0 0 (cosine $ vortex_base_angle v)),
+ \_ _ _ -> perSecond $ perSecond $ Vector3D 0 0 (negate $ vortex_gravity v)
]
glower :: (FRPModel m, FRPModes m ~ RoguestarModes,
@@ -100,33 +100,29 @@ glower library_model = proc (p,_,_) ->
random_particles :: [(Point3D,Rate Vector3D)]
random_particles = makeAParticle vs
- where makeAParticle (a:b:c:d:e:f:xs) = (Point3D a (b+0.5) c,perSecond $ Vector3D d e f) : makeAParticle xs
+ where makeAParticle (a:b:c:d:e:f:xs) = (Point3D a b (c+0.5),perSecond $ Vector3D d e f) : makeAParticle xs
makeAParticle _ = error "Debauchery is perhaps an act of despair in the face of infinity."
vs = randomRs (-0.5,0.5) $ mkStdGen 5
particleAvatar :: (FRPModel m) => Vortex -> Integer -> LibraryModel -> (Maybe RGB) -> CreatureAvatar e m
-particleAvatar vortex_spec num_particles library_model m_color = genericCreatureAvatar $ proc () ->
+particleAvatar vortex_spec num_particles library_model m_color = genericCreatureAvatar nonrotating $ proc () ->
do a <- inertia root_coordinate_system origin_point_3d -< ()
particles <- particleSystem fps120 (genericTake num_particles random_particles) -<
\particles -> concatForces [vortexForceFunction vortex_spec particles, \_ _ _ -> a]
- glower library_model -< particles !! 0
- glower library_model -< particles !! 1
- glower library_model -< particles !! 2
- glower library_model -< particles !! 3
- glower library_model -< particles !! 4
- glower library_model -< particles !! 5
- glower library_model -< particles !! 6
- glower library_model -< particles !! 7
+ (foldr1 (<<<) $ flip map [1..num_particles] $
+ \_ -> proc particles ->
+ do glower library_model -< head particles
+ returnA -< tail particles) -< particles
accumulateSceneA -< (scene_layer_local,
lightSource $
case m_color of
- Just color -> PointLight (Point3D 0 0.5 0)
- (measure (Point3D 0 0.5 0) (Point3D 0 0 0))
+ Just color -> PointLight (abstractAverage $ map (\(p,_,_) -> p) particles)
+ (measure (Point3D 0 0 0.5) (Point3D 0 0 0))
color
color
Nothing -> NoLight)
t <- threadTime -< ()
- wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.5 0)
+ wield_point <- exportCoordinateSystem -< translate (rotateY (fromRotations $ t `cyclical'` (fromSeconds 3)) $ Vector3D 0.25 0.0 0.5)
returnA -< (CreatureThreadOutput {
cto_wield_point = wield_point })
View
28 roguestar-gl/src/CreatureData.hs
@@ -3,22 +3,42 @@
module CreatureData
(CreatureAvatarSwitch,
CreatureAvatar,
+ CreatureAvatarConfiguration,
+ normal,
+ nonrotating,
genericCreatureAvatar)
where
import RSAGL.FRP
import RSAGL.Scene
+import RSAGL.Math
import VisibleObject
import Data.Maybe
import Control.Arrow
type CreatureAvatarSwitch m = AvatarSwitch () (Maybe CreatureThreadOutput) m
type CreatureAvatar e m = FRP e (AvatarSwitch () (Maybe CreatureThreadOutput) m) () (Maybe CreatureThreadOutput)
-genericCreatureAvatar :: (FRPModel m) => FRP e (CreatureAvatarSwitch m) () CreatureThreadOutput -> CreatureAvatar e m
-genericCreatureAvatar creatureA = proc () ->
+data CreatureAvatarConfiguration = CreatureAvatarConfiguration {
+ should_rotate :: Bool }
+
+normal :: CreatureAvatarConfiguration
+normal = CreatureAvatarConfiguration {
+ should_rotate = True }
+
+nonrotating :: CreatureAvatarConfiguration
+nonrotating = CreatureAvatarConfiguration {
+ should_rotate = False }
+
+genericCreatureAvatar :: (FRPModel m) =>
+ CreatureAvatarConfiguration ->
+ FRP e (CreatureAvatarSwitch m) () CreatureThreadOutput -> CreatureAvatar e m
+genericCreatureAvatar config creatureA = proc () ->
do visibleObjectHeader -< ()
+ m_position_info <- objectIdealPosition ThisObject -< ()
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,())
+ let m_coordinate_system = if (should_rotate config) then m_orientation else
+ fmap (\position -> translate (vectorToFrom position origin_point_3d) root_coordinate_system) m_position_info
+ switchTerminate -< if isNothing m_orientation then (Just $ genericCreatureAvatar config creatureA,Nothing) else (Nothing,Nothing)
+ arr Just <<< transformA creatureA -< (fromMaybe (error "genericCreatureAvatar: fromMaybe") m_coordinate_system,())
View
7 roguestar-gl/src/Limbs.hs
@@ -75,9 +75,9 @@ rightArm bend_vector shoulder_anchor maximum_length hand_rest = proc (arm_upper,
is_wielding <- isWielding ThisObject -< ()
hand_point <- approachA 0.1 (perSecond 1.0) -< case m_time_recent_attack of
Just t | t_now < t `add` fromSeconds 0.5 && m_tool_type == Just "sword" -> translate (Vector3D maximum_length 0 0) shoulder_anchor
- Just t | t_now < t `add` fromSeconds 0.3 && m_tool_type == Nothing -> translate (Vector3D 0 0 $ maximum_length / 4) shoulder_anchor
- Just t | t_now < t `add` fromSeconds 1.0 && m_tool_type == Nothing -> translate (Vector3D 0 0 maximum_length) shoulder_anchor
- _ | is_wielding -> translate (Vector3D 0 0 maximum_length) shoulder_anchor
+ Just t | t_now < t `add` fromSeconds 0.3 && m_tool_type == Nothing -> translate (Vector3D 0 (maximum_length / 4) 0) shoulder_anchor
+ Just t | t_now < t `add` fromSeconds 1.0 && m_tool_type == Nothing -> translate (Vector3D 0 maximum_length 0) shoulder_anchor
+ _ | is_wielding -> translate (Vector3D 0 maximum_length 0) shoulder_anchor
_ | otherwise -> hand_rest
arm bend_vector maximum_length -< (shoulder_anchor,hand_point,arm_upper,arm_lower)
@@ -147,3 +147,4 @@ bothLegs style
swapX :: (AffineTransformable a) => a -> a
swapX = scale (Vector3D (-1.0) 1.0 1.0)
+
View
10 roguestar-gl/src/Models/Androsynth.hs
@@ -10,7 +10,8 @@ import Models.Factions
import Models.FactionData
androsynth_head :: Faction -> Quality -> Modeling
-androsynth_head f _ = model $
+androsynth_head f _ = rotate (Vector3D 0 0 1) (fromDegrees 180) $
+ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $ model $
do model $
do smoothbox 0.2 (Point3D (-2) 0 (-2)) (Point3D (-3) 10 (-5)) -- side panels/"ears"
smoothbox 0.2 (Point3D 2 0 (-2)) (Point3D 3 10 (-5))
@@ -35,7 +36,8 @@ androsynth_head f _ = model $
concordance_dark_glass
androsynth_body :: Faction -> Quality -> Modeling
-androsynth_body f _ = model $
+androsynth_body f _ = rotate (Vector3D 0 0 1) (fromDegrees 180) $
+ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $ model $
do model $
do smoothbox 0.2 (Point3D (-2) 7 (-2.5)) (Point3D 2 8 2.5)
smoothbox 0.2 (Point3D (-3) 0 (-3.5)) (Point3D 3 1 3.5)
@@ -46,8 +48,8 @@ androsynth :: Faction -> Quality -> Modeling
androsynth f q = model $
do model $
do androsynth_head f q
- affine $ translate (Vector3D 0 30 0)
+ affine $ translate (Vector3D 0 0 30)
model $
do androsynth_body f q
- affine $ translate (Vector3D 0 20 0)
+ affine $ translate (Vector3D 0 0 20)
affine $ scale' (1/40)
View
3 roguestar-gl/src/Models/Caduceator.hs
@@ -13,7 +13,8 @@ import Models.Factions
import Models.FactionData
caduceator :: Faction -> Quality -> Modeling
-caduceator f _ = model $
+caduceator f _ = rotate (Vector3D 0 0 1) (fromDegrees 180) $
+ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $ model $
do model $
do tube $ linearInterpolation
[(0,Point3D 0 0 (-5)),
View
3 roguestar-gl/src/Models/Encephalon.hs
@@ -46,7 +46,8 @@ encephalon_suit f _ = model $
material $ metal f
encephalon :: Faction -> Quality -> Modeling
-encephalon f q = model $ scale' (1/30) $
+encephalon f q = rotate (Vector3D 0 0 1) (fromDegrees 180) $
+ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $ model $ scale' (1/30) $
do encephalon_head f q
encephalon_suit f q
translate (Vector3D (-1) 6 4) $ encephalon_eye f q
View
9 roguestar-gl/src/Models/EnergyThings.hs
@@ -10,7 +10,10 @@ import RSAGL.Color.RSAGLColors
energyCylinder :: EnergyColor -> Quality -> Modeling
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
+ do model $
+ do closedCone (Point3D 0 0 0,1.0) (Point3D 0 1 0,1.0)
+ material $ emissive $ pure $ energyColor c
+ model $
+ do closedCone (Point3D 0 0 0,0.75) (Point3D 0 1 0,0.75)
+ material $ emissive $ pure $ white
View
12 roguestar-gl/src/Models/FactionData.hs
@@ -0,0 +1,12 @@
+
+module Models.FactionData
+ (Faction(..))
+ where
+
+data Faction =
+ Player
+ | Nonaligned
+ | Monsters
+ | Cyborg
+ | Gray
+ deriving (Eq, Ord, Show)
View
2 roguestar-gl/src/Models/Hellion.hs
@@ -15,7 +15,7 @@ import Models.FactionData
hellion :: Faction -> Quality -> Modeling
hellion f _ = model $
- do sphere (Point3D 0 0.6 0) 0.1
+ do sphere (Point3D 0 0 0.6) 0.1
material $ skin f hellion_skin
hellion_appendage :: Faction -> Quality -> Modeling
View
2 roguestar-gl/src/Models/Library.hs
@@ -88,6 +88,8 @@ toModel (SimpleModel Monolith) = monolith
toModel (SimpleModel PlanetaryAnchorCore) = planetary_anchor_core
toModel (SimpleModel PlanetaryAnchorFlange) = planetary_anchor_flange
toModel (SimpleModel Portal) = portal
+toModel (SimpleModel Cybergate) = cybergate
+toModel (SimpleModel Cyberpylon) = cyberpylon
-- |
-- Models that should be displayed at lower quality.
View
2 roguestar-gl/src/Models/LibraryData.hs
@@ -39,6 +39,8 @@ data SimpleModel =
| PlanetaryAnchorCore
| PlanetaryAnchorFlange
| Portal
+ | Cybergate
+ | Cyberpylon
deriving (Eq,Ord,Show,Enum,Bounded)
data EnergyThing =
View
13 roguestar-gl/src/Models/Materials.hs
@@ -133,11 +133,16 @@ encephalon_skin = pigment $ pattern (cloudy 32 0.1) [(0.0,pure mauve),(1.0,pure
- Material by Energy Type
- ------------------------------------------------------}
+-- Blue: 0.1 0.3 0.9
+-- Yellow: 0.3 0.3 0.0
+-- Red: 0.6 0.0 0.0
+-- Green: 0.0 0.4 0.1
+-- Sum to: 1.0 1.0 1.0
energyColor :: EnergyColor -> RGB
-energyColor Blue = blue
-energyColor Yellow = yellow
-energyColor Red = red
-energyColor Green = bright_green
+energyColor Blue = RGB 0.1 0.3 0.9
+energyColor Yellow = RGB 0.3 0.3 0.0
+energyColor Red = RGB 0.6 0.0 0.0
+energyColor Green = RGB 0.0 0.4 0.1
energyMaterial :: EnergyColor -> Modeling
energyMaterial c = material $
View
4 roguestar-gl/src/Models/Node.hs
@@ -12,7 +12,7 @@ import Quality
monolith :: Quality -> Modeling
monolith _ = model $
- do box (Point3D (-1/2) 0 (-1/8)) (Point3D (1/2) (9/4) (1/8))
+ do box (Point3D (-1/2) (-1/8) 0) (Point3D (1/2) (1/8) (9/4))
material $
do pigment $ pure blackbody
specular 100 $ pure white
@@ -25,7 +25,7 @@ planetary_anchor_core _ = model $
planetary_anchor_flange :: Quality -> Modeling
planetary_anchor_flange _ = model $
do openDisc (Point3D 0 0 0)
- (Vector3D 0 1 0)
+ (Vector3D 0 0 1)
0.20
0.21
material $ emissive $ pure violet
View
6 roguestar-gl/src/Models/Recreant.hs
@@ -10,7 +10,7 @@ import Models.Factions
import Models.FactionData
recreant_antenna_small :: Quality -> Modeling
-recreant_antenna_small _ =
+recreant_antenna_small _ = rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $
do sor $ linearInterpolation $
points2d $ reverse
[(1,6.5),
@@ -19,7 +19,7 @@ recreant_antenna_small _ =
(1.5,6)]
recreant_antenna_large :: Quality -> Modeling
-recreant_antenna_large _ =
+recreant_antenna_large _ = rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $
do sor $ linearInterpolation $
points2d $ reverse
[(2,4.5),
@@ -28,7 +28,7 @@ recreant_antenna_large _ =
(2.5,4)]
recreant_body :: Quality -> Modeling
-recreant_body _ =
+recreant_body _ = rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $
do sor $ linearInterpolation $
points2d $ reverse
[(0,3),
View
5 roguestar-gl/src/Models/RecreantFactory.hs
@@ -11,10 +11,11 @@ recreant_factory :: Quality -> Modeling
recreant_factory _ = model $
do quadralateral (Point3D (-0.5) 0 (-0.5))
(Point3D (-0.5) 0 0.5)
- (Point3D 0.5 0 0.5)
- (Point3D 0.5 0 (-0.5))
+ (Point3D 0.5 0 0.5)
+ (Point3D 0.5 0 (-0.5))
sphere (Point3D (-0.4) 0 (-0.4)) 0.1
sphere (Point3D 0.4 0 (-0.4)) 0.1
sphere (Point3D 0.4 0 0.4) 0.1
sphere (Point3D (-0.4) 0 0.4) 0.1
material $ alliance_metal
+ affine $ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0)
View
3 roguestar-gl/src/Models/Reptilian.hs
@@ -16,7 +16,8 @@ import Models.Factions
import Models.FactionData
reptilian :: Faction -> Quality -> Modeling
-reptilian f _ = model $
+reptilian f _ = rotate (Vector3D 0 0 1) (fromDegrees 180) $
+ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $ model $
do model $
do tube $ linearInterpolation
[(0 ,Point3D 0 0 (-6)),
View
32 roguestar-gl/src/Models/Sky.hs
@@ -112,11 +112,11 @@ biomeAtmosphere _ = (Nothing,Just hot_pink_atmosphere)
-- | '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
+ 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 1 0) (fromDegrees $ realToFrac $ sky_info_degrees_after_midnight sky_info) $ Vector3D 0 0 (-1)
-- | Apparent temperature of a color in kelvins.
temperatureColor :: Integer -> RGB
@@ -142,8 +142,8 @@ makeSky sky_info | Just atmo <- snd $ biomeAtmosphere $ sky_info_biome sky_info
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)
+ skyHemisphere origin_point_3d (Vector3D 0 0 1) 5.0
+ affine $ scale (Vector3D 2 2 2)
material $ atmosphereScatteringMaterial
atmo
[(v,adjustColor channel_value maximize $
@@ -172,7 +172,7 @@ skyAbsorbtionFilter sky_info = LightSourceLayerTransform $ \entering_layer origi
-- | 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)
+sunlightFadeFactor tolerance v = max 0 $ lerpBetweenClamped (85,toDegrees $ angleBetween v (Vector3D 0 0 1),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.
@@ -204,13 +204,13 @@ lightingConfiguration sky_info = result
ambientSkyRadiation :: SkyInfo -> RGB
ambientSkyRadiation sky_info | Nothing <- snd $ biomeAtmosphere $ sky_info_biome sky_info = blackbody
ambientSkyRadiation sky_info | Nothing <- fst $ biomeAtmosphere $ sky_info_biome sky_info = blackbody
-ambientSkyRadiation sky_info = abstractAverage $ map (atmosphereScattering atmosphere [sun_info] (Point3D 0 1 0)) test_vectors
+ambientSkyRadiation sky_info = abstractAverage $ map (atmosphereScattering atmosphere [sun_info] (Point3D 0 0 1)) test_vectors
where atmosphere = fromMaybe mempty $ snd $ biomeAtmosphere $ sky_info_biome sky_info
sun_info = (sunVector sky_info,maybe blackbody sunColor $ sunInfoOf sky_info)
- test_vectors = map vectorNormalize $
+ test_vectors = map vectorNormalize $
do x <- [1,0,-1]
y <- [1,0,-1]
- return $ Vector3D x 1 y
+ return $ Vector3D x y 1
-- 'makeSun' generates a perspectiveSphere of the sun.
makeSun :: SunInfo -> Modeling
@@ -219,19 +219,19 @@ makeSun sun_info = model $
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 $
+ perspectiveSphere (Point3D 0 0 (-10)) size origin_point_3d
+ material $
do pigment $ pure $ grayscale 0
- emissive $ pattern (spherical (Point3D 0 (size-10) 0) size) [(0.0,temperaturePattern temp),
+ emissive $ pattern (spherical (Point3D 0 0 (size-10)) 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)
+ do heightDisc (0,0) 8 (\(x,y) -> perlinNoise (Point3D x y 0) - 6.9 + distanceBetween origin_point_3d (Point3D x y 0))
+ affine $ scale (Vector3D 1 1 0.2)
material $ pigment $ pure blackbody
disregardSurfaceNormals
View
25 roguestar-gl/src/Models/Stargate.hs
@@ -1,14 +1,17 @@
module Models.Stargate
- (portal)
+ (portal,
+ cybergate,
+ cyberpylon)
where
import RSAGL.Math
import RSAGL.Modeling
+import RSAGL.Scene
import Models.Materials
import Quality
portal :: Quality -> Modeling
-portal q =
+portal q = rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0) $
do model $
do model $
do box (Point3D (-0.6) 0 (-0.05)) (Point3D (-0.5) 1.618 0.05)
@@ -36,3 +39,21 @@ portal q =
twoSided True
material treaty_energy_field
+cybergate :: Quality -> Modeling
+cybergate _ = model $
+ do model $
+ do closedDisc (Point3D 0 0 0) (Vector3D 0 1 0) 1.0
+ twoSided True
+ material cyborg_glow
+ torus 1.0 0.1
+ affine $ scale $ Vector3D 1 1 1.5
+ affine $ translate $ Vector3D 0 0 1.5
+ material cyborg_metal
+
+cyberpylon :: Quality -> Modeling
+cyberpylon _ = model $
+ do openCone (Point3D 0 0 0,0.5)
+ (Point3D 0 0 1.0,0.0)
+ deform $ \(Point3D _ y _) -> if y > 0 then (affineOf $ scale (Vector3D 1 3 1)) else affineOf id
+ material cyborg_metal
+
View
8 roguestar-gl/src/Models/Terrain.hs
@@ -50,9 +50,9 @@ known_terrain_types =
--
terrainTileShape :: RSdouble -> RSdouble -> Quality -> Modeling
terrainTileShape physical_height aesthetic_height q = model $
- do heightField (-0.5,-0.5) (0.5,0.5) $ \(x,z) -> let y = 1 - max (abs x) (abs z) * 2 in min (max 0 $ sqrt y) (2*y)
- affine $ scale (Vector3D 1 aesthetic_height 1)
- deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 (physical_height/aesthetic_height) 1) p) v
+ do heightField (-0.5,-0.5) (0.5,0.5) $ \(x,y) -> let z = 1 - max (abs x) (abs y) * 2 in min (max 0 $ sqrt z) (2*z)
+ affine $ scale (Vector3D 1 1 aesthetic_height)
+ deform $ \(SurfaceVertex3D p v) -> SurfaceVertex3D (scale (Vector3D 1 1 (physical_height/aesthetic_height)) p) v
qualityToFixed q
-- |
@@ -81,6 +81,7 @@ terrainTile "downstairs" q = model $
box (Point3D (-0.5) 0 0.5) (Point3D (-0.45) 0.05 (-0.5))
box (Point3D 0.5 0 0.5) (Point3D 0.45 0.05 (-0.5))
material $ pigment $ pure tan
+ affine $ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0)
terrainTile "upstairs" q = model $
do basicTerrainTile "rockyground" q
model $
@@ -108,6 +109,7 @@ terrainTile "upstairs" q = model $
(0.50,pure $ scalarMultiply 0.2 $ adjustColor channel_value maximize $ blackBodyRGB 5300),
(0.75,pure $ scalarMultiply 0.1 $ adjustColor channel_value maximize $ blackBodyRGB 5550),
(1.00,pure $ scalarMultiply 0.0 $ adjustColor channel_value maximize $ blackBodyRGB 5800)]
+ affine $ rotateToFrom (Vector3D 0 0 1) (Vector3D 0 1 0)
terrainTile s q = basicTerrainTile s q
-- |
View
2 roguestar-gl/src/Models/Tree.hs
@@ -13,6 +13,6 @@ leafy_blob = model $
tree_branch :: ModelingM ()
tree_branch = model $
- do closedCone (Point3D 0 0 0, 1.0) (Point3D 0 1 0, 0.5)
+ do hemisphere (Point3D 0 0 0) (Vector3D 0 0 1) 1.0
material $ pigment $ pure brown
View
16 roguestar-gl/src/ProtocolTypes.hs
@@ -52,14 +52,14 @@ instance ProtocolType WieldedObject where
fromTable _ = Nothing
facingToAngle :: B.ByteString -> BoundAngle
-facingToAngle "south" = BoundAngle $ fromDegrees 0
-facingToAngle "southeast" = BoundAngle $ fromDegrees 45
-facingToAngle "east" = BoundAngle $ fromDegrees 90
-facingToAngle "northeast" = BoundAngle $ fromDegrees 135
-facingToAngle "north" = BoundAngle $ fromDegrees 180
-facingToAngle "northwest" = BoundAngle $ fromDegrees 225
-facingToAngle "west" = BoundAngle $ fromDegrees 270
-facingToAngle "southwest" = BoundAngle $ fromDegrees 315
+facingToAngle "north" = BoundAngle $ fromDegrees 0
+facingToAngle "northwest" = BoundAngle $ fromDegrees 45
+facingToAngle "west" = BoundAngle $ fromDegrees 90
+facingToAngle "southwest" = BoundAngle $ fromDegrees 135
+facingToAngle "south" = BoundAngle $ fromDegrees 180
+facingToAngle "southeast" = BoundAngle $ fromDegrees 225
+facingToAngle "east" = BoundAngle $ fromDegrees 270
+facingToAngle "northeast" = BoundAngle $ fromDegrees 315
facingToAngle "here" = BoundAngle $ fromDegrees 0
facingToAngle s = trace ("facingToAngle: what is " ++ B.unpack s ++ "?") $ BoundAngle $ fromDegrees 180
View
8 roguestar-gl/src/RenderingControl.hs
@@ -108,7 +108,7 @@ planarGameplayDispatch = proc () ->
sky_info <- getSkyInfo -< ()
sky -< sky_info
m_lookat <- whenJust (approachA 1.0 (perSecond 3.0)) <<< sticky isJust Nothing <<<
- arr (fmap (\(x,y) -> Point3D (realToFrac x) 0.25 (negate $ realToFrac y))) <<< centerCoordinates -< ()
+ arr (fmap (\(x,y) -> Point3D (realToFrac x) (realToFrac y) 0.25)) <<< centerCoordinates -< ()
camera_distance <- approachA 5.0 (perSecond 5.0) <<< readGlobal global_planar_camera_distance -< ()
let (planar_camera,lookat) = maybe (basic_camera,origin_point_3d) (\x -> (planarCamera camera_distance x,x)) m_lookat
artificial_light_intensity <- arr lighting_artificial <<< lightingConfiguration -< sky_info
@@ -132,9 +132,9 @@ planarGameplayDispatch = proc () ->
-- and the look-at point.
planarCamera :: RSdouble -> Point3D -> Camera
planarCamera camera_distance look_at = PerspectiveCamera {
- camera_position = translate (vectorScaleTo camera_distance $ Vector3D 0 (7*(camera_distance/10)**2) camera_distance) look_at,
- camera_lookat = translate (Vector3D 0 (1/camera_distance) 0) look_at,
- camera_up = Vector3D 0 1 0,
+ camera_position = translate (vectorScaleTo camera_distance $ Vector3D 0 (-camera_distance) (7*(camera_distance/10)**2)) look_at,
+ camera_lookat = translate (Vector3D 0 0 (1/camera_distance)) look_at,
+ camera_up = Vector3D 0 0 1,
camera_fov = fromDegrees 75 }
-- | Retrieve the look-at point from the engine.
View
14 roguestar-gl/src/Sky.hs
@@ -56,8 +56,8 @@ 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)
+ whenJust (transformA sun) -< if angleBetween sun_vector (Vector3D 0 0 1) < fromDegrees 135 && sky_on
+ then Just (affineOf $ rotateToFrom (sunVector sky_info) (Vector3D 0 0 (-1)),sky_info)
else Nothing
returnA -< ()
lighting_configuration <- Sky.lightingConfiguration -< sky_info
@@ -68,17 +68,17 @@ sky = proc sky_info ->
() | nightlight_intensity > 0.05 && sky_on ->
mapLightSource (mapBoth $ scalarMultiply nightlight_intensity) $
DirectionalLight {
- lightsource_direction = Vector3D 0 1 0,
+ lightsource_direction = Vector3D 0 0 1,
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 $ scalarMultiply skylight_intensity) $
- skylight (Vector3D 0 1 0) skylight_color
+ skylight (Vector3D 0 0 1) skylight_color
() | lighting_artificial lighting_configuration <= 0.05 &&
not sky_on ->
- skylight (Vector3D 0 1 0) white
+ skylight (Vector3D 0 0 1) white
() | otherwise -> NoLight)
sun :: (FRPModel m,StateOf m ~ AnimationState,
@@ -91,9 +91,9 @@ sun = proc sky_info ->
accumulateSceneA -< (scene_layer_distant,lightSource $ case sunInfoOf sky_info of
Just sun_info | sunlight_intensity > 0.05 && sky_on ->
PointLight {
- lightsource_position = Point3D 0 (-10) 0,
+ lightsource_position = Point3D 0 0 (-10),
lightsource_radius = measure origin_point_3d
- (Point3D 0 (-10) 0),
+ (Point3D 0 0 (-10)),
lightsource_color = sunColor sun_info,
lightsource_ambient = blackbody}
_ | otherwise -> NoLight)
View
9 roguestar-gl/src/VisibleObject.hs
@@ -230,10 +230,7 @@ objectDetailsLookup obj field = proc _ ->
tableLookup details_table ("property","value") field
-- | Get an object's faction. (Using 'objectDetailsLookup'.)
--- Returns 'Gray' by default, if no faction is available,
--- but this should be rare because generally by the time
--- we have an avatar up for the particular type of object,
--- the details for that object are already available.
+-- Returns 'Gray' if it can't find the correct faction.
objectFaction :: (FRPModel m,StateOf m ~ AnimationState,
ThreadIDOf m ~ Maybe Integer,
FRPModes m ~ RoguestarModes) =>
@@ -261,7 +258,7 @@ objectIdealPosition :: (FRPModel m,
VisibleObjectReference -> FRP e m () (Maybe Point3D)
objectIdealPosition obj =
whenJust (approachA 0.25 (perSecond 3)) <<<
- arr (fmap (\(x,y) -> Point3D (realToFrac x) 0 (negate $ realToFrac y))) <<<
+ arr (fmap (\(x,y) -> Point3D (realToFrac x) (realToFrac y) 0)) <<<
objectDestination obj
-- | Goal direction in which the specified object should be pointed.
@@ -289,7 +286,7 @@ objectIdealOrientation obj = proc () ->
m_a <- objectIdealFacing obj -< ()
returnA -< do p <- m_p
a <- m_a
- return $ translate (vectorToFrom p origin_point_3d) $ rotateY a $ root_coordinate_system
+ return $ translate (vectorToFrom p origin_point_3d) $ rotateZ a $ root_coordinate_system
-- | 'objectIdealOrientation' implementation that is aware of wield points for wieldable objects. If an object is being
-- wielded, it will snap to it's wield point.
View
1 rsagl/RSAGL/Animation/AnimationExtras.hs
@@ -30,7 +30,6 @@ import RSAGL.Modeling.Model
import RSAGL.Scene.WrappedAffine
import Control.Monad
import RSAGL.Math.Types
-import Debug.Trace
-- | Answers a continuous rotation.
rotationA :: Vector3D -> Rate Angle -> FRP e m ignored AffineTransformation
View
13 rsagl/RSAGL/Animation/InverseKinematics.hs
@@ -25,6 +25,7 @@ import RSAGL.Math.AbstractVector
import RSAGL.Math.Angle
import RSAGL.Math.FMod
import RSAGL.Math.Types
+import Debug.Trace
-- | This simulates a single foot that hops along by itself whenever its
-- coordinate system moves. A foot always trys to walk on the plane @y == 0@.
@@ -51,7 +52,7 @@ foot :: (CoordinateSystemClass s,s ~ StateOf m) =>
foot forward_radius side_radius lift_radius = proc emergency_footdown ->
-- total forward travel of the foot:
do fwd_total_stepage <- arr (* recip (2*forward_radius)) <<<
- odometer root_coordinate_system (Vector3D 0 0 1) -< ()
+ odometer root_coordinate_system (Vector3D 0 1 0) -< ()
-- total sideways travel of the foot
side_total_stepage <- arr (* recip (2*side_radius)) <<<
odometer root_coordinate_system (Vector3D 1 0 0) -< ()
@@ -73,14 +74,14 @@ foot forward_radius side_radius lift_radius = proc emergency_footdown ->
let stepage_offset = if cyclic_stepage > 1
then 1.5 - cyclic_stepage
else cyclic_stepage - 0.5
- let step_vector = scale (Vector3D (2*side_radius) 0 (2*forward_radius)) $
+ let step_vector = scale (Vector3D (2*side_radius) (2*forward_radius) 0) $
vectorScaleTo stepage_offset $
- Vector3D side_total_stepage 0 fwd_total_stepage
+ Vector3D side_total_stepage fwd_total_stepage 0
foot_position <- importA <<<
- arr (remoteCSN root_coordinate_system $ scale (Vector3D 1 0 1)) <<<
+ arr (remoteCSN root_coordinate_system $ scale (Vector3D 1 1 0)) <<<
exportA -< translate step_vector origin_point_3d
csn_foot_position <- exportA -<
- translate (Vector3D 0 foot_lift 0) foot_position
+ translate (Vector3D 0 0 foot_lift) foot_position
returnA -< (csn_foot_position,cyclic_stepage > 1)
data LegStyle = Upright | Insectoid
@@ -129,7 +130,7 @@ leg style bend base len end animation = Leg $ proc (feet_that_are_down,a) ->
feet_that_are_down
where insectoid_style = sqrt (len^2 - foot_ideal_distance_squared) / 4
upright_style = case (base,end) of
- (Point3D _ base_y _,Point3D _ end_y _) -> sqrt $ len^2 - (base_y - end_y)^2
+ (Point3D _ _ base_z,Point3D _ _ end_z) -> sqrt $ len^2 - (base_z - end_z)^2
foot_ideal_distance_squared = distanceBetweenSquared base end
foot_radius = case style of
Insectoid -> insectoid_style
View
8 rsagl/RSAGL/Animation/Joint.hs
@@ -11,8 +11,8 @@ import RSAGL.Math.Types
-- | The result of computing a joint. It provides AffineTransformations that
-- describe the orientations of the components of the joint.
--- All affine transformations reorient the +Z axis to aim in the direction
--- of the far point. For example, in @joint_arm_lower@ the +Z axis aims
+-- All affine transformations reorient the +Y axis to aim in the direction
+-- of the far point. For example, in @joint_arm_lower@ the +Y axis aims
-- at the position of the hand.
data Joint = Joint { joint_shoulder :: Point3D,
-- ^ The fixed point of the joint.
@@ -29,7 +29,7 @@ data Joint = Joint { joint_shoulder :: Point3D,
joint_arm_hand :: AffineTransformation
-- ^ The affine transformation where the origin
-- is the hand. Oriented to preserve as much as
- -- possible the +Y axis.
+ -- possible the +Z axis.
}
-- | Compute a joint where given a bend vector, describing the direction
@@ -45,7 +45,7 @@ joint bend shoulder joint_length hand = Joint {
joint_elbow = elbow,
joint_arm_lower = modelLookAt elbow (forward $ Left hand) (down $ Right bend),
joint_arm_upper = modelLookAt shoulder (forward $ Left elbow) (down $ Right bend),
- joint_arm_hand = modelLookAt hand (backward $ Left elbow) (up $ Right (Vector3D 0 1 0)) }
+ joint_arm_hand = modelLookAt hand (backward $ Left elbow) (up $ Right (Vector3D 0 0 1)) }
where joint_offset = sqrt (joint_length^2 - (distanceBetween shoulder hand)^2) / 2
joint_offset_vector = vectorScaleTo joint_offset $ transformation
(orthogonalFrame (forward $ vectorToFrom hand shoulder) (down bend)) (Vector3D 0 (-1) 0)
View
12 rsagl/RSAGL/Extras/Sky.hs
@@ -89,16 +89,16 @@ dynamicSkyFilter max_black min_white origF = case () of
-- | Generate a low level 'Scattering' model directly from an 'AtmosphereLayer'.
atmosphereLayerToScatteringModel :: AtmosphereLayer -> Scattering
-atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Air }) =
+atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Air }) =
rayleigh (atmosphere_altitude l / atmosphere_thickness l) rayleigh_sky
atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Vapor }) = mconcat [
elasticOmnidirectionalScatter (atmosphere_altitude l / atmosphere_thickness l)
(grayscale $ linear_value $ viewChannel channel_brightness rayleigh_sky),
elasticForwardScatter (atmosphere_altitude l / atmosphere_thickness l) (fromDegrees 30)
(grayscale $ linear_value $ viewChannel channel_brightness rayleigh_sky)]
-atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Dust c }) =
+atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Dust c }) =
dust (f2f $ atmosphere_altitude l / atmosphere_thickness l) c
-atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Fog c }) =
+atmosphereLayerToScatteringModel l@(AtmosphereLayer { atmosphere_composition = Fog c }) =
fog (f2f $ atmosphere_altitude l / atmosphere_thickness l) c
-- | Cast a ray that can intersect a geometry at exactly two or zero points, given a default value
@@ -130,7 +130,7 @@ atmosphereLayerScattering :: AtmosphereLayer -> (Vector3D,RGB) -> Ray3D -> RGB
atmosphereLayerScattering l (sun_vector,sun_color) r = castSkyRay (sphere origin_point_3d (1 + atmosphere_altitude l)) (grayscale 0) scatterF r
where scatterF p_near p_far = fst $ traceScattering (const scattering_model)
(\p -> (sun_vector,scalarMultiply (lightingF p) sun_color)) adaptiveSamples p_near p_far $
- round $ max 20 $ (* 800) $ toRotations $ angleBetween (Vector3D 0 1 0) (ray_vector r)
+ round $ max 20 $ (* 800) $ toRotations $ angleBetween (Vector3D 0 0 1) (ray_vector r)
scattering_model = achromaticAbsorbtion $ atmosphereLayerToScatteringModel l
lightingF p = f2f $ castSkyRay UnitSphere 1
(\p_near p_far -> max 0 $ sqrt (atmosphere_altitude l) - 1 + sqrt (4 - distanceBetween p_near p_far ** 2) / 2)
@@ -177,10 +177,10 @@ atmosphereScatteringMaterial _ suns _ |
return ()
atmosphereScatteringMaterial atm suns sky_filter = material $
do filtering $ ApplicativeWrapper $ Left $
- \(SurfaceVertex3D p _) -> absorbtionFilter $ atmosphereAbsorbtion atm (Point3D 0 1 0) (vectorToFrom p origin_point_3d)
+ \(SurfaceVertex3D p _) -> absorbtionFilter $ atmosphereAbsorbtion atm (Point3D 0 0 1) (vectorToFrom p origin_point_3d)
case m_skyFilterF of
Just skyFilterF -> emissive $ ApplicativeWrapper $ Left $
\(SurfaceVertex3D p _) -> skyFilterF $ scatteringF (vectorToFrom p origin_point_3d)
Nothing -> return ()
- where scatteringF = atmosphereScattering atm suns (Point3D 0 1 0)
+ where scatteringF = atmosphereScattering atm suns (Point3D 0 0 1)
m_skyFilterF = sky_filter scatteringF
View
3 rsagl/RSAGL/Modeling/Model.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, PatternGuards #-}
module RSAGL.Modeling.Model
(Model,
Modeling,
@@ -319,6 +319,7 @@ closedDisc center up_vector radius = model $
closedCone :: (Point3D,RSdouble) -> (Point3D,RSdouble) -> Modeling
closedCone a b = model $
do openCone a b
+ -- we want open discs here, because closed disks don't mesh well with the cone
openDisc (fst a) (vectorToFrom (fst a) (fst b)) 0 (snd a * (1 + recip (2^8)))
openDisc (fst b) (vectorToFrom (fst b) (fst a)) 0 (snd b * (1 + recip (2^8)))
View
13 rsagl/RSAGL/Modeling/ModelingExtras.hs
@@ -61,17 +61,16 @@ regularPrism (a,ra) (b,rb) n =
b2 = rotateY (fromRotations $ recip $ fromInteger n) b1
quad = quadralateral a1 a2 b2 b1
--- | A rectangular height field rising off of the x-z plane.
+-- | A rectangular height field rising off of the x-y plane.
heightField :: (RSdouble,RSdouble) -> (RSdouble,RSdouble) -> ((RSdouble,RSdouble) -> RSdouble) -> Modeling
-heightField (x1,z1) (x2,z2) f = model $
- do quadralateral (Point3D x1 0 z1) (Point3D x1 0 z2) (Point3D x2 0 z2) (Point3D x2 0 z1)
+heightField (x1,y1) (x2,y2) f = model $
+ do quadralateral (Point3D x1 y1 0) (Point3D x2 y1 0) (Point3D x2 y2 0) (Point3D x1 y2 0)
heightMap f
-
--- | A circular height field rising off of the x-z plane.
+-- | A circular height field rising off of the x-y plane.
heightDisc :: (RSdouble,RSdouble) -> RSdouble -> ((RSdouble,RSdouble) -> RSdouble) -> Modeling
heightDisc (x,y) r f = model $
- do closedDisc (Point3D x 0 y) (Vector3D 0 1 0) r
+ do closedDisc (Point3D x y 0) (Vector3D 0 0 1) r
heightMap f
rotationGroup :: (AffineTransformable a) => Vector3D -> Integer -> a -> [a]
@@ -166,7 +165,7 @@ waves wave_length amplitude (SurfaceVertex3D (Point3D x y z) _) = (wave_f x + wa
-- | Raises or lowers each point in a model along the y-axis according to its (x,z) coordinate.
-- Typically this is used to construct height fields.
heightMap :: ((RSdouble,RSdouble) -> RSdouble) -> Modeling
-heightMap f = deform $ \(Point3D x y z) -> Point3D x (y + f (x,z)) z
+heightMap f = deform $ \(Point3D x y z) -> Point3D x y (z + f (x,y))
-- | Turns off calculation of surface normals. This can speed
-- up modeling in some cases if we know we don't need them.
View
80 rsagl/RSAGL/Scene/Scene.lhs → rsagl/RSAGL/Scene/Scene.hs
@@ -1,9 +1,3 @@
-\section{Scenes and Animation}
-
-A \texttt{Scene} is a complete description of an image to be rendered, consisting of a camera position, light sources, and models.
-
-\begin{code}
-
{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, TypeFamilies #-}
module RSAGL.Scene.Scene
@@ -55,18 +49,14 @@ import Data.Monoid
import RSAGL.FRP.RecombinantState
import Data.MemoCombinators
import RSAGL.Math.Types
-\end{code}
-\subsection{Cameras}
-
-\begin{code}
data Camera =
- PerspectiveCamera { camera_position, camera_lookat :: Point3D,
+ PerspectiveCamera { camera_position, camera_lookat :: Point3D,
camera_up :: Vector3D,
camera_fov :: Angle.Angle }
instance AffineTransformable Camera where
- transform m (pc@(PerspectiveCamera {})) =
+ transform m (pc@(PerspectiveCamera {})) =
pc { camera_position = transform m $ camera_position pc,
camera_lookat = transform m $ camera_lookat pc,
camera_up = transform m $ camera_up pc }
@@ -84,36 +74,30 @@ cameraToOpenGL aspect_ratio (near,far)
(f2f near)
(f2f far)
matrixMode $= Modelview 0
- lookAt (Vertex3 (f2f px) (f2f py) (f2f pz))
- (Vertex3 (f2f lx) (f2f ly) (f2f lz))
+ lookAt (Vertex3 (f2f px) (f2f py) (f2f pz))
+ (Vertex3 (f2f lx) (f2f ly) (f2f lz))
(Vector3 (f2f ux) (f2f uy) (f2f uz))
infiniteCameraOf :: Camera -> Camera
infiniteCameraOf pc = translateToFrom origin_point_3d (camera_position pc) pc
cameraOrientation :: (AffineTransformable a) => Camera -> a -> a
-cameraOrientation c = modelLookAt (camera_position c) (forward $ Left $ camera_lookat c)
+cameraOrientation c = modelLookAt (camera_position c) (forward $ Left $ camera_lookat c)
(up $ Right $ camera_up c)
cameraLookAt :: (AffineTransformable a) => Camera -> a -> a
-cameraLookAt = inverseTransformation . cameraOrientation
-\end{code}
-
-\subsection{Scene Construction}
-
-A \texttt{Scene} supports local and infinite scene layers. The camera moves through the local scene layer, but the infinite scene layer is fixed. Objects in the infinite scene layer never occlude objects in the local layer. All light sources in the infinite scene layer are rendered as directional light sources in the local scene layer. Local light sources are not rendered at all in the infinite layer.
+cameraLookAt = inverseTransformation . cameraOrientation
-Celestial objects such as the moon and sun, as well as the sky sphere, belong in the infinite subscene. Distant clouds or mountains may also belong in the infinite layer.
-
-\begin{code}
-data SceneObject m =
+data SceneObject m =
LightSource LightSource
| Model (Camera -> m (WrappedAffine IntermediateModel))
instance (Monad m) => AffineTransformable (SceneObject m) where
transform m (LightSource ls) = LightSource $ transform m ls
transform m (Model imodel) = Model $ \c -> liftM (transform m) (imodel c)
+-- | Scene layers are ordered from inner (small values) to outer (large values)
+-- Objects in an inner layer never occlude objects in an outer layer.
type SceneLayer = Integer
data SceneAccumulator m = SceneAccumulator {
@@ -134,7 +118,7 @@ class (RecombinantState a,CoordinateSystemClass a,Monad m) => ScenicAccumulator
accumulateScene :: SceneLayer -> SceneObject m -> a -> a
instance (Monad m) => ScenicAccumulator (SceneAccumulator m) m where
- accumulateScene slayer scobj sceneaccum = sceneaccum {
+ accumulateScene slayer scobj sceneaccum = sceneaccum {
sceneaccum_objs = (slayer,migrateToFrom (sceneaccum_coordinate_system sceneaccum) root_coordinate_system scobj) : sceneaccum_objs sceneaccum }
null_scene_accumulator :: SceneAccumulator m
@@ -149,27 +133,24 @@ cameraRelativeSceneObject = Model
lightSource :: LightSource -> SceneObject m
lightSource = LightSource
+-- | This just adds an object to the collection of objects in the accumulator,
+-- using the current state of the accumulator to position the object in the scene.
accumulateSceneM :: (ScenicAccumulator sa a,Monad m,MonadState sa m) => SceneLayer -> SceneObject a -> m ()
accumulateSceneM slayer scobj = modify (accumulateScene slayer scobj)
+-- | See accumulateSceneM.
accumulateSceneA :: (ScenicAccumulator sa m,Arrow arr,ArrowState sa arr) => arr (SceneLayer,SceneObject m) ()
accumulateSceneA = proc (slayer,scobj) ->
do sceneaccum <- fetch -< ()
store -< accumulateScene slayer scobj sceneaccum
-\end{code}
-
-\subsection{Scene Assembly}
-
-Once all objects have been accumulated, the accumulation is used to generate a \texttt{Scene} object.
-\begin{code}
data SceneElement = SceneElement {
scene_elem_layer :: SceneLayer,
scene_elem_opaque :: Bool,
scene_elem_model :: WrappedAffine IntermediateModel,
scene_elem_light_sources :: [LightSource] }
-data Scene = Scene {
+data Scene = Scene {
scene_elements :: Map.Map (SceneLayer,Bool) [SceneElement],
scene_layerToCamera :: (SceneLayer -> Camera) }
@@ -178,29 +159,29 @@ data SceneLayerInfo = SceneLayerInfo {
scene_layer_light_source_layer_transform :: LightSourceLayerTransform }
assembleScene :: (Monad m) => SceneLayerInfo -> SceneAccumulator m -> m Scene
-assembleScene (SceneLayerInfo layerToCamera light_source_layer_transform) scene_accum =
+assembleScene (SceneLayerInfo layerToCamera light_source_layer_transform) scene_accum =
do elements <- liftM (Map.mapWithKey (\(_,opaque) -> if not opaque then sortModels else id) .
- foldr (\se -> Map.alter (Just . (se:) . fromMaybe [])
- (scene_elem_layer se,scene_elem_opaque se)) Map.empty . concat) $
+ foldr (\se -> Map.alter (Just . (se:) . fromMaybe [])
+ (scene_elem_layer se,scene_elem_opaque se)) Map.empty . concat) $
mapM toElement $ sceneaccum_objs scene_accum
return $ Scene { scene_elements = elements,
scene_layerToCamera = layerToCamera }
where splitOpaquesWrapped :: WrappedAffine IntermediateModel -> (WrappedAffine IntermediateModel,
[WrappedAffine IntermediateModel])
splitOpaquesWrapped (WrappedAffine a m) =
let (opaques,transparents) = splitOpaques m
- in (WrappedAffine a opaques,map (WrappedAffine a) transparents)
+ in (WrappedAffine a opaques,map (WrappedAffine a) transparents)
toLightSource :: SceneLayer -> (SceneLayer,SceneObject m) -> LightSource
- toLightSource entering_layer (originating_layer,LightSource ls) =
+ toLightSource entering_layer (originating_layer,LightSource ls) =
lightSourceLayerTransform light_source_layer_transform entering_layer originating_layer ls
toLightSource _ _ = NoLight
sortModels :: [SceneElement] -> [SceneElement]
- sortModels = map fst . sortBy (comparing $ \(se,bbox) -> negate $
+ sortModels = map fst . sortBy (comparing $ \(se,bbox) -> negate $
minimalDistanceToBoundingBox (camera_position $ layerToCamera $ scene_elem_layer se) bbox) .
- map (\(se@(SceneElement { scene_elem_model = WrappedAffine cs m })) ->
+ map (\(se@(SceneElement { scene_elem_model = WrappedAffine cs m })) ->
(se,migrateToFrom cs root_coordinate_system $ boundingBox m))
toElement :: (Monad m) => (SceneLayer,SceneObject m) -> m [SceneElement]
- toElement (n,Model f) =
+ toElement (n,Model f) =
do (opaque,transparents) <- liftM splitOpaquesWrapped $ f (layerToCamera n)
let light_sources = filter (not . isNoLight) $ map (toLightSource n) (sceneaccum_objs scene_accum)
let base_element = SceneElement {
@@ -219,13 +200,13 @@ sceneToOpenGL aspect_ratio nearfar s =
render1Layer :: RSdouble -> (RSdouble,RSdouble) -> Scene -> SceneLayer -> IO ()
render1Layer aspect_ratio nearfar (Scene elems layerToCamera) n =
- do save_rescale_normal <- GL.get rescaleNormal
+ do save_normalize <- GL.get normalize
save_cull_face <- GL.get cullFace
save_depth_func <- GL.get depthFunc
save_depth_mask <- GL.get depthMask
save_lighting <- GL.get lighting
save_light_model_ambient <- GL.get lightModelAmbient
- rescaleNormal $= Enabled
+ normalize $= Enabled
cullFace $= Just Front
depthFunc $= Just Lequal
depthMask $= Enabled
@@ -242,19 +223,13 @@ render1Layer aspect_ratio nearfar (Scene elems layerToCamera) n =
depthMask $= save_depth_mask
depthFunc $= save_depth_func
cullFace $= save_cull_face
- rescaleNormal $= save_rescale_normal
+ normalize $= save_normalize
render1Element :: SceneElement -> IO ()
render1Element (SceneElement { scene_elem_light_sources = lss, scene_elem_model = (WrappedAffine m imodel)}) =
do setLightSourcesToOpenGL lss
migrateToFrom m root_coordinate_system $ intermediateModelToOpenGL imodel
-\end{code}
-\subsection{Standard Scene Layers}
-
-This is an example of how to implement scene layers that should be adequate to most purposes.
-
-\begin{code}
stdSceneLayerInfo :: Camera -> SceneLayerInfo
stdSceneLayerInfo c = SceneLayerInfo (stdSceneLayers c) (cameraLightSourceLayerTransform (stdSceneLayers c))
@@ -276,11 +251,7 @@ std_scene_layer_local :: SceneLayer
std_scene_layer_local = 2
std_scene_layer_infinite :: SceneLayer
std_scene_layer_infinite = 3
-\end{code}
-
-\subsection{Standard Light Layer Transforms}
-\begin{code}
newtype LightSourceLayerTransform = LightSourceLayerTransform { lightSourceLayerTransform :: SceneLayer -> SceneLayer -> LightSource -> LightSource }
instance Monoid LightSourceLayerTransform where
@@ -295,4 +266,3 @@ cameraLightSourceLayerTransform layerToCamera = LightSourceLayerTransform $ memo
f entering_layer originating_layer | entering_layer < originating_layer =
cameraOrientation (layerToCamera entering_layer) . infiniteLightSourceOf . cameraLookAt (layerToCamera originating_layer)
f _ _ = const NoLight
-\end{code}

0 comments on commit 413fd12

Please sign in to comment.