Inline functions in Dodge.Zone
This commit is contained in:
+12
-89
@@ -18,20 +18,11 @@ module Dodge.Base.Collide
|
||||
, bouncePoint
|
||||
, sortStreamOn
|
||||
, minStreamOn
|
||||
-- , wallsOnCirc
|
||||
-- , wallsOnCirc'
|
||||
, wallsOnLineHit
|
||||
, collideCircWallsStream
|
||||
, collideCircWalls
|
||||
, circOnSomeWall
|
||||
, collidePointWallsNorm
|
||||
, collidePointWalls'
|
||||
, overlapCircWalls
|
||||
, overlapCircWallsClosest
|
||||
, collideCircCrsPoint
|
||||
, collideCircCreatures
|
||||
, collidePointCreatures
|
||||
, collidePointAnyWallsReflect
|
||||
, crsNearPoint
|
||||
, crsOnLine
|
||||
, crsOnThickLine
|
||||
@@ -58,12 +49,12 @@ import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
--import qualified FoldlHelp as L
|
||||
import Data.Monoid
|
||||
--import Data.Monoid
|
||||
import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
collidePoint :: Point2 -> Point2
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> StreamOf Wall
|
||||
-> (Point2, Maybe Wall)
|
||||
{-# INLINE collidePoint #-}
|
||||
collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
||||
@@ -77,7 +68,7 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
|
||||
)
|
||||
|
||||
bounceBall :: Float -> Point2 -> Point2 -> Float
|
||||
-> Stream (Of Wall) Identity ()
|
||||
-> StreamOf Wall
|
||||
-> Maybe (Point2,Point2)
|
||||
bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r
|
||||
|
||||
@@ -86,7 +77,7 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
|
||||
|
||||
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
-- whether this is actually faster
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> Stream (Of Wall) Identity () -> Bool
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
|
||||
collidePointTestFilter t sp ep = runIdentity
|
||||
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. S.filter t
|
||||
@@ -96,55 +87,31 @@ collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
||||
. S.filter t
|
||||
. wlsNearSeg sp ep
|
||||
|
||||
overlapSegWalls :: Point2 -> Point2 -> Stream (Of Wall) Identity ()
|
||||
-> Stream (Of (Point2,Wall)) Identity ()
|
||||
overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
|
||||
-> StreamOf (Point2,Wall)
|
||||
overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
visibleWalls :: Point2 -> Point2 -> World -> Stream (Of (Point2,Wall)) Identity ()
|
||||
visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
|
||||
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
|
||||
( S.span (not . wlIsOpaque . snd)
|
||||
. sortStreamOn (dist sp . fst)
|
||||
. overlapSegWalls sp ep
|
||||
. wlsNearSeg sp ep )
|
||||
|
||||
allVisibleWalls :: World -> Stream (Of (Point2,Wall)) Identity ()
|
||||
allVisibleWalls :: World -> StreamOf (Point2,Wall)
|
||||
allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
||||
where
|
||||
vPos = _cameraViewFrom w
|
||||
|
||||
|
||||
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
||||
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
||||
where
|
||||
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
|
||||
|
||||
-- | Looks for any collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
-- note that in this version the circle can overlap the wall
|
||||
collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collidePointAnyWallsReflect p1 p2
|
||||
= getFirst
|
||||
. foldMap (First . findPoint . _wlLine)
|
||||
where
|
||||
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
|
||||
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
Nothing -> Nothing
|
||||
|
||||
collidePointWalls' :: (Foldable t, Functor t) => Point2 -> Point2 -> t Wall -> Point2
|
||||
{-# INLINE collidePointWalls' #-}
|
||||
collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
|
||||
where
|
||||
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
-> Stream (Of (Point2,Wall)) Identity ()
|
||||
overlapCircWalls :: Point2 -> Float -> StreamOf Wall
|
||||
-> StreamOf (Point2,Wall)
|
||||
overlapCircWalls p r = S.mapMaybe dointersect
|
||||
where
|
||||
dointersect wl = f (_wlLine wl) <&> (,wl)
|
||||
f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) a b
|
||||
|
||||
-- note that this does not push the circle away from the wall at all
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> Stream (Of Wall) Identity ()
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
|
||||
-> (Point2, Maybe Wall)
|
||||
collideCircWallsStream sp ep rad = runIdentity
|
||||
. S.fold_ findPoint (ep, Nothing) id
|
||||
@@ -159,54 +126,10 @@ collideCircWallsStream sp ep rad = runIdentity
|
||||
where
|
||||
f = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||
|
||||
overlapCircWallsClosest :: Point2 -> Float -> Stream (Of Wall) Identity () -> Maybe (Point2,Wall)
|
||||
overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
||||
overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
||||
. overlapCircWalls p r
|
||||
|
||||
-- | Looks for first collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collideCircWalls p1 p2 rad
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
. IM.mapMaybe
|
||||
(( \(x:y:_) -> fmap
|
||||
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
. (+.+ normalizeV (vNormal (x -.- y)))
|
||||
)
|
||||
(intersectSegSeg p1 p2 x y)
|
||||
)
|
||||
. shiftByRad . _wlLine
|
||||
)
|
||||
where
|
||||
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||
[a +.+ rad *.* normalizeV (a -.-b)
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
]
|
||||
-- this shifts the wall out, and for outer corners extends the wall
|
||||
-- not sure what this does for inner corners, hopefully won't cause a problem
|
||||
-- the alternative would be to separately bounce off corner points...
|
||||
-- unfortunately, doesn't allow for collisions when the circle spawns on the
|
||||
-- wall
|
||||
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and normal of wall.
|
||||
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collidePointWallsNorm p1 p2 ws
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
|
||||
. _wlLine) ws
|
||||
-- | Returns the first creature, if any, that a point intersects with.
|
||||
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
|
||||
collidePointCreatures p1 p2 = fmap fst
|
||||
. safeMinimumOn snd
|
||||
. IM.toList
|
||||
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
|
||||
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
|
||||
--fixed amount, thus collides a moving circle with creaures.
|
||||
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
|
||||
collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
|
||||
|
||||
-- | Returns the first creature id, if any, that a point intersects with, gives point
|
||||
--in creature on line.
|
||||
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
|
||||
|
||||
@@ -360,7 +360,6 @@ data Creature = Creature
|
||||
, _crMvDir :: Float
|
||||
, _crTwist :: Float
|
||||
, _crID :: Int
|
||||
--, _crPict :: Creature -> Configuration -> World -> SPic
|
||||
, _crPict :: Creature -> SPic
|
||||
, _crSkin :: CreatureSkin
|
||||
, _crUpdate :: Creature -> World -> World
|
||||
|
||||
@@ -1,66 +0,0 @@
|
||||
module Dodge.Debug where
|
||||
import Dodge.Data
|
||||
import Dodge.Zone
|
||||
import Dodge.Base
|
||||
import Geometry.Zone
|
||||
import Geometry.Data
|
||||
import Geometry
|
||||
import Picture
|
||||
import qualified IntMapHelp as IM
|
||||
import qualified Data.IntSet as IS
|
||||
|
||||
import qualified Streaming.Prelude as S
|
||||
import Control.Lens
|
||||
|
||||
drawCircleAtFor :: Point2 -> Int -> World -> World
|
||||
drawCircleAtFor p t = drawCircleAtForCol p t white
|
||||
|
||||
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
|
||||
drawCircleAtForCol p t col w = w & props %~
|
||||
IM.insert k Projectile
|
||||
{ _prPos = p
|
||||
, _pjStartPos = p
|
||||
, _pjVel = V2 0 0
|
||||
, _prDraw = \_ -> (,) mempty $ setDepth 20 $ uncurryV translate p $ color col $ circleSolid 20
|
||||
, _pjID = k
|
||||
, _pjUpdate = \_ -> pjTimerF t k
|
||||
}
|
||||
where
|
||||
k = IM.newKey $ _props w
|
||||
|
||||
drawLineForCol :: [Point2] -> Int -> Color -> World -> World
|
||||
drawLineForCol ps t col w = w & props %~
|
||||
IM.insert k Projectile
|
||||
{ _prPos = head ps
|
||||
, _pjStartPos = head ps
|
||||
, _pjVel = V2 0 0
|
||||
, _prDraw = \_ -> (,) mempty $ setDepth 20 $ color col $ thickLine 5 ps
|
||||
, _pjID = k
|
||||
, _pjUpdate = \_ -> pjTimerF t k
|
||||
}
|
||||
where
|
||||
k = IM.newKey $ _props w
|
||||
|
||||
pjTimerF :: Int -> Int -> World -> World
|
||||
pjTimerF 0 i = props %~ IM.delete i
|
||||
pjTimerF time i = props . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
|
||||
|
||||
drawDDA :: IM.IntMap IS.IntSet -> Picture
|
||||
drawDDA = setLayer BloomLayer . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
|
||||
where
|
||||
f pic x' ys' = concatMapPic (\y -> polygon (reverse $ rectNSWE (y+50) y x (x+50))) ys `appendPic` pic
|
||||
where
|
||||
x = 50 * fromIntegral x'
|
||||
ys = map ((50 *) . fromIntegral) $ IS.toList ys'
|
||||
|
||||
debugWallZoningPic :: World -> Picture
|
||||
debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic
|
||||
where
|
||||
--wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
|
||||
wallsPic = setDepth 25 . color yellow . runIdentity . S.foldMap_ (drawTheWall . _wlLine)
|
||||
$ wlsNearSeg sp ep w
|
||||
drawTheWall (a,b) = thickLine 20 [a,b]
|
||||
zonesPic = setDepth 20 $ drawDDA zones
|
||||
zones = ddaExt wlZoneSize sp ep
|
||||
sp = _crPos $ you w
|
||||
ep = mouseWorldPos w
|
||||
@@ -1,3 +0,0 @@
|
||||
module Dodge.Debug.Flag
|
||||
where
|
||||
|
||||
+1
-1
@@ -51,7 +51,7 @@ generateLevelFromRoomList gr' w = initWallZoning
|
||||
& peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
|
||||
(labEdges (_pgGraph path)))
|
||||
where
|
||||
path = pairsToGraph'' pairPath
|
||||
path = pairsToGraph pairPath
|
||||
pairPath = foldMap _rmPath rs
|
||||
rs = map doRoomShift $ IM.elems rs'
|
||||
rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
|
||||
|
||||
+9
-27
@@ -4,7 +4,6 @@ module Dodge.Path
|
||||
, makePathBetween
|
||||
, makePathBetweenPs
|
||||
, pairsToGraph
|
||||
, pairsToGraph''
|
||||
, walkableNodeNear
|
||||
, nodesNearL
|
||||
, getNodePos
|
||||
@@ -106,12 +105,11 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
|
||||
-- _ -> return $ Just $ ns !! i
|
||||
--
|
||||
|
||||
pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
|
||||
pairsToGraph'' pairset = PathGraph gr' nodemap ncount edgemap
|
||||
pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
|
||||
pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
|
||||
where
|
||||
(gr,nodemap,ncount) = insertNodes pairset
|
||||
(gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
|
||||
|
||||
|
||||
toPathEdge :: Point2 -> Point2 -> PathEdge
|
||||
toPathEdge sp' ep = PathEdge sp' ep mempty
|
||||
@@ -137,27 +135,15 @@ insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.emp
|
||||
Just _ -> (gr,nm,i)
|
||||
where
|
||||
j = i + 1
|
||||
--pairsToGraph' :: (Ord a) => (a -> a -> b) -> Set (a,a) -> (Gr a b, Map a Int, Map (V2 a) Int2)
|
||||
--pairsToGraph' f pairset = ngr'
|
||||
|
||||
--pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
|
||||
--pairsToGraph f pairs = undir
|
||||
-- $ run_ Data.Graph.Inductive.empty
|
||||
-- $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
|
||||
-- where
|
||||
-- nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
|
||||
-- getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
|
||||
-- ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
|
||||
-- ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
|
||||
-- insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
|
||||
-- insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
|
||||
-- fstsnd (a,b,_) = (a,b)
|
||||
-- nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
|
||||
-- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
|
||||
|
||||
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
|
||||
pairsToGraph f pairs = undir
|
||||
$ run_ Data.Graph.Inductive.empty
|
||||
$ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
|
||||
where
|
||||
nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
|
||||
pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
|
||||
|
||||
--findEdgesCrossing :: Point2 -> Point2 -> Gr Point2 PathEdge ->
|
||||
--
|
||||
addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2
|
||||
-> Gr Point2 PathEdge
|
||||
-> Gr Point2 PathEdge
|
||||
@@ -172,7 +158,3 @@ addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
|
||||
-> World
|
||||
-> World
|
||||
addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
|
||||
|
||||
-- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
|
||||
-- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
|
||||
-- newGraph = pairsToGraph'' dist pg'
|
||||
|
||||
+17
-21
@@ -11,8 +11,6 @@ module Dodge.Zone
|
||||
, crsNearSeg
|
||||
, wlsInsideCirc
|
||||
, crsInsideCirc
|
||||
, lookLookups
|
||||
, zoneNearPointIP
|
||||
, clZoneOfPoint
|
||||
, crZoneOfPoint
|
||||
, wlZoneOfPoint
|
||||
@@ -32,31 +30,25 @@ import Geometry.Zone
|
||||
import qualified Streaming.Prelude as S
|
||||
import StreamingHelp
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
extractFromZone :: Zoning t a -> Int2 -> Maybe (t a)
|
||||
{-# INLINE extractFromZone #-}
|
||||
extractFromZone zn (V2 x y) = zn ^? znObjects . ix x . ix y
|
||||
|
||||
streamFromZone :: Foldable t => Zoning t a -> StreamOf Int2 -> StreamOf a
|
||||
{-# INLINE streamFromZone #-}
|
||||
streamFromZone zn = S.concat . S.mapMaybe (extractFromZone zn)
|
||||
|
||||
|
||||
zoneNearPointIP :: Point2 -> [(Int,Int)]
|
||||
zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
|
||||
where
|
||||
V2 x y = wlZoneOfPoint p
|
||||
|
||||
zoneAroundPoint :: Float -> Point2 -> StreamOf Int2
|
||||
{-# INLINE zoneAroundPoint #-}
|
||||
zoneAroundPoint s p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
|
||||
where
|
||||
V2 x y = zoneOfPoint s p
|
||||
|
||||
--zoneOfBounds :: Float -> (Float,Float,Float,Float) -> Stream (Of Int2) Identity ()
|
||||
--zoneOfBounds x (n,s,e,w) = ddaSqStream x (V2 n e) (V2 s w)
|
||||
|
||||
-- this is ugly, might be better with zoneOfBounds or somesuch
|
||||
zoneOfSight :: Float -> World -> Stream (Of (V2 Int)) Identity () --(Int,Int)]
|
||||
{-# INLINE zoneOfSight #-}
|
||||
zoneOfSight x' w = S.each
|
||||
[V2 a b
|
||||
| a <- [minimum xs .. maximum xs]
|
||||
@@ -69,15 +61,6 @@ zoneOfSight x' w = S.each
|
||||
where
|
||||
f = floor . (/ s)
|
||||
|
||||
lookLookup :: Int -> Int -> IM.IntMap (IM.IntMap a) -> Maybe a
|
||||
lookLookup i j z = case IM.lookup i z of
|
||||
Just z' -> IM.lookup j z'
|
||||
Nothing -> Nothing
|
||||
|
||||
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
|
||||
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
|
||||
|
||||
|
||||
nearPoint :: (Foldable t,Monoid (t a))
|
||||
=> (World -> Zoning t a) -> Point2 -> World -> StreamOf a
|
||||
{-# INLINE nearPoint #-}
|
||||
@@ -86,46 +69,59 @@ nearPoint f p w = S.each . fromMaybe mempty $ extractFromZone zn (zoneOfPoint (_
|
||||
zn = f w
|
||||
|
||||
aroundPoint :: Foldable t => (World -> Zoning t a) -> Point2 -> World -> StreamOf a
|
||||
{-# INLINE aroundPoint #-}
|
||||
aroundPoint f p w = streamFromZone zn $ zoneAroundPoint (_znSize zn) p
|
||||
where
|
||||
zn = f w
|
||||
|
||||
clsNearPoint :: Point2 -> World -> StreamOf Cloud
|
||||
{-# INLINE clsNearPoint #-}
|
||||
clsNearPoint = nearPoint _clZoning
|
||||
|
||||
wlsNearPoint :: Point2 -> World -> StreamOf Wall
|
||||
{-# INLINE wlsNearPoint #-}
|
||||
wlsNearPoint = nearPoint _wlZoning
|
||||
|
||||
crsNearPoint :: Point2 -> World -> StreamOf Creature
|
||||
{-# INLINE crsNearPoint #-}
|
||||
crsNearPoint = nearPoint _crZoning
|
||||
|
||||
nearSeg :: Foldable t => (World -> Zoning t a) -> Point2 -> Point2 -> World -> StreamOf a
|
||||
{-# INLINE nearSeg #-}
|
||||
nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
|
||||
where
|
||||
zn = f w
|
||||
|
||||
wlsNearSeg :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
|
||||
{-# INLINE wlsNearSeg #-}
|
||||
wlsNearSeg = nearSeg _wlZoning
|
||||
|
||||
crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
|
||||
{-# INLINE crsNearSeg #-}
|
||||
crsNearSeg = nearSeg _crZoning
|
||||
|
||||
insideCirc :: Foldable t => (World -> Zoning t a) -> Point2 -> Float -> World -> StreamOf a
|
||||
{-# INLINE insideCirc #-}
|
||||
insideCirc f p r w = streamFromZone zn $ zoneInsideCirc (_znSize zn) p r
|
||||
where
|
||||
zn = f w
|
||||
|
||||
wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
|
||||
{-# INLINE wlsInsideCirc #-}
|
||||
wlsInsideCirc = insideCirc _wlZoning
|
||||
|
||||
crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
|
||||
{-# INLINE crsInsideCirc #-}
|
||||
crsInsideCirc = insideCirc _crZoning
|
||||
|
||||
wlZoneOfPoint :: Point2 -> Int2
|
||||
{-# INLINE wlZoneOfPoint #-}
|
||||
wlZoneOfPoint = zoneOfPoint wlZoneSize
|
||||
|
||||
clZoneOfPoint :: Point2 -> Int2
|
||||
{-# INLINE clZoneOfPoint #-}
|
||||
clZoneOfPoint = zoneOfPoint clZoneSize
|
||||
|
||||
crZoneOfPoint :: Point2 -> Int2
|
||||
{-# INLINE crZoneOfPoint #-}
|
||||
crZoneOfPoint = zoneOfPoint crZoneSize
|
||||
|
||||
+10
-198
@@ -1,11 +1,6 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Geometry.Zone
|
||||
( ddaExt
|
||||
, ddaExt'
|
||||
, ddaSq
|
||||
, ddaSqStream
|
||||
, ddaStream
|
||||
, ddaStreamX
|
||||
( ddaStreamX
|
||||
, ddaStreamY
|
||||
, xIntercepts
|
||||
, yIntercepts
|
||||
@@ -19,60 +14,13 @@ import Geometry.Vector
|
||||
|
||||
import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
import Data.Foldable
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.IntSet as IS
|
||||
--import Control.Monad
|
||||
|
||||
--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)
|
||||
|
||||
modTo :: Float -> Float -> Float
|
||||
{-# INLINE modTo #-}
|
||||
modTo s x = x - s * fromIntegral (divTo s x)
|
||||
|
||||
--remTo :: Float -> Float -> Float
|
||||
@@ -82,75 +30,13 @@ modTo s x = x - s * fromIntegral (divTo s x)
|
||||
--{-# INLINE quotTo #-}
|
||||
--quotTo s = truncate . (/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)
|
||||
|
||||
zoneOfPoint :: Float -> Point2 -> V2 Int
|
||||
{-# INLINE zoneOfPoint #-}
|
||||
zoneOfPoint s = fmap (divTo s)
|
||||
|
||||
--increasingInterval :: Int -> Int -> [Int]
|
||||
--increasingInterval x y
|
||||
-- | y > x = [x .. y]
|
||||
-- | otherwise = [y .. x]
|
||||
|
||||
-- | Determines a "square" zone of points for a line
|
||||
ddaSq :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
|
||||
ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs
|
||||
where
|
||||
maxMin a b | a >= b = (a,b)
|
||||
| otherwise = (b,a)
|
||||
(maxx,minx) = maxMin (divTo s sx) (divTo s ex)
|
||||
(maxy,miny) = maxMin (divTo s sy) (divTo s ey)
|
||||
xs = IS.fromDistinctAscList [minx-1..maxx+1]
|
||||
ys = IS.fromDistinctAscList [miny-1..maxy+1]
|
||||
|
||||
--ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (V2 Int)) m ()
|
||||
--ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [V2 x y | x <- [minx..maxx], y <- [miny..maxy]]
|
||||
-- where
|
||||
-- maxMin a b | a >= b = (a,b)
|
||||
-- | otherwise = (b,a)
|
||||
-- (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
|
||||
-- (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
|
||||
|
||||
-- | 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 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2]
|
||||
$ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
|
||||
| otherwise = ddaExt' s ep sp
|
||||
where
|
||||
addsp im = let V2 x y = zoneOfPoint s sp
|
||||
in insertXY im (x,y)
|
||||
x1 = divTo s sx
|
||||
x2 = divTo s ex
|
||||
x1y = fx' sp ep $ s * fromIntegral x1
|
||||
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]
|
||||
ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
|
||||
zoneOfRect :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
{-# INLINE zoneOfRect #-}
|
||||
zoneOfRect s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
|
||||
where
|
||||
V2 sx sy = zoneOfPoint s sp
|
||||
V2 ex ey = zoneOfPoint s ep
|
||||
@@ -161,13 +47,12 @@ makeInterval x y
|
||||
| otherwise = [y-1..x+1]
|
||||
|
||||
zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2
|
||||
zoneInsideCirc x p r = ddaSqStream x (p +.+ V2 r r) (p -.- V2 r r)
|
||||
{-# INLINE zoneInsideCirc #-}
|
||||
zoneInsideCirc x p r = zoneOfRect x (p +.+ V2 r r) (p -.- V2 r r)
|
||||
|
||||
zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
|
||||
zoneOfSeg = ddaStream
|
||||
|
||||
ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
ddaStream s sp ep = S.map (zoneOfPoint s)
|
||||
{-# INLINE zoneOfSeg #-}
|
||||
zoneOfSeg s sp ep = S.map (zoneOfPoint s)
|
||||
$ S.yield sp
|
||||
<> xIntercepts s sp ep
|
||||
<> yIntercepts s sp ep
|
||||
@@ -193,80 +78,7 @@ xIntercepts s (V2 sx sy) (V2 ex ey)
|
||||
| otherwise = s + sx - modTo s sx
|
||||
|
||||
yIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
|
||||
{-# INLINE yIntercepts #-}
|
||||
yIntercepts s sp ep = S.map f $ xIntercepts s (f sp) (f ep)
|
||||
where
|
||||
f (V2 x y) = V2 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.
|
||||
-- Not correct, eg ddaExt 10 (V2 40 50) (V2 0 0)
|
||||
ddaExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
|
||||
ddaExt s sp@(V2 sx sy) ep@(V2 ex ey)
|
||||
| x1 <= x2 = addsp . addys . IM.fromDistinctAscList $ zip [x1 .. x2]
|
||||
$ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
|
||||
| otherwise = addsp . addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1]
|
||||
$ map (IS.singleton . divTo s) [x2y,x2y+ydx..]
|
||||
where
|
||||
addsp im = let V2 x y = zoneOfPoint s sp
|
||||
in insertXY im (x,y)
|
||||
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)
|
||||
fx' :: Point2 -> Point2 -> Float -> Float
|
||||
{-# INLINE fx' #-}
|
||||
fx' sp@(V2 sx sy) ep@(V2 _ ey) x
|
||||
| sy == ey = sy
|
||||
| otherwise = sy + ydx' sp ep * (x - sx)
|
||||
|
||||
xdy' :: Point2 -> Point2 -> Float
|
||||
{-# INLINE xdy' #-}
|
||||
xdy' (V2 sx sy) (V2 ex ey)
|
||||
| sy == ey = 0
|
||||
| otherwise = (ex - sx) / (ey - sy)
|
||||
fy' :: Point2 -> Point2 -> Float -> Float
|
||||
{-# INLINE fy' #-}
|
||||
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 = foldl'
|
||||
(\m (k,x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
|
||||
|
||||
insertXY :: IM.IntMap IS.IntSet -> (Int,Int) -> IM.IntMap IS.IntSet
|
||||
{-# INLINE insertXY #-}
|
||||
insertXY m (k,x) = IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m
|
||||
|
||||
--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
|
||||
|
||||
Reference in New Issue
Block a user