Add more information to Room Positions

src/Dodge/Data.hs

@@ -24,7 +24,9 @@ module Dodge.Data
     , module MaybeHelp
     , module Dodge.Data.ItemAmount
     , module Dodge.RoomCluster.Data
+    , module Dodge.Data.Room
     ) where
+import Dodge.Data.Room
 import Dodge.RoomCluster.Data
 import Dodge.Data.ItemAmount
 import Dodge.ShortShow
@@ -1426,7 +1428,8 @@ data PlacementSpot
 -- TODO attempt to unify/simplify this union type
 data Placement 
     = Placement
-        { _plSpot   :: PlacementSpot
+        { _plOrder  :: Int
+        , _plSpot   :: PlacementSpot
         , _plType   :: PSType
         , _plMID    :: Maybe Int
         , _plIDCont :: World -> Placement -> Maybe Placement 
@@ -1473,52 +1476,6 @@ data Room = Room
     , _rmType       :: RoomType
     , _rmClusterStatus :: ClusterStatus
     }
-data RoomLink = RoomLink
-    { _rlType   :: S.Set RoomLinkType
-    , _rlPos    :: Point2
-    , _rlDir    :: Float
-    } deriving (Eq,Ord)
-data RoomType = DefaultRoomType
-    | RectRoomType
-        { _numLinkEW :: Int
-        , _numLinkNS :: Int
-        , _linkGapEW :: Float
-        , _linkGapNS :: Float
-        , _rmWidth :: Float
-        , _rmHeight :: Float
-        }
-  deriving (Eq,Ord)
-data RoomLinkType
-    = OutLink
-    | InLink
-    | LabLink Int
-    | OnEdge CardinalPoint
-    | FromEdge CardinalPoint Int
-    | BlockedLink
-    deriving (Eq,Ord,Show)
-data CardinalPoint
-    = North
-    | East
-    | South
-    | West
-    deriving (Eq,Ord,Show)
-data RoomWire
-    = --RoomWire Point2 Float
-     WallWire Point2 Float Float
-
-data RPLinkStatus
-    = UsedOutLink 
-        { _rplsType :: S.Set RoomLinkType 
-        , _rplsChildNum :: Int
-        , _rplsOutRoomID :: Int
-        }
-    | UsedInLink  
-        { _rplsType :: S.Set RoomLinkType 
-        , _rplsInRoomID :: Int
-        }
-    | UnusedLink  { _rplsType :: S.Set RoomLinkType }
-    | NotLink
-  deriving (Eq,Ord,Show)
 data OutPlacement = OutPlacement
     { _opPlacement :: Placement
     , _opPlacementID :: Int
@@ -1527,21 +1484,6 @@ data InPlacement = InPlacement
     { _ipPlacement :: [Placement] -> Placement
     , _ipPlacementID :: Int
     }
-data RoomPos = RoomPos
-    { _rpPos :: Point2 
-    , _rpDir :: Float
-    , _rpType :: S.Set RoomPosType
-    , _rpLinkStatus :: RPLinkStatus
-    , _rpPlacementUse :: Int
-    }
-  deriving (Eq,Ord,Show)
-
-data RoomPosType 
-    = RoomPosOnPath
-    | RoomPosOffPath
-    | RoomPosExLink
-    | RoomPosLab Int
-  deriving (Eq,Ord,Show)
 
 makeLenses ''CreatureState
 makeLenses ''Damage
@@ -1621,7 +1563,3 @@ makeLenses ''RoomType
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
-makeLenses ''RoomLink
-makeLenses ''RoomPos
-makeLenses ''RoomPosType
-makeLenses ''RPLinkStatus

src/Dodge/Data/Room.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Room where
+import Geometry
+
+import qualified Data.Set as S
+import Control.Lens
+
+data RoomPos = RoomPos
+    { _rpPos :: Point2 
+    , _rpDir :: Float
+    , _rpType :: S.Set RoomPosType
+    , _rpLinkStatus :: RPLinkStatus
+    , _rpPlacementUse :: Int
+    }
+  deriving (Eq,Ord,Show)
+
+data RoomLink = RoomLink
+    { _rlType   :: S.Set RoomLinkType
+    , _rlPos    :: Point2
+    , _rlDir    :: Float
+    } deriving (Eq,Ord)
+data RoomType = DefaultRoomType
+    | RectRoomType
+        { _numLinkEW :: Int
+        , _numLinkNS :: Int
+        , _linkGapEW :: Float
+        , _linkGapNS :: Float
+        , _rmWidth :: Float
+        , _rmHeight :: Float
+        }
+  deriving (Eq,Ord)
+data RoomLinkType
+    = OutLink
+    | InLink
+    | LabLink Int
+    | OnEdge CardinalPoint
+    | FromEdge CardinalPoint Int
+    | BlockedLink
+    deriving (Eq,Ord,Show)
+data CardinalPoint
+    = North
+    | East
+    | South
+    | West
+    deriving (Eq,Ord,Show)
+data RoomWire
+    = --RoomWire Point2 Float
+     WallWire Point2 Float Float
+
+data RPLinkStatus
+    = UsedOutLink 
+        { _rplsType :: S.Set RoomLinkType 
+        , _rplsChildNum :: Int
+        , _rplsOutRoomID :: Int
+        }
+    | UsedInLink  
+        { _rplsType :: S.Set RoomLinkType 
+        , _rplsInRoomID :: Int
+        }
+    | UnusedLink  { _rplsType :: S.Set RoomLinkType }
+    | NotLink
+  deriving (Eq,Ord,Show)
+data PathEdge = PathFromEdge CardinalPoint Int
+  deriving (Eq,Ord,Show)
+
+data RoomPosType 
+    = RoomPosOnPath {_onPathEdges :: S.Set PathEdge}
+    | RoomPosOffPath {_offPathEdges :: S.Set PathEdge}
+    | RoomPosExLink
+    | RoomPosLab Int
+  deriving (Eq,Ord,Show)
+
+makeLenses ''RoomLink
+makeLenses ''RoomPos
+makeLenses ''RoomPosType
+makeLenses ''RPLinkStatus

src/Dodge/Floor.hs

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

src/Dodge/LevelGen/Data.hs

@@ -20,28 +20,28 @@ import Data.Maybe
 
 
 spNoID :: PlacementSpot -> PSType -> Placement
-spNoID ps pst = Placement ps pst Nothing (const . const Nothing)
+spNoID ps pst = Placement 10 ps pst Nothing (const . const Nothing)
 
 pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement
-pContID ps pt = Placement ps pt Nothing . contToIDCont
+pContID ps pt = Placement 10 ps pt Nothing . contToIDCont
 
 psPtCont :: PlacementSpot -> PSType -> (Placement -> Maybe Placement) -> Placement
-psPtCont ps pt = Placement ps pt Nothing . const
+psPtCont ps pt = Placement 10 ps pt Nothing . const
 
 psPt :: PlacementSpot -> PSType -> Placement
-psPt ps pt = Placement ps pt Nothing (const . const Nothing)
+psPt ps pt = Placement 10 ps pt Nothing (const . const Nothing)
 
 sPS :: Point2 -> Float -> PSType -> Placement
-sPS p a pt = Placement (PS p a) pt Nothing (const . const Nothing)
+sPS p a pt = Placement 10 (PS p a) pt Nothing (const . const Nothing)
 
 sps :: PlacementSpot -> PSType -> Placement
-sps ps pt = Placement ps pt Nothing (const . const Nothing)
+sps ps pt = Placement 10 ps pt Nothing (const . const Nothing)
 
 plRRpt :: Int -> PSType -> Placement
-plRRpt i pt = Placement (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing)
+plRRpt i pt = Placement 10 (PSRoomRand i (uncurry PS)) pt Nothing (const . const Nothing)
 
 jsps :: Point2 -> Float -> PSType -> Maybe Placement
-jsps p a pst = Just $ Placement (PS p a) pst Nothing $ const . const Nothing
+jsps p a pst = Just $ Placement 10 (PS p a) pst Nothing $ const . const Nothing
 
 jsps0 :: PSType -> Maybe Placement
 jsps0 = Just . sPS (V2 0 0) 0
@@ -50,52 +50,52 @@ sps0 :: PSType -> Placement
 sps0 = sPS (V2 0 0) 0
 
 jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
-jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing $ \_ _ -> Just plm
+jspsJ p a pst plm = Just $ Placement 10 (PS p a) pst Nothing $ \_ _ -> Just plm
 
 jsps0J :: PSType -> Placement -> Maybe Placement
-jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm
+jsps0J pst plm = Just $ Placement 10 (PS (V2 0 0) 0) pst Nothing $ \_ _ -> Just plm
 
 ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
-ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . contToIDCont
+ps0 pst = Placement 10 (PS (V2 0 0) 0) pst Nothing . contToIDCont
 
 pt0 :: PSType -> (Placement -> Maybe Placement) -> Placement
-pt0 pst = Placement (PS (V2 0 0) 0) pst Nothing . const
+pt0 pst = Placement 10 (PS (V2 0 0) 0) pst Nothing . const
 
 contToIDCont :: (Int -> Maybe Placement) -> World -> Placement -> Maybe Placement
 contToIDCont f _ = f . fromJust . _plMID
 
 jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement
-jps0' pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . const
+jps0' pst = Just . Placement 10 (PS (V2 0 0) 0) pst Nothing . const
 
 jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
-jps0PushPS pst f = Just . Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
+jps0PushPS pst f = Just . Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
     $ \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt
 
 ps0j :: PSType -> Placement -> Placement
-ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt)
+ps0j pst plmnt = Placement 10 (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt)
 
 psj :: PlacementSpot -> PSType -> Placement -> Placement
-psj ps pst plmnt = Placement ps pst Nothing (\_ -> const $ Just plmnt)
+psj ps pst plmnt = Placement 10 ps pst Nothing (\_ -> const $ Just plmnt)
 
 -- the NoShiftCont is necessary when shifting then combining rooms
 ps0jPushPS :: PSType -> Placement -> Placement
-ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
+ps0jPushPS pst plmnt = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
     $ \_ p -> Just $ plmnt & plSpot .~ _plSpot p
 
 -- the NoShiftCont is necessary when shifting then combining rooms
 ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement
-ps0PushPS pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
+ps0PushPS pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
     $ \_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl)
 
 ps0PushPSw :: PSType -> (World -> Placement -> Maybe Placement) -> Placement
-ps0PushPSw pst f = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
+ps0PushPSw pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing
     $ \w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl)
 
 addPlmnt :: Placement -> Placement -> Placement
 addPlmnt pl pl2 = case pl2 of
     (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
     (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
-    (Placement ps pt mi f) -> Placement ps pt mi (fmap (fmap g) f)
+    (Placement i ps pt mi f) -> Placement i ps pt mi (fmap (fmap g) f)
     PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet"
   where
     g Nothing = Just pl

src/Dodge/Placement/Instance/LightSource.hs

@@ -149,7 +149,7 @@ spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)
     V2 x y = 0.5 *.* (a +.+ b)
 
 spanLS :: LightSource -> Point2 -> Point2 -> Placement
-spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing
+spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing
     $ const $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b
   where
     V3 _ _ h = _lsPos (_lsParam ls) + 5

src/Dodge/PlacementSpot.hs

@@ -1,6 +1,8 @@
 --{-# LANGUAGE LambdaCase #-}
 module Dodge.PlacementSpot 
     ( atFstLnkOut
+    , rpIsOnPath
+    , rpIsOffPath
     , useUnusedLnk
     , psRandRanges
     , useRoomPosCond
@@ -68,6 +70,17 @@ psposAddLabel lab = psSelect %~ (\f rp r -> f rp r & _Just . _2 . rpType %~ S.in
 rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
 rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
 
+rpIsOnPath :: RoomPos -> Bool
+rpIsOnPath = any f . _rpType
+  where
+    f RoomPosOnPath {} = True
+    f _ = False
+rpIsOffPath :: RoomPos -> Bool
+rpIsOffPath = any f . _rpType
+  where
+    f RoomPosOffPath {} = True
+    f _ = False
+
 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback
   where
@@ -109,7 +122,7 @@ unusedOffPathAwayFromLink :: Float -> PlacementSpot
 --unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
 unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpPlacementUse rp == 0 
     && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
-    && RoomPosOffPath `S.member` _rpType rp
+    && rpIsOffPath rp
 
 unusedSpotAwayFromInLink :: Float -> PlacementSpot
 unusedSpotAwayFromInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
@@ -123,8 +136,8 @@ twoRoomPoss :: (RoomPos -> Room -> Bool)
     -> (RoomPos -> Room -> Bool)
     -> (PlacementSpot -> PlacementSpot -> Placement)
     -> Placement
-twoRoomPoss cond1 cond2 f = Placement (rprBool cond1) PutNothing Nothing
+twoRoomPoss cond1 cond2 f = Placement 10 (rprBool cond1) PutNothing Nothing
-    $ \_ pl1 -> Just $ Placement (rprBool cond2) PutNothing Nothing
+    $ \_ pl1 -> Just $ Placement 10 (rprBool cond2) PutNothing Nothing
     $ \_ pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
 
 --isUnusedLnk :: RoomPos -> Bool

src/Dodge/Room/Containing.hs

@@ -21,9 +21,11 @@ roomsContaining crs its = tToBTree "roomsContaining" <$> roomsContaining' crs it
 roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
 roomsContaining' crs its = do
     endroom <- join $ takeOne
-        [ randomFourCornerRoomCrsIts crs its 
+        [roomPillarsSquare
-        , tanksRoom crs its
+--        [ randomFourCornerRoomCrsIts crs its 
-        , roomPillarsContaining crs its
+--        , tanksRoom crs its
+--        , roomPillarsContaining crs its
+--        , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its
         ]
     return (pure $ cleatOnward endroom)
 
@@ -31,10 +33,11 @@ roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room
 roomPillarsContaining crs itms = do
     (w,wn) <- takeOne [(240,2),(340,3)]
     (h,hn) <- takeOne [(240,2),(340,3)]
-    let plmnts = 
+    roomPillars 30 w h wn hn <&> rmPmnts .++~ crsItmsUnused crs itms
-            map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
+
-            ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
+crsItmsUnused :: [Creature] -> [Item] -> [Placement]
-    roomPillars 30 w h wn hn <&> rmPmnts .++~ plmnts
+crsItmsUnused crs itms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms
+    ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs
 
 
 pedestalRoom :: RandomGen g => Item -> State g Room

src/Dodge/Room/Path.hs

@@ -4,6 +4,7 @@ module Dodge.Room.Path
     , linksAndPath'
     , makeGrid
     , createPathGrid
+    , gridPoints''
     )
     where
 --import Dodge.LevelGen.Data
@@ -85,10 +86,22 @@ makeGrid x nx y ny
     . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
     $ gridPoints x nx y ny
 
+--gridPoints :: Float -> Int -> Float -> Int -> [Point2]
+--gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x
+--                              , b <- take ny $ scanl (+) 0 $ repeat y
+--                       ]
 gridPoints :: Float -> Int -> Float -> Int -> [Point2]
-gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x
+gridPoints x nx y ny = map f $ gridPoints' nx ny
-                              , b <- take ny $ scanl (+) 0 $ repeat y
+  where
-                       ]
+    f (a,b) = V2 (fromIntegral a * x) (fromIntegral b * y)
+
+gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2,(Int,Int))]
+gridPoints'' x nx y ny = map f $ gridPoints' nx ny
+  where
+    f (a,b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a,b))
+
+gridPoints' :: Int -> Int -> [(Int,Int)]
+gridPoints' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]]
 
 makeRect :: Float -> Float -> [(Point2,Point2)]
 makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0))

src/Dodge/Room/Pillar.hs

@@ -7,6 +7,7 @@ import Dodge.LevelGen.Data
 import Dodge.Placement.Instance
 --import Dodge.LevelGen.Data
 import Dodge.Room.Procedural
+import Dodge.Room.Link
 import Geometry
 import LensHelp
 
@@ -28,6 +29,9 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
     bl = V2 (-w) (-h)
     aline = PutLineBlock baseBlockPane StoneBlock 9 9
 
+smallPillar :: PSType
+smallPillar = PutBlock StoneBlock 5 [5,5] baseBlockPane $ reverse $ square 5
+
 crossPillar :: Float -> Float -> Placement
 crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
     $ sps0 (aline (V2 0 (-h)) (V2 0 h))
@@ -36,14 +40,35 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
     h = h' - 9
     aline = PutLineBlock baseBlockPane StoneBlock 9 9
 
---longPillars :: Float -> Float
+roomPillarsSquare :: RandomGen g => State g Room
+roomPillarsSquare = return $ roomRectAutoLinks 400 400
+    & rmPmnts .++~ [sps (rprBool $ \rp _ -> t rp) smallPillar
+        ,sps (rprBool $ \rp _ -> t rp) smallPillar
+        ,sps (rprBool $ \rp _ -> t rp) smallPillar
+        ,sps (rprBool $ \rp _ -> t rp) smallPillar
+        ,sps (rprBool $ \rp _ -> t rp) smallPillar
+        ]
+  where
+    t rp = any f (_rpType rp) && _rpPlacementUse rp == 0
+    f rpt = maybe False (PathFromEdge West 1 `S.member`) (rpt ^? onPathEdges)
 
+roomPillarsPassage :: RandomGen g => State g Room
+roomPillarsPassage = do
+    let rm = roomRect 100 300 1 3
+    shuffleLinks $ rm & rmPmnts .~
+        [mntLS iShape (V2 50  0)   (V3 50 10 90)
+        ,mntLS iShape (V2 50  300) (V3 50 290 90)
+        ,mntLS iShape (V2 0   150) (V3 10 150 90)
+        ,mntLS iShape (V2 100 150) (V3 90 150 90)
+        ] ++
+        [ sPS (V2 30 y) 0 smallPillar | y <- [50,90.. 250] ] ++
+        [ sPS (V2 70 y) 0 smallPillar | y <- [50,90.. 250] ]
 roomPillars :: RandomGen g => Float -> Float -> Float -> Int -> Int -> State g Room
 roomPillars pillarsize w h wn hn = do
     let rm = roomRect w h wn hn
-        npillars = length $ filter (S.member RoomPosOffPath . _rpType) $ _rmPos rm
+        npillars = length $ filter rpIsOffPath $ _rmPos rm
     let plmnts = replicate npillars (blockPillar (0.5*pilw) (0.5*pilh) & plSpot .~ rprBool
-                    (\rp _ -> RoomPosOffPath `S.member` _rpType rp
+                    (\rp _ -> rpIsOffPath rp
                               && _rpPlacementUse rp == 0
                               && _rpLinkStatus rp == NotLink )
                 )

src/Dodge/Room/Procedural.hs

@@ -49,8 +49,9 @@ roomRect x y xn yn = defaultRoom
     , _rmLinks = lnks
     , _rmName  = "rect"
     , _rmPath  = concatMap doublePair pth
-    , _rmPos   = map (roomposat RoomPosOnPath) posps
+    --, _rmPos   = map (roomposat (RoomPosOnPath S.empty)) posps
-        ++ map (roomposat RoomPosOffPath) interposps
+    , _rmPos   = map (makeonpos) posps'
+        ++ map (roomposat (RoomPosOffPath S.empty)) interposps
     , _rmPmnts    = []
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = Tiled [Tile 
@@ -85,6 +86,14 @@ roomRect x y xn yn = defaultRoom
     m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..]
         . zipCountDown
     pth  = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
+    makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
+    makerpedges (a,b) = S.fromList 
+        [PathFromEdge South b
+        ,PathFromEdge North (yn-b)
+        ,PathFromEdge East (yn-a)
+        ,PathFromEdge West a
+        ]
+    posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (xn+1)
     posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
     interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
 

src/Dodge/Room/Room.hs

@@ -40,9 +40,9 @@ roomC :: RandomGen g => Float -> Float -> State g Room
 roomC w h = do
     wallf <- takeOne [ crystalLine , windowLine ]
     ntanks <- takeOne [0,0,0,0,0,1,1,1,1,2,3,4]
-    thetank <- randomTank <&> plSpot .~ (rprBool $ \rp _ ->
+    thetank <- randomTank <&> plSpot .~ rprBool (\rp _ ->
         _rpPlacementUse rp == 0
-        && RoomPosOffPath `S.member` _rpType rp
+        && rpIsOffPath rp
         && (xV2 (_rpPos rp) > w / 2 + 5 || xV2 (_rpPos rp) < w / 2 - 5  ))
     maybeaddgird <- takeOne [return, addRandomGirderFrom West 0, addRandomGirderFrom North 0]
     maybeaddgird =<< shuffleLinks (roomRectAutoLinks w h
@@ -196,14 +196,14 @@ weaponBetweenPillars = do
     (w,wn) <- takeOne [(240,2),(340,3)]
     (h,hn) <- takeOne [(240,2),(340,3)]
     let wpPos = rprBool $ \rp r -> and 
-            [ RoomPosOnPath `S.member` _rpType rp
+            [ rpIsOnPath rp
             , _rpPlacementUse rp == 0
             , _rpLinkStatus rp == NotLink
             , any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
             ]
     ncrits <- state $ randomR (1,3)
     critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r -> 
-        RoomPosOnPath `S.member` _rpType rp
+        rpIsOnPath rp
         && _rpPlacementUse rp == 0
         && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
     fmap pure $ roomPillars 30 w h wn hn 
@@ -242,7 +242,7 @@ deadEndRoom = defaultRoom
 weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 weaponRoom i = join $ takeOne 
     [ weaponEmptyRoom       >>= rToOnward "weaponEmptyRoom"
-    , weaponUnderCrits i
+    , weaponUnderCrits i  -- this int is used for PickOnePlacement
     , weaponBehindPillar    >>= rToOnward "weaponBehindPillar"
     , weaponBetweenPillars  >>= rToOnward "weaponBetweenPillars"
     , weaponLongCorridor    >>= rToOnward "weaponLongCorridor"
@@ -300,7 +300,7 @@ pistolerRoom :: RandomGen g => State g Room
 pistolerRoom = do
     (w,wn) <- takeOne [(200,3),(255,4)]
     roomPillars 10 w 200 wn 3 <&> rmPmnts .++~ replicate 3 
-        (spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && RoomPosOnPath `S.member` _rpType rp) 
+        (spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp) 
         (PutCrit pistolCrit))
 
 shootingRange :: RandomGen g => State g (MetaTree Room String)
@@ -328,7 +328,7 @@ spawnerRoom = do
     x <- state $ randomR (250,300)
     y <- state $ randomR (300,400)
     roomWithSpawner <- roomC x y <&> rmPmnts .:~ spNoID 
-        (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && RoomPosOnPath `S.member` _rpType rp
+        (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp
                         && xV2 (_rpPos rp) < x/2 && yV2 (_rpPos rp) < y/2 ) 
         (PutCrit spawnerCrit)
     aRoom <- airlock

src/Dodge/Room/Start.hs

@@ -55,6 +55,7 @@ powerFakeout = do
                 , keyholeCorridor, corridor
             ,cleatOnward door]
 
+-- the i is used either for a PickOnePlacement or a room id, this is not great
 startRoom :: RandomGen g => Int -> State g (MetaTree Room String)
 startRoom i = join $ takeOne
     [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i