Add more procedural girders

src/Dodge/Room/Tanks.hs

@@ -10,9 +10,9 @@ import Dodge.Placement.TopDecoration
 import Dodge.PlacementSpot
 --import Padding
 import Color
---import Shape
+import Shape
 import LensHelp
---import Geometry
+import Geometry
 
 --import Data.Maybe
 --import Data.Tree
@@ -29,6 +29,29 @@ randomTank = takeOne $ map (\f -> f (dim orange) orange)
     , roundTankCross
     , tankSquareDec plusDecoration
     ]
+addGirderNS :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
+addGirderNS shapef col room = do
+    let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room
+    girderPosOrder <- shuffle [1 .. nwestlnks - 2]
+    return $ room & rmPmnts .:~ foldr1 setFallback 
+        (sps0 PutNothing : [ twoRoomPoss 
+            (isUnusedLnkType (FromWest i)) 
+            (isUnusedLnkType (FromWest i)) 
+            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
+       | i <- girderPosOrder]
+        )
+addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room
+addGirderEW shapef col room = do
+    let nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
+    girderPosOrder <- shuffle [1 .. nwestlnks - 2]
+    return $ room & rmPmnts .:~ foldr1 setFallback 
+        (sps0 PutNothing :
+        [ twoRoomPoss
+            (isUnusedLnkType (FromSouth i)) 
+            (isUnusedLnkType (FromSouth i)) 
+            $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) 
+       | i <- girderPosOrder]
+        )
 
 tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
 tanksRoom crs its = do
@@ -37,17 +60,19 @@ tanksRoom crs its = do
     ntanks  <- state $ randomR (3,6)
     thetank <- randomTank <&> plSpot .~ unusedOffPathAwayFromLink 50
     let room = roomRectAutoLinks w h
-        nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room
-    girderPosOrder <- shuffle [1 .. nwestlnks - 2]
     let plmnts = 
-            --ok, this has become complicated
-            foldr1 setFallback [ twoRoomPoss (isUnusedLnkType (FromSouth i)) 
-                (isUnusedLnkType (FromSouth i)) $ \ps1 ps2 ->
-                sps0 $ PutShape $ girderV 96 20 10 (_psPos ps1) (_psPos ps2) 
-                | i <- girderPosOrder]
-            : map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
+            map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its
             ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
             ++ replicate ntanks thetank
 --            , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
-    return $ room & rmPmnts .++~ plmnts
+    hgshape <- takeOne [girder 96 20 10, girderZ 96 20 10, girderV 96 20 10]
+    addhighgirds <- takeOne $
+        [ addGirderEW hgshape black >=> addGirderEW hgshape black
+        , addGirderEW hgshape black
+        , addGirderNS hgshape black >=> addGirderNS hgshape black
+        , addGirderNS hgshape black
+        ] ++ replicate 4 return
+    lgshape <- takeOne [girder 60 20 10, girderZ 60 20 10, girderV 60 20 10]
+    addlowgirds  <- takeOne $ addGirderNS lgshape red : replicate 4 return
+    (addlowgirds >=> addhighgirds) $ room & rmPmnts .++~ plmnts
         & rmName .~ "tanksRoom"