roguestar-gl-0.6.0.0: src/Models/Sky.hs
{-# LANGUAGE OverloadedStrings, PatternGuards #-}
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 RSAGL.Color
import RSAGL.Color.RSAGLColors
import Scene
import Data.Monoid
import qualified Data.ByteString as B
import Data.Maybe
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 = fromMaybe (error "Nothing: default_sun") $ sunInfoOf default_sky
-- | generates a 'SunInfo' from a 'SkyInfo'
sunInfoOf :: SkyInfo -> Maybe SunInfo
sunInfoOf sky_info =
do temperature_adjustment <- fst $ biomeAtmosphere $ sky_info_biome sky_info
return $ SunInfo {
sun_info_size_adjustment = abs (sky_info_degrees_latitude sky_info) + temperature_adjustment,
sun_info_kelvins = sky_info_solar_kelvins sky_info }
medium_atmosphere :: Atmosphere
medium_atmosphere = [
AtmosphereLayer Air 0.75 9.0e-4,
AtmosphereLayer Vapor 0.25 2.5e-4,
AtmosphereLayer (Dust $ grayscale 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 $ grayscale 0.5) 0.02 1.0e-4 ]
arid_atmosphere :: Atmosphere
arid_atmosphere = [
AtmosphereLayer Air 0.05 2.5e-3,
AtmosphereLayer (Dust maroon) 0.1 1.0e-3 ]
hot_pink_atmosphere :: Atmosphere
hot_pink_atmosphere = [
AtmosphereLayer (Fog hot_pink) 0.1 1.0e-3]
-- Answers a temperature adjustment and a atmospheric model, for rendering the sun and sky.
-- If there is no temperature adjustment, there will be no sun, and likewise if there
-- is no atmosphere model, there will be no (rendered) atmosphere.
biomeAtmosphere :: B.ByteString -> (Maybe Integer,Maybe Atmosphere)
biomeAtmosphere "shallowdungeon" = (Nothing,Nothing)
biomeAtmosphere "deepdungeon" = (Nothing,Nothing)
biomeAtmosphere "frozendungeon" = (Nothing,Nothing)
biomeAtmosphere "abyssaldungeon" = (Nothing,Nothing)
biomeAtmosphere "infernaldungeon" = (Nothing,Nothing)
biomeAtmosphere "rockbiome" = (Just 0,Just arid_atmosphere)
biomeAtmosphere "icyrockbiome" = (Just (-100),Just thin_atmosphere)
biomeAtmosphere "grasslandbiome" = (Just 35,Just medium_atmosphere)
biomeAtmosphere "tundrabiome" = (Just (-75),Just thin_atmosphere)
biomeAtmosphere "desertbiome" = (Just 100,Just arid_atmosphere)
biomeAtmosphere "oceanbiome" = (Just 5,Just medium_atmosphere)
biomeAtmosphere "mountainbiome" = (Just (-15),Just thin_atmosphere)
biomeAtmosphere "swampbiome" = (Just 35,Just thick_atmosphere)
biomeAtmosphere "nothing" = (Nothing,Nothing)
biomeAtmosphere _ = (Nothing,Just hot_pink_atmosphere)
-- | 'sunVectorOf' indicates vector pointing at the sun.
sunVector :: SkyInfo -> Vector3D
sunVector sky_info =
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)
(grayscale 0,adjustColor channel_value maximize $
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 | Just atmo <- snd $ biomeAtmosphere $ sky_info_biome sky_info = model $
do hilly_silhouette
model $
do let v = sunVector sky_info
skyHemisphere origin_point_3d (Vector3D 0 1 0) 5.0
affine $ scale (Vector3D 2 1 2)
material $ atmosphereScatteringMaterial
atmo
[(v,adjustColor channel_value maximize $
blackBodyRGB $ realToFrac $
sky_info_solar_kelvins sky_info)]
(dynamicSkyFilter 0.05 0.5)
makeSky _ = return ()
-- | Implements absorbtion of light sources passing through the sky sphere.
-- In particular, this turns off all lights inside 'scene_layer_sky_sphere'.
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 $ scalarMultiply $ sunlightFadeFactor (fromDegrees 30) v) ls
() | entering_layer == scene_layer_far_sky -> sunFade (fromDegrees 10) v ls
() | entering_layer == scene_layer_clouds -> sunFade (fromDegrees 5) v ls
() | entering_layer == scene_layer_near_sky -> sunFade (fromDegrees 2) v ls
() | otherwise -> sunFade (fromDegrees 0) v ls
where absorbtion v = filterRGB $ (absorbtionFilter . absorbtionFilter) $ atmosphereAbsorbtion (fromMaybe mempty $ snd $ biomeAtmosphere $ sky_info_biome sky_info) (Point3D 0 1 0) v
direction (PointLight { lightsource_position = p }) = vectorToFrom p origin_point_3d
direction (DirectionalLight { lightsource_direction = d }) = d
direction NoLight = Vector3D 0 1 0
sunFade tolerance v = mapLightSource (mapBoth (absorbtion v) `mappend` mapBoth (scalarMultiply $ sunlightFadeFactor tolerance v))
-- | The amount of fade of the sun based on falling below the horizon.
sunlightFadeFactor :: Angle -> Vector3D -> RSdouble
sunlightFadeFactor tolerance v = max 0 $ lerpBetweenClamped (85,toDegrees $ angleBetween v (Vector3D 0 1 0),95+toDegrees tolerance) (1.0,0.0)
-- | Information about the lighting environment. All values are between 0 and 1, indicating a
-- relative scale compared to the normal, full brightness.
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 sunlight_intensity = linear_value $ viewChannel channel_luminance $
maybe blackbody sunColor $ sunInfoOf sky_info
result = LightingConfiguration {
lighting_sunlight = sunlightFadeFactor (fromDegrees 0) (sunVector sky_info) * sunlight_intensity,
lighting_skylight = sunlightFadeFactor (fromDegrees 10) (sunVector sky_info) * sunlight_intensity,
lighting_nightlight = max 0 $ 1.0 - lighting_sunlight result - lighting_skylight result,
lighting_artificial = min 1 $ max 0 $ 1.0 - lighting_sunlight result - (lighting_nightlight result/4) + (1000 / realToFrac (sky_info_solar_kelvins sky_info))^3 }
-- | Get the color of the ambient sky radiation by sampling a very small number vectors into the sky.
ambientSkyRadiation :: SkyInfo -> RGB
ambientSkyRadiation sky_info | Nothing <- snd $ biomeAtmosphere $ sky_info_biome sky_info = blackbody
ambientSkyRadiation sky_info | Nothing <- fst $ biomeAtmosphere $ sky_info_biome sky_info = blackbody
ambientSkyRadiation sky_info = abstractAverage $ map (atmosphereScattering atmosphere [sun_info] (Point3D 0 1 0)) test_vectors
where atmosphere = fromMaybe mempty $ snd $ biomeAtmosphere $ sky_info_biome sky_info
sun_info = (sunVector sky_info,maybe blackbody sunColor $ sunInfoOf sky_info)
test_vectors = map vectorNormalize $
do x <- [1,0,-1]
y <- [1,0,-1]
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 $ grayscale 0
emissive $ pattern (spherical (Point3D 0 (size-10) 0) size) [(0.0,temperaturePattern temp),
(0.5,temperaturePattern $ temp - 200),
(0.75,temperaturePattern $ temp - 500),
(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