justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Improve line zoning

Browse Source
This commit is contained in:
jgk
2021-08-16 14:44:52 +02:00
parent 3192ae628f
commit c58ee6d56c
13 changed files with 197 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+5 -5
View File
@@ -74,7 +74,7 @@ wallNormal wl = normalizeV . vNormal $ a -.- b
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls
where
hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w)
hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
@@ -252,7 +252,7 @@ collidePointFF = undefined
-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
--collidePointFF p1 p2 g ff = fmap f ip
-- where (p3:p4:_) = _ffLine ff
-- ip = intersectSegSeg' p1 p2 p3 p4
-- ip = intersectSegSeg p1 p2 p3 p4
-- ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff
-- f p = (p, (ref, _ffID ff))
--
@@ -267,7 +267,7 @@ collideCircWalls' p1 p2 rad ws
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
) ws
@@ -288,7 +288,7 @@ collideCircWalls' p1 p2 rad ws
collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
collidePointLines p1 p2 ws
= safeMinimumOn f
$ mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) )
$ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine') ws
where
f (a,_) = magV (p1 -.- a)
@@ -298,7 +298,7 @@ collidePointLines p1 p2 ws
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws
= safeMinimumOn f
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) )
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
src/Dodge/Base/Collide.hs
+9 -9
View File
@@ -24,7 +24,7 @@ hitPointLines
hitPointLines p1 p2
= safeMinimumOn (dist p1 . fst)
. mapMaybe
(\(x,y) -> (, (x,y)) <$> intersectSegSeg' p1 p2 x y)
(\(x,y) -> (, (x,y)) <$> intersectSegSeg p1 p2 x y)
-- | looks for first collision of a point with walls
-- if found, gives point and reflection velocity
@@ -36,7 +36,7 @@ reflectPointWalls p1 p2 ws
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
(intersectSegSeg p1 p2 x y)
)
. _wlLine) ws
-- | Looks for first collision of a point with walls.
@@ -52,43 +52,43 @@ reflectPointWallsDamped dfact p1 p2 ws
$ IM.mapMaybe
(( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
(intersectSegSeg' p1 p2 x y))
(intersectSegSeg p1 p2 x y))
. _wlLine
) ws
-- | Test if a point collides with walls
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
pointHitsWalls p1 p2
= any $ isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine
= any $ isJust . uncurry (intersectSegSeg p1 p2) . _wlLine
-- | Test if there something blocking a walk
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws
= any (isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine)
= any (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws
= fromMaybe p2
. safeMinimumOn (dist p1)
$ IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) ws
$ IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine) ws
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
collidePointIndirect p1 p2 ws
= safeMinimumOn (dist p1)
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine)
. IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine)
$ IM.filter (not . _wlIsSeeThrough) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointFire p1 p2 ws
= safeMinimumOn (dist p1)
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine )
. IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine )
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws
= any ( isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine)
= any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
$ IM.filter notBlockWindow ws
where
notBlockWindow wl = case wl ^? blHP of
src/Dodge/Base/Zone.hs
+12 -9
View File
@@ -5,6 +5,7 @@ module Dodge.Base.Zone
import Dodge.Data
import Dodge.Base.Window
import Geometry
import Geometry.Zone
import Data.Maybe
import Data.List
@@ -73,14 +74,16 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where
(x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap = ddaExt zoneSize
--zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
-- where
-- (x,y) = zoneOfPoint a
-- (x',y') = zoneOfPoint b
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE expandLine #-}
--{-# INLINE expandLine #-}
expandLine xs = IM.map expandSet
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
where
@@ -172,10 +175,10 @@ lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-- there is certainly a problem somewhere here: it may be in the zoning, or
-- within this function
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
--{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) m
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of
Just val -> val
src/Dodge/LevelGen/Pathing.hs
+1 -1
View File
@@ -23,6 +23,6 @@ removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraph' w
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/LevelGen/TriggerDoor.hs
+2 -2
View File
@@ -30,7 +30,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
@@ -49,7 +49,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
src/Dodge/Render/Picture.hs
+3 -3
View File
@@ -121,7 +121,7 @@ wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
-- towards the center of sight
lineOnScreenCone :: World -> Point2 -> Point2 -> Bool
lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon w
vp = _cameraViewFrom w
@@ -132,7 +132,7 @@ lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
lineOnScreen :: World -> Point2 -> Point2 -> Bool
lineOnScreen w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
@@ -160,7 +160,7 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] +
where
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
. makeLoopPairs $ screenPolygon w
rectangleSolid :: Float -> Float -> Picture
src/Dodge/Update.hs
+1 -1
View File
@@ -226,5 +226,5 @@ visibleWalls p1 p2 ws
. map f
$ IM.toList ws
where
f (i,wl) = (uncurry intersectSegSeg' (_wlLine wl) p1 p2, (i,wl))
f (i,wl) = (uncurry intersectSegSeg (_wlLine wl) p1 p2, (i,wl))
src/Dodge/WallCreatureCollisions.hs
+2 -2
View File
@@ -105,11 +105,11 @@ checkPushThroughs cp1 wls cp2
checkPushThrough :: Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2
checkPushThrough cp1 cp2 (wp1,wp2)
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
| isPushedThrough = intersectSegSeg cp1 cp2 wp1 wp2
| otherwise = Nothing
where
--norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
--wp1' = (rad *.* norm) +.+ wp1
--wp2' = (rad *.* norm) +.+ wp2
--newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg cp1 cp2 wp1 wp2)
src/Dodge/WorldEvent/ThingsHit.hs
+2 -2
View File
@@ -34,7 +34,7 @@ thingsHit sp ep w
Just val -> val
_ -> IM.empty
wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w' = uncurry (intersectSegSeg' sp ep) (_wlLine w')
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
{- List objects that appear on a line.
@@ -76,7 +76,7 @@ thingsHitLongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitPoint wl = uncurry (intersectSegSeg' sp ep) (_wlLine wl)
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
src/Geometry.hs
+6 -47
View File
@@ -15,6 +15,7 @@ module Geometry
, module Geometry.Bezier
, module Geometry.Vector
, module Geometry.LHS
--, module Geometry.Zone
)
where
import Geometry.Data
@@ -22,11 +23,9 @@ import Geometry.Intersect
import Geometry.Bezier
import Geometry.Vector
import Geometry.LHS
--import Geometry.Zone
--import Data.Function
import Data.List
import Data.Maybe
--import Control.Applicative
-- | Return a point a distance away from a first point towards a second point.
-- Does not go past the second point.
alongSegBy :: Float -> Point2 -> Point2 -> Point2
@@ -191,48 +190,6 @@ doublePair (x,y) = [(x,y),(y,x)]
doubleV2 :: V2 a -> [V2 a]
doubleV2 (V2 x y) = [V2 x y,V2 y x]
-- | Test whether two polygons intersect by testing the intersection of each
-- consecutive pair of points.
--polysIntersect :: [Point2] -> [Point2] -> Bool
--{-# INLINE polysIntersect #-}
--polysIntersect (p:ps) (q:qs)
-- -- = any isJust $ (\(V2 a b) (V2 c d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
-- = or $ (\(V2 a b) (V2 c d) -> isJust $ myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
-- where
-- pairs1 = zipWith V2 (p:ps) (ps++[p])
-- pairs2 = zipWith V2 (q:qs) (qs++[q])
--polysIntersect _ _ = False
polysIntersect :: [Point2] -> [Point2] -> Bool
polysIntersect (a:b:xs) ps = go a (a:b:xs) ps
where
go x' (a':b':xs') ps' = pairPolyIntersect a' b' ps' || go x' (b':xs') ps'
go b' (a':[]) ps' = pairPolyIntersect a' b' ps'
go _ _ _ = False
polysIntersect _ _ = False
pairPolyIntersect :: Point2 -> Point2 -> [Point2] -> Bool
pairPolyIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs')
where
go x a b (c:d:xs)
| isJust $ myIntersectSegSeg a b c d = True
| otherwise = go x a b (d:xs)
go d a b (c:[]) = isJust $ myIntersectSegSeg a b c d
go _ _ _ _ = False
pairPolyIntersect _ _ _ = False
-- | Test whether two polygons intersect or if one is contained in the other.
polysOverlap :: [Point2] -> [Point2] -> Bool
polysOverlap (p:ps) (q:qs) = pointInPolygon p (q:qs)
|| pointInPolygon q (p:ps)
|| polysIntersect (p:ps) (q:qs)
polysOverlap _ _ = False
-- | Test whether any polygons from a first list intersect with any polygons from
-- a second list.
anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
-- split a list into triples, forms triangles from a polygon
polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
@@ -394,10 +351,11 @@ divideLineExact x a b = map ( (a +.+ ) . ( *.* v) ) [0 , x .. d]
d = dist a b
v = normalizeV $ b -.- a
-- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- a digital line between them.
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{-# INLINE digitalLine #-}
--{-# INLINE digitalLine #-}
digitalLine (x1,y1) (x2,y2)
| abs (x1-x2) > abs (y1-y2) =
[ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
@@ -421,8 +379,9 @@ digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
miny = min b d
-- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int]
{-# INLINE intervalList #-}
intervalList x y
| y >= x = [x .. y]
| y > x = [x .. y]
| otherwise = reverse [y..x]
-- | Create points on the circumference of a circle with maximal distance
-- between them.
src/Geometry/ConvexPoly.hs
+2 -2
View File
@@ -57,7 +57,7 @@ polyPointsIntersect :: [Point2] -> [Point2] -> Bool
polyPointsIntersect (a:b:xs) ps = go a (a:b:xs) ps
where
go x' (a':b':xs') ps' = pairPolyPointsIntersect a' b' ps' || go x' (b':xs') ps'
go b' (a':[]) ps' = pairPolyPointsIntersect a' b' ps'
go b' [a'] ps' = pairPolyPointsIntersect a' b' ps'
go _ _ _ = False
polyPointsIntersect _ _ = False
@@ -67,7 +67,7 @@ pairPolyPointsIntersect a' b' (c':d':xs') = go c' a' b' (c':d':xs')
go x a b (c:d:xs)
| isJust $ myIntersectSegSeg a b c d = True
| otherwise = go x a b (d:xs)
go d a b (c:[]) = isJust $ myIntersectSegSeg a b c d
go d a b [c] = isJust $ myIntersectSegSeg a b c d
go _ _ _ _ = False
pairPolyPointsIntersect _ _ _ = False
src/Geometry/Intersect.hs
+3 -3
View File
@@ -18,9 +18,9 @@ intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
-- | If two segments intersect, return 'Just' that point.
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegSeg' #-}
intersectSegSeg' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
intersectSegSeg :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegSeg #-}
intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing
| den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
= Nothing
src/Geometry/Zone.hs
+149
View File
@@ -0,0 +1,149 @@
{-# LANGUAGE TupleSections #-}
module Geometry.Zone
( ddaExt
)
where
import Geometry.Data
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
foldl2'
:: (b -> a -> a -> b)
-> b
-> [a]
-> b
foldl2' f s (t:ts) = fst $ foldl' g (s, t) ts
where
g (r,x) y = (f r x y,y)
foldl2' _ s _ = s
sortArguments
:: Ord a
=> (a -> a -> b)
-> a -> a -> b
sortArguments f x y
| x < y = f x y
| otherwise = f y x
sortArgumentsReverse
:: Ord a
=> (a -> a -> [b])
-> a -> a -> [b]
sortArgumentsReverse f x y
| x < y = f x y
| otherwise = reverse $ f y x
intervalBounds
:: Float -- ^ interval threshold
-> Float -- ^ First endpoint
-> Float -- ^ Second endpoint
-> [Float]
intervalBounds = sortArgumentsReverse . f
where
f r a b
| x > b = [a]
| otherwise = (a : [x,x+r..b])
where
x = floorTo r a + r
floorTo :: Float -> Float -> Float
floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int))
ceilingTo :: Float -> Float -> Float
ceilingTo r x = r * (fromIntegral ((ceiling $ x / r) :: Int))
divTo :: Float -> Float -> Int
{-# INLINE divTo #-}
divTo s = floor . (/s)
flipV :: Point2 -> Point2
{-# INLINE flipV #-}
flipV (V2 a b) = V2 b a
applyInverted
:: (Point2 -> Point2 -> [Point2])
-> Point2 -> Point2 -> [Point2]
applyInverted f sp@(V2 sx sy) ep@(V2 ex ey)
| abs (sx-ex) > abs (sy-ey) = f sp ep
| otherwise = map flipV $ f (flipV sp) (flipV ep)
sizeZoneOfPoint' :: Float -> Point2 -> V2 Int
sizeZoneOfPoint' s = fmap (divTo s)
increasingInterval :: Int -> Int -> [Int]
increasingInterval x y
| y > x = [x .. y]
| otherwise = [y .. x]
-- | Determines which horizontal and vertical lines on a grid are crossed by a
-- line. For each adds the x-y index of the square to the right or above the
-- crossed grid line. Also adds the index of the square containing the start
-- point.
ddaExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
ddaExt s sp@(V2 sx sy) ep@(V2 ex ey)
| x1 <= x2 = addys . IM.fromDistinctAscList $ zip [x1 .. x2]
$ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
| otherwise = addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1]
$ map (IS.singleton . divTo s) [x2y,x2y+ydx..]
where
x1 = divTo s sx
x2 = divTo s ex
x1y = fx' sp ep $ s * (fromIntegral x1)
x2y = fx' sp ep $ s * (fromIntegral x2)
ydx = s * ydx' sp ep
addys m = add2s m ypairs
y1 = divTo s sy
y2 = divTo s ey
y1x = fy' sp ep $ s * (fromIntegral y1)
y2x = fy' sp ep $ s * (fromIntegral y2)
xdy = s * xdy' sp ep
ypairs
| y1 <= y2 = zip (map (divTo s) [y1x,y1x+xdy..])
[y1 .. y2]
| otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
[y2-1 .. y1-1]
ydx' :: Point2 -> Point2 -> Float
{-# INLINE ydx' #-}
ydx' (V2 sx sy) (V2 ex ey)
| sx == ex = 0
| otherwise = (ey - sy) / (ex - sx)
xInt' :: Float -> Point2 -> Point2 -> Float
xInt' s (V2 sx _) (V2 ex _)
| ex > sx = ceilingTo s sx
| otherwise = floorTo s sx
fx' :: Point2 -> Point2 -> Float -> Float
fx' sp@(V2 sx sy) ep@(V2 _ ey) x
| sy == ey = sy
| otherwise = sy + ydx' sp ep * (x - sx)
xdy' :: Point2 -> Point2 -> Float
xdy' (V2 sx sy) (V2 ex ey)
| sy == ey = 0
| otherwise = (ex - sx) / (ey - sy)
yInt' :: Float -> Point2 -> Point2 -> Float
yInt' s (V2 _ sy) (V2 _ ey)
| ey > sy = ceilingTo s sy
| otherwise = floorTo s sy
fy' :: Point2 -> Point2 -> Float -> Float
fy' sp@(V2 sx sy) ep@(V2 ex _) y
| sx == ex = sx
| otherwise = sx + xdy' sp ep * (y - sy)
add2s :: IM.IntMap IS.IntSet -> [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE add2s #-}
add2s imis = foldl'
(\m (k,x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
imis
addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet
{-# INLINE addV2s #-}
addV2s imis = foldl'
(\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
imis
pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet
pairsToIntMapSet = foldl'
(\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
IM.empty