Create new files

2021-09-08 17:41:40 +01:00
parent 643cd5a420
commit f3c5e3a177
5 changed files with 277 additions and 0 deletions
@@ -0,0 +1,96 @@
+module Dodge.Room.Path
+    ( gridPoints
+    , linksAndPath
+    , makeGrid
+    , createPathGrid
+    )
+    where
+import Dodge.Data
+import Dodge.Room.Data
+import Dodge.LevelGen.StaticWalls
+import Geometry
+
+import Data.Function (on)
+import Data.List
+import Data.Bifunctor
+import Data.Maybe
+import qualified Data.Tuple.Extra as Tup
+import qualified Control.Foldl as L
+
+createPathGrid :: Room -> Room
+createPathGrid rm = rm
+    { _rmPath = linksAndPath (_rmLinks rm) filterGrid }
+  where
+    filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
+    grid = case shiftedGrid <$> minx <*> maxx <*> miny <*> maxy of
+        Nothing -> []
+        Just xs -> xs
+    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
+
+-- ?TODO? : make this minimumOn
+linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
+linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
+  where 
+    linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ 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 (pointInPolygon a) polys && any (pointInPolygon b) polys
+
+shiftedGrid
+    :: Float    -- ^ x min
+    -> Float    -- ^ x max
+    -> Float    -- ^ y min
+    -> Float    -- ^ y max
+    -> [(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 rectangular grid starting at (0,0) in the positive orthant
+-- needs fixing in degenerate (xstep or ystep == 0) cases
+makeGrid 
+    :: Float    -- ^ horizontal step size
+    -> Int      -- ^ number of horizontal steps
+    -> Float    -- ^ vertical step size
+    -> Int      -- ^ number of vertical steps
+    -> [(Point2,Point2)]
+makeGrid x nx y ny 
+    = nub 
+    . concatMap doublePair 
+    . 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
+                       ]
+
+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))
+               ]
+