Simplify grid/lattice creation

src/Dodge/Room/Boss.hs

@@ -18,12 +18,13 @@ import LensHelp
 import RandomHelp
 import Control.Monad
 
+-- pathing needs to be done
 roomGlassOctogon ::
     -- | Size
     Float ->
     Room
 roomGlassOctogon x =
-    createPathGrid $
+--    createPathGrid $
         defaultRoom
             { _rmPolys =
                 [ rectNSWE x (- x) (- x) x

src/Dodge/Room/Path.hs

@@ -1,39 +1,20 @@
 module Dodge.Room.Path (
     gridPoints,
     linksGridToPath,
-    makeGrid,
-    createPathGrid,
+--    makeGrid,
+--    createPathGrid,
     gridPoints'',
     linksGridToPath',
 ) where
 
 import Control.Lens
-import qualified Control.Foldl as L
 import Data.Function (on)
 import Data.List
-import Data.Maybe
 import qualified Data.Set as S
 import Dodge.Data.GenWorld
-import Dodge.LevelGen.StaticWalls
 import Geometry
 import Grid
 
-createPathGrid :: Room -> Room
-createPathGrid rm = rm & rmPath .~ linksGridToPath (_rmLinks rm) filterGrid
-  where
-    filterGrid = filter 
-        (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
-    grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy
-    outerWalls = foldr cutPoly [] $ _rmPolys rm
-    outerPoints = map fst outerWalls
-    (minx, maxx, miny, maxy) = L.fold theFold outerPoints
-    theFold =
-        (,,,)
-            <$> L.premap fstV2 L.minimum
-            <*> L.premap fstV2 L.maximum
-            <*> L.premap sndV2 L.minimum
-            <*> L.premap sndV2 L.maximum
-
 -- assumes subpth is symmetric
 linksGridToPath :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
 linksGridToPath lnks subpth = S.fromList subpth <> foldMap (linkClosest . (^. rlPos)) lnks
@@ -45,10 +26,3 @@ linksGridToPath' lnks subpth' = subpth <> foldMap (linkClosest . (^. rlPos)) lnk
   where
     subpth = foldMap doublePairSet subpth'
     linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
-
-testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
-testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
-
---extra test whether both members of the path edge are in some poly
-pairInPolys :: [[Point2]] -> (Point2, Point2) -> Bool
-pairInPolys polys (a, b) = any (pointInPoly a) polys && any (pointInPoly b) polys

src/Dodge/Room/Procedural.hs

@@ -7,9 +7,10 @@ module Dodge.Room.Procedural (
     centerVaultRoom,
     combineRooms,
 --    linksAndPath,
-    makeGrid,
+--    makeGrid,
 ) where
 
+import Grid
 import Dodge.Door.PutSlideDoor
 import Dodge.Default.Wall
 import Control.Monad
@@ -37,16 +38,7 @@ import RandomHelp
 -- This will need a cleanup, but it might change a bit first
 {- A simple rectangular room with a light in the center.
 Creates links and pathfinding graph.  -}
-roomRect ::
-    -- | Width
-    Float ->
-    -- | Height
-    Float ->
-    -- | Number of links on vertical walls
-    Int ->
-    -- | Number of links on horizontal walls
-    Int ->
-    Room
+roomRect :: Float -> Float -> Int -> Int -> Room
 roomRect x y xn yn =
     defaultRoom
         { _rmPolys = [rectNSWE y 0 0 x]
@@ -82,8 +74,14 @@ roomRect x y xn yn =
                 }
         }
   where
+    xs = take (xn + 1) [0,xd..] & each +~ 20
+    ys = take (yn + 1) [0,yd..] & each +~ 20
     yd = (y - 40) / fromIntegral yn
     xd = (x - 40) / fromIntegral xn
+    pth = linksGridToPath lnks 
+        $ latticeXsYs xs ys
+    --pth = linksGridToPath lnks 
+    --    $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
     somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a)
     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)
@@ -97,8 +95,6 @@ roomRect x y xn yn =
     m edge edgefrom1 edgefrom2 =
         zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..]
             . zipCountDown
-    pth = linksGridToPath lnks 
-        $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
     makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnGrid $ makerpedges a) 
         (NotLink True) mempty
     makerpedges (a, b) =

src/Dodge/Room/Tutorial.hs

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

src/Grid.hs

@@ -1,15 +1,12 @@
 module Grid (
-    makeGrid,
     gridInPolygon,
-    shiftedGrid,
     gridPoints,
     gridPoints'',
+    latticeXsYs,
 ) where
 
 import Bound
 import Control.Lens
-import Data.List
-import qualified Data.Tuple.Extra as Tup
 import Geometry
 
 gridInPolygon :: Float -> [Point2] -> [Point2]
@@ -25,65 +22,14 @@ boundedGrid gap (n, s, e, w) = gridPointsOff w s gap nx gap ny
     nx = floor $ (e - w) / gap
     ny = floor $ (n - s) / gap
 
-shiftedGrid ::
-    -- | x min
-    Float ->
-    -- | x max
-    Float ->
-    -- | y min
-    Float ->
-    -- | y max
-    Float ->
-    [(Point2, Point2)]
-shiftedGrid xmin xmax ymin ymax = grid
-  where
-    xd = xmax - xmin
-    yd = ymax - ymin
-    xsteps = ceiling $ (xd - 40) / 60
-    ysteps = ceiling $ (yd - 40) / 60
-    shift p = bimap (p +.+) (p +.+)
-    grid = map (shift (V2 (xmin + 20) (ymin + 20))) $ makeGrid 60 xsteps 60 ysteps
-
 -- creates a DAG
-gridXsYs :: [Float] -> [Float] -> [(Point2, Point2)]
-gridXsYs xs ys =
+latticeXsYs :: [Float] -> [Float] -> [(Point2, Point2)]
+latticeXsYs xs ys =
     foldMap (\y -> mkpairs xs & each . each %~ (`V2` y)) ys
         <> foldMap (\x -> mkpairs ys & each . each %~ V2 x) xs
   where
     mkpairs zs = zip zs $ tail zs
 
-makeGrid ::
-    -- | horizontal step size
-    Float ->
-    -- | number of horizontal steps
-    Int ->
-    -- | vertical step size
-    Float ->
-    -- | number of vertical steps
-    Int ->
-    [(Point2, Point2)]
-makeGrid x nx y ny =
-    foldMap doublePair $
-        gridXsYs (take (nx + 1) [0, x ..]) (take (ny + 1) [0, y ..])
-
--- creates a rectangular grid starting at (0,0) in the positive orthant
--- needs fixing in degenerate (xstep or ystep == 0) cases
-makeGrid' ::
-    -- | horizontal step size
-    Float ->
-    -- | number of horizontal steps
-    Int ->
-    -- | vertical step size
-    Float ->
-    -- | number of vertical steps
-    Int ->
-    [(Point2, Point2)]
-makeGrid' x nx y ny =
-    nub
-        . concatMap doublePair
-        . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
-        $ gridPoints x nx y ny
-
 gridPointsOff :: Float -> Float -> Float -> Int -> Float -> Int -> [Point2]
 gridPointsOff xoff yoff x nx y ny = map f $ gridPoints' nx ny
   where
@@ -92,10 +38,6 @@ gridPointsOff xoff yoff x nx y ny = map f $ gridPoints' nx ny
 gridPoints :: Float -> Int -> Float -> Int -> [Point2]
 gridPoints = gridPointsOff 0 0
 
---    map f $ gridPoints' nx ny
---  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
@@ -103,13 +45,3 @@ gridPoints'' x nx y ny = map f $ gridPoints' nx ny
 
 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))
-        , ((0, 0), (0, y))
-        , ((x, y), (x, 0))
-        , ((x, y), (0, y))
-        ]