Refactor light sources

2022-07-21 16:21:35 +01:00
parent cf5ec4a261
commit aabd8a2cb8
8 changed files with 71 additions and 45 deletions
@@ -2,24 +2,32 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.LightSource where
 import Geometry
-import Picture.Data
 import Control.Lens

+data LightSourceDraw = DefaultLightSourceDraw
+
+data TLSIntensity = ConstantIntensity
+    | TLSFade Point3 Int
+
+data TLSUpdate = DestroyTLS
+    | TimerTLS
+    | IntensityTLS TLSIntensity
+
 data LSParam = LSParam
    { _lsPos        :: !Point3
    , _lsRad        :: !Float
    , _lsCol        :: !Point3
    }
 data LightSource = LS  
-    { _lsID     :: !Int
+    { _lsID     :: Int
    , _lsParam  :: LSParam
-    , _lsDir    :: !Float
-    , _lsPict   :: LightSource -> Picture
+    , _lsDir    :: Float
+    , _lsPict   :: LightSourceDraw --LightSource -> Picture
    }
 data TempLightSource = TLS 
    { _tlsParam     :: LSParam
-    , _tlsUpdate    :: TempLightSource -> Maybe TempLightSource
-    , _tlsTime      :: !Int
+    , _tlsUpdate    :: TLSUpdate --TempLightSource -> Maybe TempLightSource
+    , _tlsTime      :: Int
    }
 makeLenses ''LSParam
 makeLenses ''LightSource
@@ -1,8 +1,6 @@
 module Dodge.Default.LightSource where
 import Dodge.Data
-import Picture
 import Geometry
-import LensHelp

 defaultLS :: LightSource
 defaultLS = LS
@@ -13,13 +11,8 @@ defaultLS = LS
        , _lsCol = 0.6
        }
    , _lsDir = 0
-    , _lsPict = defLSPic 
+    , _lsPict = DefaultLightSourceDraw --defLSPic 
    }
-defLSPic :: LightSource -> Picture
-defLSPic ls = setLayer BloomNoZWrite . translate3 (_lsPos $ _lsParam ls) . color col $ circleSolid 4
-  where
-    col = V4 r g b 2
-    V3 r g b = _lsCol $ _lsParam ls
 defaultTLS :: TempLightSource
 defaultTLS = TLS
    { _tlsParam = LSParam
@@ -27,10 +20,6 @@ defaultTLS = TLS
        , _lsRad = 0
        , _lsCol = 0.5
        }
-    , _tlsUpdate = f
+    , _tlsUpdate = TimerTLS
    , _tlsTime = 1
    }
-  where
-    f t 
-        | _tlsTime t <= 0 = Nothing
-        | otherwise       = Just $ t & tlsTime -~ 1
@@ -24,23 +24,23 @@ import Dodge.Material.Sound
 lsPosRad :: Point3 -> Float -> LightSource
 lsPosRad = lsColPosRad 0.75

-tlsTimeRadFunPos :: Int -> Float -> (Int -> Float) -> Point3 -> TempLightSource
+tlsTimeRadFunPos :: Int -> Float -> TLSIntensity -> Point3 -> TempLightSource
 tlsTimeRadFunPos t rmax intensityF p = TLS 
    { _tlsParam = LSParam
        { _lsPos = p
        , _lsRad = rmax
-        , _lsCol = f $ intensityF t
+        , _lsCol = 0 -- intensityF t
        }
-    , _tlsUpdate = upF
+    , _tlsUpdate = IntensityTLS intensityF
    , _tlsTime = t
    }
  where
-    upF tls 
-        | _tlsTime tls <= 0 = Nothing
-        | otherwise         = Just $ tls    
-            & tlsTime -~ 1
-            & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) )
-    f x' = V3 x' x' x'
+--    upF tls 
+--        | _tlsTime tls <= 0 = Nothing
+--        | otherwise         = Just $ tls    
+--            & tlsTime -~ 1
+--            & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) )
+--    f x' = V3 x' x' x'

 lsPosColRad :: Point3 -> Point3 -> Float -> LightSource
 lsPosColRad p col = lsColPosRad col p
@@ -79,14 +79,9 @@ tlsTimeRadColPos t rmax col (V3 x y z) = TLS
        , _lsRad = rmax
        , _lsCol = col
        }
-    , _tlsUpdate = upF
+    , _tlsUpdate = TimerTLS
    , _tlsTime = t
    }
-  where
-    upF tls 
-        | _tlsTime tls <= 0 = Nothing
-        | otherwise         = Just $ tls    
-            & tlsTime -~ 1

 makeTlsTimeRadColPos :: Int -> Float -> Point3 -> Point3 -> World -> World
 makeTlsTimeRadColPos i rad (V3 r g b) p = tempLightSources .:~ tlsTimeRadColPos i rad (V3 r g b) p
@@ -101,9 +96,8 @@ destroyLS lsid w = w
    p3 = _lsPos $ _lsParam ls

 destroyLSFlashAt :: Point3 -> World -> World
-destroyLSFlashAt (V3 x' y' z') = tempLightSources .:~ tlsTimeRadFunPos 20 150 intensityFunc (addZ z' p)
+destroyLSFlashAt (V3 x' y' z') = tempLightSources .:~ tlsTimeRadFunPos 20 150 
+    (TLSFade 1 10)
+    (addZ z' p)
  where 
    p = V2 x' y'
-    intensityFunc x 
-        | x < 10 = 1 / (10 - fromIntegral x)
-        | otherwise = 1
@@ -0,0 +1,13 @@
+module Dodge.LightSource.Draw where
+import Dodge.Data.LightSource
+import Picture
+import Geometry.Data
+
+drawLightSource :: LightSourceDraw -> LightSource -> Picture
+drawLightSource lsd = case lsd of
+    DefaultLightSourceDraw -> defLSPic
+defLSPic :: LightSource -> Picture
+defLSPic ls = setLayer BloomNoZWrite . translate3 (_lsPos $ _lsParam ls) . color col $ circleSolid 4
+  where
+    col = V4 r g b 2
+    V3 r g b = _lsCol $ _lsParam ls
@@ -0,0 +1,24 @@
+module Dodge.LightSource.Update where
+import Dodge.Data.LightSource
+import Geometry
+import Control.Lens
+
+updateTempLightSource :: TLSUpdate -> TempLightSource -> Maybe TempLightSource
+updateTempLightSource tlsu = case tlsu of
+    DestroyTLS -> const Nothing
+    TimerTLS -> timerTLS
+    IntensityTLS ConstantIntensity -> updateTempLightSource TimerTLS
+    IntensityTLS (TLSFade startcol x) -> fadeTLS startcol x
+
+fadeTLS :: Point3 -> Int -> TempLightSource -> Maybe TempLightSource
+fadeTLS startcol x tls
+    | t < 1 = Nothing
+    | t < x = Just $ tls & tlsParam . lsCol .~ (1 / fromIntegral (x - t)) *.*.* startcol
+    | otherwise = Just $ tls & tlsParam . lsCol .~ startcol -- this is wasteful, should be set once at begining
+  where
+    t = _tlsTime tls
+    
+timerTLS :: TempLightSource -> Maybe TempLightSource
+timerTLS t 
+    | _tlsTime t <= 0 = Nothing
+    | otherwise       = Just $ t & tlsTime -~ 1
@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
    ( worldSPic
    ) where
+import Dodge.LightSource.Draw
 import Dodge.Targeting.Draw
 import Dodge.Beam.Draw
 import Dodge.RadarSweep.Draw
@@ -127,7 +128,7 @@ extraPics cfig w = pictures (_decorations w)
    <> concatMapPic drawFlare (_flares    w)
    <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams w)
    <> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams w)
-    <> concatMapPic (dbArg _lsPict) (_lightSources w)
+    <> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources w)
    <> testPic cfig w
    <> concatMapPic clDraw (_clouds w      )
    <> concatMapPic ppDraw (_pressPlates w )
@@ -6,6 +6,7 @@ Description : Simulation update
 module Dodge.Update ( updateUniverse ) where
 import Dodge.Data
 import Dodge.Beam
+import Dodge.LightSource.Update
 import Dodge.Projectile.Update
 import Dodge.Creature.Update
 import Dodge.RadarSweep
@@ -209,7 +210,7 @@ updateDistortions = distortions %~ mapMaybe updateDistortion
 updateLightSources :: World -> World
 updateLightSources = tempLightSources %~ f
  where 
-    f = mapMaybe (\b -> _tlsUpdate b b)
+    f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b)

 updateRadarBlips :: World -> World
 updateRadarBlips = radarBlips %~ mapMaybe updateRadarBlip
@@ -47,11 +47,7 @@ flareCircleAt col alphax tranv = flares .:~ CircFlare


 explosionFlashAt :: Point2 -> World -> World
-explosionFlashAt p = tempLightSources .:~ tlsTimeRadFunPos 20 150 intensityFunc (addZ 20 p)
-  where 
-    intensityFunc x 
-        | x < 10 = 1 / (10 - fromIntegral x)
-        | otherwise = 1
+explosionFlashAt p = tempLightSources .:~ tlsTimeRadFunPos 20 150 (TLSFade 1 10) (addZ 20 p)

 ptFlicker :: Particle -> World -> World
 ptFlicker pt