Simplify grid/lattice creation

This commit is contained in:
2025-10-27 12:21:18 +00:00
parent 437f5d44d8
commit c88fc1c729
6 changed files with 138 additions and 222 deletions
+3 -71
View File
@@ -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))
]