Tweak pipes and girders

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