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