Tweak pipes and girders

src/Dodge/Creature/Inanimate.hs

@@ -37,7 +37,7 @@ colorLamp
 colorLamp col h = defaultInanimate
     { _crUpdate = initialiseColorLamp col h
     , _crHP = 100
-    , _crPict = picAtCrPosNoRot (lampPic h)
+    , _crPict = picAtCrPosNoRot (lampCrPic h)
     , _crRad = 3
     , _crMass = 3
     }
@@ -46,14 +46,13 @@ lamp :: Float -> Creature
 lamp h = defaultInanimate
     { _crUpdate = initialiseLamp h
     , _crHP = 100
-    , _crPict = picAtCrPosNoRot (lampPic h)
+    , _crPict = picAtCrPosNoRot (lampCrPic h)
     , _crRad = 3
     , _crMass = 3
     }
 -- it is not clear that any of the attempts with Foldl help at all here
-lampPic :: Float -> Picture
+lampCrPic :: Float -> Picture
---{-# INLINE lampPic #-}
+lampCrPic h = pictures 
-lampPic h = pictures 
     [ setLayer 1 (setDepth h . color white $ circleSolid 3)
     , concatMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
     ]

src/Dodge/LevelGen.hs

@@ -19,6 +19,7 @@ import Dodge.LevelGen.TriggerDoor
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
 import Geometry
+import Geometry.Vector3D
 import Shape
 --import Geometry.Data
 import Picture
@@ -199,9 +200,10 @@ placeCr crF p rot = over creatures addCr
 placeLS :: LightSource -> Picture -> Point3 -> Float -> World -> World
 placeLS ls dec (V3 x y z) rot w = over lightSources addLS $ over decorations addDec w
   where 
+    startPos = _lsPos ls
     addLS lss = IM.insert 
         (IM.newKey lss) 
-        (ls {_lsPos = V3 x y z,_lsDir = rot,_lsID = IM.newKey lss}) 
+        (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) 
         lss
     addDec decs = IM.insert 
         (IM.newKey decs) 

src/Dodge/LightSources.hs

@@ -3,10 +3,12 @@ module Dodge.LightSources
     , tLight
     , lightAt
     , colorLightAt
+    , lampPic
     )
     where
 import Dodge.Data
 import Geometry.Data
+import Picture
 
 import Control.Lens
 
@@ -57,3 +59,6 @@ tLight t rmax col (V3 x y z) = TLS
         | otherwise         = Just $ tls    
             & tlsTime -~ 1
 
+lampPic :: Float -> Picture
+--{-# INLINE lampPic #-}
+lampPic h = setLayer 1 (setDepth h . color white $ circleSolid 3)

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
+highBar :: Float -> Point2 -> Point2 -> Shape
-highPipe h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
+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
+    [ highBar h xt yt
-    , highPipe h xb yb
+    , 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
+    [ highBar h xt yt
-    , highPipe h xb yb
+    , 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
+    [ highBar h xt yt
-    , highPipe h xb yb
+    , 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