diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index f78112308..7c14de6b9 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 24e33a9f3..9af853f03 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -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 diff --git a/src/Dodge/Base/Zone.hs b/src/Dodge/Base/Zone.hs index 274902b34..cc7d7f189 100644 --- a/src/Dodge/Base/Zone.hs +++ b/src/Dodge/Base/Zone.hs @@ -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 diff --git a/src/Dodge/LevelGen/Pathing.hs b/src/Dodge/LevelGen/Pathing.hs index 0c1599841..5678c65b9 100644 --- a/src/Dodge/LevelGen/Pathing.hs +++ b/src/Dodge/LevelGen/Pathing.hs @@ -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' diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 48ec56318..8d5357b08 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -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] diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index de8d62a5b..08cc71796 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 6cedcb244..4de71152a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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)) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index a0a0d4e68..eac14547c 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -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) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 49748120b..db2d0ff57 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -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 diff --git a/src/Geometry.hs b/src/Geometry.hs index c884c8869..a2e87a6cb 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -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. diff --git a/src/Geometry/ConvexPoly.hs b/src/Geometry/ConvexPoly.hs index 88bd4238e..0a6269dfa 100644 --- a/src/Geometry/ConvexPoly.hs +++ b/src/Geometry/ConvexPoly.hs @@ -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 diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 84a3ab19d..278309ae4 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -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 diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs new file mode 100644 index 000000000..72d04b725 --- /dev/null +++ b/src/Geometry/Zone.hs @@ -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