Commit before making out and in placements have ids

src/Dodge/Room/Procedural.hs

@@ -1,5 +1,4 @@
-{- | 
- Procedural creation of rooms and subroom parts.  -}
+{- | Procedural creation of rooms and subroom parts.  -}
 module Dodge.Room.Procedural
     ( roomRect
     , roomRectAutoLinks
@@ -74,24 +73,35 @@ roomRect x y xn yn = defaultRoom
     wlnks = somelnks (V2 x 20) (gridPoints  0  1      yd (yn+1))  (-pi/2) 
     nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1)  0  1     )       0  
     slnks = somelnks (V2 20 0) (gridPoints xd (xn+1)  0  1     )      pi  
-    lnks = m North FromWest nlnks
-        ++ m East FromSouth elnks
-        ++ m West FromSouth wlnks
-        ++ m South FromWest slnks
-    m edge edgefrom = zipWith (lnkBothAnd' (OnEdge edge) edgefrom) [0..]
+    lnks = m North FromWest FromEast nlnks
+        ++ m East FromSouth FromNorth elnks
+        ++ m West FromSouth FromNorth wlnks
+        ++ m South FromWest FromEast slnks
+    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)
     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
+
+zipCountDown :: [a] -> [(Int,a)]
+zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs
+
+lnkBothAnd' :: RoomLinkType -> (Int -> RoomLinkType) 
+    -> (Int -> RoomLinkType)
+    -> Int -> (Int,(Point2,Float)) -> RoomLink
+lnkBothAnd' rlt ltcon ltcon2 i (j,(p,a)) = RoomLink 
+    {_rlType = S.fromList [OutLink,InLink,rlt,ltcon i,ltcon2 j]
+    ,_rlPos = p 
+    , _rlDir = a
+    }
 {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.  -}
 -- it is not clear to me that this works for very small rooms (but it does seem
 -- to do so)
 roomRectAutoLinks :: Float -> Float -> Room
-roomRectAutoLinks x y = (roomRect x y xn yn)
-    {_rmPmnts = plmnts}
+roomRectAutoLinks x y = (roomRect x y (f x) (f y)) {_rmPmnts = plmnts}
   where
-    xn = max 1 $ (ceiling x - 40) `div` 60
-    yn = max 1 $ (ceiling y - 40) `div` 60
-    plmnts = replicate 3 (mntLightLnkCond $ useRoomPosCond isUsedLnkUnplaced)
+    f z = max 1 $ (ceiling z - 40) `div` 60
+    plmnts = replicate 3 . mntLightLnkCond $ useRoomPosCond isUsedLnkUnplaced
 {- Combines two rooms into one room.
  - will have to work out exactly what to do with combining links
 Mostly involves concatenation.  -}
@@ -126,7 +136,7 @@ quarterRoomTri w = do
         [   [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70)
             , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w)
             ]
-        ,   [blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
+        ,   [ blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
         ,   [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
             , blockLine (V2 (-29) w) (V2 0 (w/2))
             ]
@@ -142,10 +152,7 @@ quarterRoomTri w = do
             ,(V2 0 (w-20),V2 0 0)
             ,(V2 (55-w) (w-20),V2 0 0)
             ]
-        , _rmPmnts  = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70)
-            , sPS (V2 (w-20) (w-20)) pi PutNothing 
-            , sPS (V2 (w-15) (w-25)) pi PutNothing 
-            ]
+        , _rmPmnts  = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) ]
         , _rmPos = 
             [ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0
             , RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0
@@ -167,9 +174,9 @@ quarterRoomSquare w = do
         ]
     pure $ defaultRoom
         { _rmPolys  = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
-        , _rmLinks  = 
-            [toBothLnk (V2 (w/2) (3*w/2), negate $ pi/4)
-            ,toBothLnk (V2 (negate $ w/2) (3*w/2), pi/4)
+        , _rmLinks  = map toBothLnk
+            [ (V2 (w/2) (3*w/2), negate $ pi/4)
+            , (V2 (negate $ w/2) (3*w/2), pi/4)
             ]
         , _rmPath   = concatMap doublePair
             [(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
@@ -183,15 +190,9 @@ quarterRoomSquare w = do
             ,(V2 0 0,V2 0 (w-40))
 --            ,(V2 (20-w) (w-20),V2 (40-w) (w))
             ]
-        , _rmPmnts = b ++
-            [ blockLine (V2 (w/2) (w/2)) (V2 0 w)
-            , sPS (V2 20 (2*w-40)) pi PutNothing
-            , sPS (V2 25 (2*w-45)) pi PutNothing
-            ]
-        , _rmPos = 
-                [ RoomPos (V2 20 (2*w-40)) pi S.empty NotLink 0
-                , RoomPos (V2 25 (2*w-45)) pi S.empty NotLink 0
-                ]
+        , _rmPmnts = b ++ [ blockLine (V2 (w/2) (w/2)) (V2 0 w) ]
+        , _rmPos = [ RoomPos p pi S.empty NotLink 0 
+                    | p <- [V2 20 (2*w-40),V2 25 (2*w-45)] ]
         , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
         }
 {- | Randomise the ordering of placements in a room.