Work on grid for room placements

src/Dodge/Data/CardinalPoint.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Dodge.Data.CardinalPoint where
 import Control.Lens
@@ -9,6 +10,13 @@ data CardinalPoint
     | West
     deriving (Eq, Ord, Show, Bounded, Enum)
 
+revCard :: CardinalPoint -> CardinalPoint
+revCard = \case
+    North -> South
+    East -> West
+    South -> North
+    West -> East
+
 data CardinalPointBetween
     = NorthEast
     | SouthEast

src/Dodge/Room/Procedural.hs

@@ -10,6 +10,7 @@ module Dodge.Room.Procedural (
 --    makeGrid,
 ) where
 
+import Linear
 import Grid
 import Dodge.Door.PutSlideDoor
 import Dodge.Default.Wall
@@ -45,7 +46,8 @@ roomRect x y xn yn =
         , _rmLinks = lnks
         , _rmName = "rect"
         , _rmPath = pth
-        , _rmPos = map makeonpos posps ++ map makeoffpos interposps
+        , _rmPos = map makeonpos (grid xs ys) 
+            <> map makeoffpos (grid (mids xs) (mids ys))
         , _rmPmnts = []
         , _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)]
         , _rmFloor =
@@ -75,36 +77,20 @@ roomRect x y xn yn =
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
     pth = linksDAGToPath lnks $ latticeXsYs xs ys
-    hls y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a
+    horilnks y' a e = xs <&> \x' -> RoomLink (rlt e) (V2 x' y') a
-    vls x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a
+    vertlnks x' a e = ys <&> \y' -> RoomLink (rlt e) (V2 x' y') a
     rlt e = S.fromList [OnEdge e, InLink, OutLink]
-    somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
+    wlnks = vertlnks 0 (pi/2) West
-    wlnks = vls 0 (pi/2) West
+    elnks = vertlnks x (-pi/2) East
-    elnks = vls x (-pi/2) East
+    nlnks = horilnks y 0 North
-    nlnks = hls y 0 North --somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0
+    slnks = horilnks 0 pi South
-    slnks = hls 0 pi South --somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi
+    lnks = imap (g West) nlnks
-    lnks = zipWith g nlnks [0..]
+        <> imap (g West) slnks
-        <> zipWith g slnks [0..]
+        <> imap (g South) elnks
-        <> zipWith g' elnks [0..]
+        <> imap (g South) wlnks
-        <> zipWith g' wlnks [0..]
+    g c xi ln = ln 
-    g ln xi = ln & rlType <>~ S.fromList [FromEdge West xi,FromEdge East (xn - xi)]
+        & rlType <>~ S.fromList [FromEdge c xi,FromEdge (revCard c) (xn - xi)]
-    g' ln xi = ln & rlType <>~ S.fromList [FromEdge South xi,FromEdge North (xn - xi)]
+    grid as bs = [(V2 x' y', (xi,yi)) | (x',xi) <- zip as [0..], (y',yi) <- zip bs [0..]]
---    lnks= m North (FromEdge West) (FromEdge East) nlnks
---            ++ m East (FromEdge South) (FromEdge North) elnks
---            ++ m West (FromEdge South) (FromEdge North) wlnks
---            ++ m South (FromEdge West) (FromEdge East) slnks
-    --wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2)
-    --elnks = 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 (FromEdge West) (FromEdge East) nlnks
-    --        ++ m East (FromEdge South) (FromEdge North) elnks
-    --        ++ m West (FromEdge South) (FromEdge North) wlnks
-    --        ++ m South (FromEdge West) (FromEdge East) slnks
-    m edge edgefrom1 edgefrom2 =
-        zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
-            . zipCountDown
     makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a) 
         (NotLink True) mempty
     makerpedges (a, b) =
@@ -114,8 +100,9 @@ roomRect x y xn yn =
             , PathFromEdge East (xn - a)
             , PathFromEdge West a
             ]
-    posps = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1)
+    --posps = grid -- map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1)
-    interposps = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn
+    mids zs = zipWith (\a b -> 0.5 * (a + b)) zs $ tail zs
+    --interposps = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn
     makeoffpos (p, a) = RoomPos 
         p 0 (S.singleton $ RoomPosOffGrid $ makerpedges' a) (NotLink False) mempty
     makerpedges' (a, b) =
@@ -126,23 +113,6 @@ roomRect x y xn yn =
             , PathFromEdge West a
             ]
 
-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)

src/Dodge/Room/Tutorial.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.Room.Tutorial where
 
+import Dodge.Room.Pillar
 import Dodge.Room.Boss
 import Dodge.Room.Tanks
 import Dodge.Room.LongDoor
@@ -46,6 +47,8 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
+        , tToBTree "cor" . return . cleatOnward <$> roomPillarsSquare
+        , corDoor
 --        , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
 --        , return $ tToBTree "cor" $ return $ cleatOnward $ roomGlassOctogon 200
 --        , corDoor