Add possible cosmetic pipes to tanks

src/Dodge/Base.hs

@@ -11,11 +11,13 @@ module Dodge.Base
     , module Dodge.Base.Window
     , module Dodge.Base.Coordinate
     , module Dodge.Base.Collide
+    , module Dodge.Base.CardinalPoint
     ) where
 import Dodge.Data
 import Dodge.Base.WinScale
 import Dodge.Base.NewID
 import Dodge.Base.Coordinate
+import Dodge.Base.CardinalPoint
 import Dodge.Zone
 --import Dodge.Zone.Data
 import Dodge.Base.Window

src/Dodge/Base/CardinalPoint.hs

@@ -0,0 +1,15 @@
+module Dodge.Base.CardinalPoint where
+import Dodge.Data.Room
+import Geometry
+
+cardList :: [CardinalPoint]
+cardList = [North,East,South,West]
+
+cardVec :: CardinalPoint -> Point2
+cardVec cp = case cp of
+    North -> V2  0   1
+    South -> V2  0 (-1)
+    East -> V2   1   0
+    West -> V2 (-1)  0
+
+

src/Dodge/Data.hs

@@ -924,7 +924,7 @@ data Block = Block
     , _blShadows    :: [Int]   -- a list of blocks/walls? that are not shown when this block exists
     , _blFootprint  :: [Point2]
     , _blPos        :: Point2
-    , _blRot        :: Float
+    , _blDir        :: Float
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
     }
@@ -1402,7 +1402,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutTerminal {_unputTerminal :: Terminal}
     | PutFlIt Item
     | PutPPlate PressPlate
-    | PutBlock Block Wall [Point2]
+    | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2] }
     | PutCoord Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)

src/Dodge/Default/Block.hs

@@ -11,7 +11,7 @@ defaultBlock = Block
     , _blShadows = []
     , _blFootprint = []
     , _blPos       = 0
-    , _blRot       = 0
+    , _blDir       = 0
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
     }

src/Dodge/Floor.hs

@@ -40,9 +40,10 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
 --    [ IntAnno $ AnTree . startRoom
-    [ AnRoom $ tanksRoom [] []
+    [ AnRoom tanksPipesRoom
-    , AnRoom roomPillarsPassage
     , AnRoom tanksPipesRoom
+    , AnRoom $ tanksRoom [] []
+    , AnRoom roomPillarsPassage
     , AnTree firstBreather
 --     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
     , AnRoom $ roomCCrits 10

src/Dodge/Placement/Instance/Pipe.hs

@@ -1,5 +1,12 @@
 module Dodge.Placement.Instance.Pipe where
 import Shape
+import Geometry
+import Quaternion
 
 verticalPipe :: Float -> Shape
-verticalPipe = flip upperPrismPoly $ polyCirc  4 5
+verticalPipe = flip upperPrismPoly $ polyCirc 2 5
+
+horPipe :: Float -> Point2 -> Point2 -> Shape
+horPipe h x y = translateSH (x `v2z` h) $ overPosSH (rotateToZ (V3 xd yd 0)) $ verticalPipe (dist x y)
+  where
+    V2 xd yd = x -.- y

src/Dodge/Placement/Instance/Tank.hs

@@ -26,7 +26,7 @@ tankShape baseshape facade col col'
     = sps0 $ PutBlock bl wl $ reverse baseshape
   where
     bl = defaultBlock
-        & blDraw .~ (\bl' -> (noPic $ uncurryV translateSHf (_blPos bl') $ rotateSH (_blRot bl') $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col'))
+        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
         & blDeath .~ const id
     wl = defaultWall 
         & wlDraw .~ False 

src/Dodge/Placement/PlaceSpot.hs

@@ -103,7 +103,7 @@ placeSpotID ps pt w = case pt of
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
     PutSlideDr  pth col f off  a   b spd 
                             -> plSlideDoor pth col f off (doShift a) (doShift b) spd w
-    PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blRot .~ rot)
+    PutBlock    bl wl  ps'  -> placeBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
                                     wl w
     PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
     PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -85,7 +85,7 @@ placeLineBlock basePane blockWidth depth a b gw = ( 0
     insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
         , _blHP = 1000, _blShadows = shadowsAt i
-        , _blRot = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
+        , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs

src/Dodge/PlacementSpot.hs

@@ -3,6 +3,7 @@ module Dodge.PlacementSpot
     ( atFstLnkOut
     , rpIsOnPath
     , rpIsOffPath
+    , rpOffPathEdge
     , useUnusedLnk
     , psRandRanges
     , useRoomPosCond
@@ -80,6 +81,10 @@ rpIsOffPath = any f . _rpType
   where
     f RoomPosOffPath {} = True
     f _ = False
+rpOffPathEdge :: PathEdge -> RoomPos -> Bool
+rpOffPathEdge pe = any f . _rpType
+  where
+    f rt = maybe False (any (== pe)) (rt ^? offPathEdges) 
 
 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback

src/Dodge/Render/ShapePicture.hs

@@ -33,7 +33,7 @@ worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w = 
     (extraShapes w, extraPics cfig w)
     <> foldMap (dbArg _prDraw) (filtOn _prPos _props)
-    <> foldMap (dbArg _blDraw) (filtOn _blPos _blocks)
+    <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
     <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
     <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
@@ -43,6 +43,12 @@ worldSPic cfig w =
     filtOn f g = IM.filter (pointIsClose . f) (g w)
     pointIsClose = cullPoint cfig w
 
+shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
+shiftDraw fpos fdir fdraw x = uncurryV translateSPf (fpos x)
+    . rotateSP (fdir x)
+    $ fdraw x x
+
+
 cullPoint :: Configuration -> World -> Point2 -> Bool
 cullPoint cfig w p 
     | debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)

src/Dodge/Room/Procedural.hs

@@ -119,7 +119,8 @@ lnkBothAnd rlt ltcon ltcon2 i (j,(p,a)) = RoomLink
 roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = roomRect x y (f x) (f y) 
     & rmName .~ "autoRect"
-    & rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp]
+    & rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp
+        ,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp]
   where
     f z = max 1 $ (ceiling z - 40) `div` 60
 {- Combines two rooms into one room.

src/Dodge/Room/Tanks.hs

@@ -1,5 +1,6 @@
 module Dodge.Room.Tanks where
 import Dodge.Data
+import Dodge.Placement.Instance.Pipe
 import Dodge.LevelGen.Data
 import RandomHelp
 import Dodge.Room.Procedural
@@ -9,11 +10,13 @@ import Dodge.Room.Modify.Girder
 import Dodge.Placement.Instance
 import Dodge.Placement.TopDecoration
 import Dodge.PlacementSpot
+import Dodge.Base.CardinalPoint
 --import Padding
 import Color
---import Shape
+import Shape
+import ShapePicture
 import LensHelp
---import Geometry
+import Geometry
 
 --import Data.Maybe
 --import Data.Tree
@@ -29,11 +32,25 @@ randomTank = takeOne $ map (\f -> f (dim orange) orange)
     , tankSquareDec plusDecoration
     ]
 
+randEdgeTank :: RandomGen g => State g Placement
+randEdgeTank = do
+    edge <- takeOne cardList
+    basetank <- randomTank
+    return $ basetank 
+        & plType . putBlock . blDraw 
+            %~ fmap (<> noPic ( colorSH orange (verticalPipe 80
+                <>  horPipe 80 0 (70 *.* cardVec edge))))
+                    -- 70 is a guess, the true value depends on the distance to the wall
+        & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
+                && rpOffPathEdge (PathFromEdge edge 0) rp)
+
 tanksPipesRoom :: RandomGen g => State g Room
 tanksPipesRoom = do
-    thetank <- randomTank
+    w <- state $ randomR (200,400)
-    let rm = roomRectAutoLinks 200 400  & rmPmnts .:~ thetank
+    h <- state $ randomR (200,400)
-    return rm
+    i <- state $ randomR (1,5)
+    tanks <- replicateM i randEdgeTank
+    return $ roomRectAutoLinks w h & rmPmnts .++~ tanks
 
 tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
 tanksRoom crs its = do