Tweak pipes and girders

src/Dodge/Room/Corridor.hs

@@ -1,9 +1,11 @@
 module Dodge.Room.Corridor
     where
 import Dodge.Room.Data
+import Dodge.Room.Foreground
 import Dodge.Default.Room
+import Dodge.LevelGen.Data
+import Dodge.LightSources
 import Geometry
---import Geometry.Data
 import Tile
 
 import Data.Bifunctor
@@ -14,7 +16,10 @@ corridor = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
-    , _rmPS    = []
+    , _rmPS    = 
+        [ sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
+        , sPS (V2 0 0)   0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
+        ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
     , _rmFloor = [makeTileFromPoly poly 2]  
     }

src/Dodge/Room/Foreground.hs

@@ -6,7 +6,7 @@ module Dodge.Room.Foreground
 import Picture
 import Geometry
 --import Geometry.Data
---import Geometry.Vector3D
+import Geometry.Vector3D
 import Shape
 
 import Data.List
@@ -47,22 +47,30 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
         ]
     yN = d * 0.5 *.* normalizeV (pa -.- pb)
 
-highPipe :: Float -> Point2 -> Point2 -> Shape
-highPipe h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
+highBar :: Float -> Point2 -> Point2 -> Shape
+highBar h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
     [x +.+ n, y +.+ n, y -.- n, x -.- n]
   where
     n = 2.5 *.* normalizeV (vNormal (y -.- x))
 
+highPipe :: Float -> Point2 -> Point2 -> Shape
+highPipe h x y = colorSH orange $ prismPoly
+    (map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
+    (map (addZ h)       [x +.+ n, y +.+ n, y -.- n, x -.- n]    )
+  where
+    n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
+    n = 2.5 *.* normalizeV (vNormal (y -.- x))
+
 girderZ 
     :: Float -- ^ height
     -> Float -- ^ distance between cross bars
     -> Float -- ^ width
     -> Point2 -> Point2 -> Shape
 girderZ h d w x y = colorSH red $ mconcat $
-    [ highPipe h xt yt
-    , highPipe h xb yb
+    [ highBar h xt yt
+    , highBar h xb yb
     ]
-    <> zipWith (highPipe (h- 5)) ps qs
+    <> zipWith (highBar (h- 5)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n
@@ -78,10 +86,10 @@ girderV
     -> Float -- ^ width
     -> Point2 -> Point2 -> Shape
 girderV h d w x y = colorSH red $ mconcat $
-    [ highPipe h xt yt
-    , highPipe h xb yb
+    [ highBar h xt yt
+    , highBar h xb yb
     ]
-    <> zipWith (highPipe (h- 5)) ps qs
+    <> zipWith (highBar (h- 5)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n
@@ -101,10 +109,10 @@ girder
     -> Float -- ^ width
     -> Point2 -> Point2 -> Shape
 girder h d w x y = colorSH red $ mconcat $
-    [ highPipe h xt yt
-    , highPipe h xb yb
+    [ highBar h xt yt
+    , highBar h xb yb
     ]
-    <> zipWith (highPipe (h- 5)) ps qs
+    <> zipWith (highBar (h- 5)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n