94 lines
2.9 KiB
Haskell
94 lines
2.9 KiB
Haskell
module Dodge.Room.Path
|
|
( gridPoints
|
|
, linksAndPath
|
|
, makeGrid
|
|
, createPathGrid
|
|
)
|
|
where
|
|
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 = 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
|
|
|
|
-- ?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))
|
|
]
|
|
|