Add lights to buttons, cleanup

2021-11-02 19:38:22 +00:00
parent 9eda8c81a9
commit 59f43a3602
25 changed files with 356 additions and 349 deletions
@@ -0,0 +1,113 @@
+module Dodge.Placements.LightSource
+    where
+import Dodge.Data
+import Dodge.LightSources.Lamp
+import Dodge.LevelGen.Data
+import Dodge.Room.Foreground
+import Geometry
+import Dodge.Creature.Inanimate
+import Shape.Data
+import Dodge.Default
+
+mountLightOnShape
+    :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
+    -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightOnShape shapeF ls wallp lsp = ps0j (PutForeground $ shapeF wallp lsp)
+    . ps0 (PutLS $ ls {_lsPos = lsp})
+
+mountLightID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightID = mountLightOnShape f 
+  where
+    f wp (V3 x y z) = thinHighBar (z+5) wp pout
+      where
+        pout = V2 x y +.+ safeNormalizeV (V2 x y -.- wp)
+
+redMID :: (LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement)
+    -> Point2 -> Point3 -> Placement
+redMID f wallp lampp = f defaultLS wallp lampp (const Nothing)
+
+mountLight :: Point2 -> Point3 -> Placement
+mountLight = redMID mountLightID
+
+mountLightLID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightLID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+            <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)    
+      where
+        n = vNormal (wallpos -.- V2 x y)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+
+mountLightL :: Point2 -> Point3 -> Placement
+mountLightL = redMID mountLightLID
+
+mountLightJID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightJID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp turn1
+        <> thinHighBar (z + 5) turn1 turn2
+        <> thinHighBar (z + 5) turn2 (endpos `extendAway` turn2)
+      where
+        n = vNormal (wallpos -.- V2 x y)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+        endpos = V2 x y
+        turn1 = 0.5 *.* (wallposUp +.+ turnpos)
+        turn2 = 0.5 *.* (turnpos +.+ endpos)
+
+mountLightJ :: Point2 -> Point3 -> Placement
+mountLightJ = redMID mountLightJID
+
+mountLightlID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightlID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (turnpos `extendAway` wallposUp)
+        <> thinHighBar (z + 5) turnpos (V2 x y `extendAway` turnpos)
+      where
+        n = vNormal (V2 x y -.- wallpos)
+        wallposUp = wallpos +.+ n
+        turnpos = V2 x y +.+ n
+
+mountLightll :: Point2 -> Point3 -> Placement
+mountLightll = redMID mountLightlID
+
+mountLightA :: Point2 -> Point3 -> Placement
+mountLightA wallpos lamppos@(V3 x y z)
+    = ps0 (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)
+
+mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
+mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
+mountLightI :: Float -> Point2 -> Point2 -> Placement
+mountLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+  where
+    V2 x y = 0.5 *.* (a +.+ b)
+
+mountLightV :: Point2 -> Point3 -> Placement
+mountLightV wallpos lamppos@(V3 x y z)
+    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
+    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
+        <> thinHighBar (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)
+
+putColorLamp :: Point3 -> PSType
+putColorLamp col = PutCrit (colorLamp col 90)
+
+putLamp :: PSType
+putLamp = PutCrit (lamp 90)
+