Add light fittings

2021-09-29 19:07:02 +01:00
parent f3437adef7
commit d7f975d40e
10 changed files with 252 additions and 192 deletions
@@ -0,0 +1,60 @@
+module Dodge.LightSources.Fitting
+    where
+import Dodge.LightSources.Lamp
+import Dodge.LevelGen.Data
+import Dodge.Room.Foreground
+import Geometry
+
+wallMount :: Point2 -> Point3 -> Placement
+wallMount wallPos lampPos@(V3 x y z) 
+    = Placement (PS (V2 0 0) 0 $ PutForeground $ highBar (z+5) wallPos pout)
+    $ \_ -> Just $ sPS (V2 0 0) 0 $ PutLS (colorLightAt 0.75 lampPos 0)
+  where
+    pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wallPos)
+
+wallMountL :: Point2 -> Point3 -> Placement
+wallMountL wallpos lamppos@(V3 x y z)
+    = place0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+        <> highBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
+  where
+    n = vNormal (wallpos -.- V2 x y)
+    wallposUp = wallpos +.+ n
+    turnpos = V2 x y +.+ n
+
+wallMountl :: Point2 -> Point3 -> Placement
+wallMountl wallpos lamppos@(V3 x y z)
+    = place0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+        <> highBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
+  where
+    n = vNormal (V2 x y -.- wallpos)
+    wallposUp = wallpos +.+ n
+    turnpos = V2 x y +.+ n
+
+wallMountA :: Point2 -> Point3 -> Placement
+wallMountA wallpos lamppos@(V3 x y z)
+    = place0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
+  where
+    pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
+
+wallMountV :: Point2 -> Point3 -> Placement
+wallMountV wallpos lamppos@(V3 x y z)
+    = place0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ highBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
+        <> highBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
+  where
+    lxy = V2 x y
+    n = vNormal (wallpos -.- lxy)
+    wallposUp = wallpos +.+ n
+    wallposDown = wallpos -.- n
+
+extendAway :: Point2 -> Point2 -> Point2
+extendAway p x = p +.+ safeNormalizeV (p -.- x)
+
+jsps0 :: PSType -> Maybe Placement
+jsps0 pst = Just $ sPS (V2 0 0) 0 pst
+
+place0 :: PSType -> (Int -> Maybe Placement) -> Placement
+place0 pst plm = Placement (PS (V2 0 0) 0 pst) plm
@@ -0,0 +1,176 @@
+module Dodge.LightSources.Lamp
+    ( tLightTimedIntensity
+    , tLight
+    , lightAt
+    , colorLightAt
+    , lampPic
+    , lampCover
+    , lampCoverWhen
+    , doubleLampCover
+    , verticalLampCover
+    , chain
+    )
+    where
+import Dodge.Data
+import Geometry.Data
+import Picture
+import ShapePicture
+import Shape
+import Geometry
+
+import Control.Lens
+
+colorLightAt :: Point3 -> Point3 -> Int -> LightSource
+colorLightAt col pos i = 
+    LS {_lsID = i
+       ,_lsPos = pos
+       ,_lsDir = 0
+       ,_lsRad = 700
+       ,_lsIntensity = col
+       ,_lsPict = lightSourcePicture
+       }
+lightSourcePicture :: LightSource -> Picture
+lightSourcePicture ls = setLayer 1 . translate3 (_lsPos ls) . color col $ circleSolid 3
+  where
+    col = V4 r g b 1
+    V3 r g b = _lsIntensity ls
+
+lightAt :: Point3 -> Int -> LightSource
+lightAt = colorLightAt 0.75
+
+tLightTimedIntensity :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
+tLightTimedIntensity t rmax intensityF (V2 x y) = TLS 
+    { _tlsPos = V3 x y 0
+    , _tlsRad = rmax
+    , _tlsIntensity = f $ intensityF t
+    , _tlsUpdate = upF
+    , _tlsTime = t
+    }
+  where
+    upF _ tls 
+        | _tlsTime tls <= 0 = Nothing
+        | otherwise         = Just $ tls    
+            & tlsTime -~ 1
+            & tlsIntensity .~ f (intensityF (_tlsTime tls) )
+    f x' = V3 x' x' x'
+
+tLight
+    :: Int 
+    -> Float -- ^ maximal radius
+    -> Point3
+    -> Point3 
+    -> TempLightSource
+tLight t rmax col (V3 x y z) = TLS 
+    { _tlsPos = V3 x y z
+    , _tlsRad = rmax
+    , _tlsIntensity = col
+    , _tlsUpdate = upF
+    , _tlsTime = t
+    }
+  where
+    upF _ tls 
+        | _tlsTime tls <= 0 = Nothing
+        | otherwise         = Just $ tls    
+            & tlsTime -~ 1
+
+lampPic :: Float -> Picture
+--{-# INLINE lampPic #-}
+lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)
+
+lampCover :: Float -> Prop
+lampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawLampCover h
+    , _prToggle = True
+    }
+lampCoverWhen :: (World -> Bool) -> Float -> Prop
+lampCoverWhen cond h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = setToggle cond `chain` rotateProp 0.15
+    , _prDraw = drawLampCover h
+    , _prToggle = True
+    }
+
+doubleLampCover :: Float -> Prop
+doubleLampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawDoubleLampCover h
+    , _prToggle = True
+    }
+
+-- on the current (27/9/21) version of shadow stencilling, this glitches
+-- slightly when the shadow rotates towards the screen
+verticalLampCover :: Float -> Prop
+verticalLampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawVerticalLampCover h
+    , _prToggle = True
+    }
+
+rotateProp :: Float -> Prop -> World -> World
+rotateProp rotAmount pr w = w
+    & props . ix (_pjID pr) . pjRot +~ rotAmount
+
+setToggle :: (World -> Bool) -> Prop -> World -> World
+setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
+
+-- TODO check whether this is simply the reader monad, flipped
+chain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
+chain f g x = f x . g x
+
+drawLampCover :: Float -> Prop -> SPic
+drawLampCover h pr | not (_prToggle pr) = mempty
+                   | otherwise =
+    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
+        $ rotateSH a $ mconcat
+        [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
+        , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
+        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
+        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
+        --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
+        , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
+        $ rotateSH a $ mconcat
+        [ upperPrismPoly 5 $ rectNSEW 6 5       6 (-6)
+        , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
+        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf pos 
+        $ rotateSHx a $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr