Add light fittings

src/Dodge/Creature/Inanimate.hs

@@ -11,7 +11,7 @@ import Dodge.Creature.State.Data
 import Dodge.Picture.Layer
 import Dodge.Default
 import Dodge.Creature.State
-import Dodge.LightSources
+import Dodge.LightSources.Lamp
 import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.Sound
 import Dodge.Creature.Update

src/Dodge/LightSources.hs

@@ -1,176 +1,2 @@
 module Dodge.LightSources 
-    ( 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

src/Dodge/LightSources/Fitting.hs

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

src/Dodge/LightSources/Lamp.hs

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

src/Dodge/Prop.hs

@@ -0,0 +1,3 @@
+module Dodge.Prop
+  where
+

src/Dodge/Room/Corridor.hs

@@ -4,7 +4,7 @@ import Dodge.Room.Data
 import Dodge.Room.Foreground
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
-import Dodge.LightSources
+import Dodge.LightSources.Lamp
 import Geometry
 import Tile
 

src/Dodge/Room/LongDoor.hs

@@ -15,7 +15,7 @@ import Dodge.LevelGen.Switch
 import Dodge.RandomHelp
 import Dodge.Creature.Inanimate
 import Dodge.Creature
-import Dodge.LightSources
+import Dodge.LightSources.Lamp
 import Picture
 import Geometry
 
@@ -56,9 +56,9 @@ twinSlowDoorRoom drid w h x = defaultRoom
     , _rmName   = "twinSlowDoorRoom"
     }
   where
-    addColorChange lsid drid = over pjUpdate $ chain $ const f
+    addColorChange lsid drid' = over pjUpdate $ chain $ const f
       where
-        f w' | _drStatus (_doors w' IM.! drid) == DoorHalfway 
+        f w' | _drStatus (_doors w' IM.! drid') == DoorHalfway 
                 = w' & lightSources . ix lsid . lsIntensity .~ V3 8 0 0
              | otherwise = w' & lightSources . ix lsid . lsIntensity .~ 0.7
     drmoving i w' = DoorHalfway == _drStatus (_doors w' IM.! i)

src/Dodge/Room/Start.hs

@@ -4,11 +4,11 @@ import Dodge.Room.Data
 import Dodge.Room.Door
 import Dodge.Room.Link
 import Dodge.Room.Procedural
-import Dodge.Room.Placement
+--import Dodge.Room.Placement
 import Dodge.Room.Foreground
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
---import Dodge.LightSources
+import Dodge.LightSources.Fitting
 --import Picture
 import Geometry.Data
 
@@ -25,18 +25,13 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
-               girderV 40 20 10 (V2  0    (h/6)) (V2  w    (h/6))
+               girderV 40 20 10 (V2  0    (h/2)) (V2  w    (h/2))
-            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/2))
+--            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/2))
-            <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
+--            <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
-        theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
                 $ roomRectAutoLinks w h & rmPS .~ 
             [ fground
-            , theLamp
+            , wallMountA (V2 0 (h/3)) (V3 40 (h/3) 70)
-            --, sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
-            --, sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
             ]
             )
-  where
-    --lampHeight = 41

src/Dodge/WorldEvent.hs

@@ -18,7 +18,7 @@ import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.Explosion
 import Dodge.WorldEvent.SpawnParticle
 --import Dodge.WorldEvent.Shockwave
-import Dodge.LightSources
+import Dodge.LightSources.Lamp
 import Dodge.Creature.State.Data
 import Dodge.Data
 import Dodge.Data.DamageType

src/Dodge/WorldEvent/Flash.hs

@@ -13,7 +13,7 @@ module Dodge.WorldEvent.Flash
 import Dodge.Data
 --import Dodge.Base
 import Dodge.Picture
-import Dodge.LightSources
+import Dodge.LightSources.Lamp
 import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.HelperParticle
 import Picture