Refactor light sources

src/Dodge/Data/LightSource.hs

@@ -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
+    , _lsDir    :: Float
-    , _lsPict   :: LightSource -> Picture
+    , _lsPict   :: LightSourceDraw --LightSource -> Picture
     }
 data TempLightSource = TLS 
     { _tlsParam     :: LSParam
-    , _tlsUpdate    :: TempLightSource -> Maybe TempLightSource
+    , _tlsUpdate    :: TLSUpdate --TempLightSource -> Maybe TempLightSource
-    , _tlsTime      :: !Int
+    , _tlsTime      :: Int
     }
 makeLenses ''LSParam
 makeLenses ''LightSource

src/Dodge/Default/LightSource.hs

@@ -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

src/Dodge/LightSource.hs

@@ -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 
+--    upF tls 
-        | _tlsTime tls <= 0 = Nothing
+--        | _tlsTime tls <= 0 = Nothing
-        | otherwise         = Just $ tls    
+--        | otherwise         = Just $ tls    
-            & tlsTime -~ 1
+--            & tlsTime -~ 1
-            & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) )
+--            & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) )
-    f x' = V3 x' x' x'
+--    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

src/Dodge/LightSource/Draw.hs

@@ -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

src/Dodge/LightSource/Update.hs

@@ -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

src/Dodge/Render/ShapePicture.hs

@@ -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 )

src/Dodge/Update.hs

@@ -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

src/Dodge/WorldEvent/Flash.hs

@@ -47,11 +47,7 @@ flareCircleAt col alphax tranv = flares .:~ CircFlare
 
 
 explosionFlashAt :: Point2 -> World -> World
-explosionFlashAt p = tempLightSources .:~ tlsTimeRadFunPos 20 150 intensityFunc (addZ 20 p)
+explosionFlashAt p = tempLightSources .:~ tlsTimeRadFunPos 20 150 (TLSFade 1 10) (addZ 20 p)
-  where 
-    intensityFunc x 
-        | x < 10 = 1 / (10 - fromIntegral x)
-        | otherwise = 1
 
 ptFlicker :: Particle -> World -> World
 ptFlicker pt