91 lines
2.4 KiB
Haskell
91 lines
2.4 KiB
Haskell
module Grid where
|
|
|
|
import Bound
|
|
--import Data.Function (on)
|
|
|
|
import Data.Bifunctor
|
|
import Data.List
|
|
--import Data.Maybe
|
|
import qualified Data.Tuple.Extra as Tup
|
|
import Geometry
|
|
|
|
gridInPolygon :: Float -> [Point2] -> [Point2]
|
|
gridInPolygon gap ps =
|
|
filter (`pointInPoly` ps)
|
|
. maybe [] (boundedGrid gap)
|
|
. boundPoints
|
|
$ ps
|
|
|
|
boundedGrid :: Float -> (Float, Float, Float, Float) -> [Point2]
|
|
boundedGrid gap (n, s, e, w) = gridPointsOff w s gap nx gap ny
|
|
where
|
|
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 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
|
|
f (a, b) = V2 (xoff + fromIntegral a * x) (yoff + fromIntegral b * y)
|
|
|
|
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
|
|
f (a, b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a, b))
|
|
|
|
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))
|
|
]
|