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

Start using streaming as the way to consume foldable objects

Browse Source
This commit is contained in:
justin
2022-06-24 09:27:29 +01:00
parent 89dd8502ad
commit 86b1c2581b
6 changed files with 58 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+12 -6
View File
@@ -19,10 +19,11 @@ module Dodge.Base.Collide
, collideCircWalls
-- , collideCircWalls'
, circOnSomeWall
-- , collidePointWalls
, collidePointWalls
, collidePointWallsNorm
, collidePointWalls'
, collidePointWallsFilt'
, collidePointWallsL
, collidePointWallsFilt
, overlapCircWallsReturnWall
, collideCircCrsPoint
, collideCircCreatures
@@ -370,15 +371,20 @@ collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine
where
findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
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)
collidePointWallsFilt' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
{-# INLINE collidePointWallsFilt' #-}
collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t
collidePointWallsL :: Point2 -> Point2 -> L.Fold Wall Point2
collidePointWallsL p1 p2 = L.Fold findPoint p2 id
where
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p) . _wlLine
collidePointWallsFilt :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
{-# INLINE collidePointWallsFilt #-}
collidePointWallsFilt t p1 p2 = collidePointWalls' p1 p2 . IM.filter t
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
src/Dodge/Update/Camera.hs
+5 -2
View File
@@ -27,7 +27,8 @@ import qualified Data.IntMap.Strict as IM
import qualified SDL
--import Data.Monoid
--import Data.Semigroup
--import qualified Control.Foldl as L
import qualified Control.Foldl as L
import qualified Streaming.Prelude as S
{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
update where your avatar's view is from. -}
updateCamera :: Configuration -> World -> World
@@ -213,7 +214,9 @@ farWallDistDirection p w = foldl' (flip (m . f)) (0,0,0,0) vps
where
--f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p
f q = g $ rotateV (negate $ _cameraRot w)
$ collidePointWallsFilt' wlIsOpaque p q (wallsAlongLine p q w) -.- p
-- $ collidePointWallsFilt wlIsOpaque p q (wallsAlongLine p q w) -.- p
-- $ L.purely S.fold_ (collidePointWallsL p q) (wallsAlongLineStream p q w) -.- p
$ runIdentity (L.purely S.fold_ (collidePointWallsL p q) (wallsAlongLineStream p q w)) -.- p
g (V2 x y) = (y, negate y, x, negate x)
m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w')
vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs
src/Dodge/WorldEvent/Explosion.hs
+2 -2
View File
@@ -31,7 +31,7 @@ makePoisonExplosionAt
-> World
makePoisonExplosionAt p w
= soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing
$ foldr (makeGasCloud p) w
$ foldl' (flip $ makeGasCloud p) w
$ replicateM 25 (randInCirc 2) & evalState $ _randGen w
-- just change the number after replicateM to get more or less clouds
-- suggested change: use random positions, offset from p, rather than velocities
@@ -89,7 +89,7 @@ makeExplosionAt p w = w
times = randomRs (15,20) $ _randGen w
mF q z v size time = makeFlamelet q z v Nothing size time
newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
addFlames w' = foldr ($) w' newFs
addFlames w' = foldl' (flip ($)) w' newFs
--pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls
pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls
wls = wallsNearPoint p w
src/Dodge/WorldEvent/SpawnParticle.hs
+6 -7
View File
@@ -23,6 +23,7 @@ import Geometry
import qualified IntMapHelp as IM
import LensHelp
import Data.Foldable
import Data.Tuple
aFlameParticle
:: Int -- ^ Timer
@@ -82,7 +83,7 @@ moveFlame rotd w pt
| otherwise = case thingsHitExceptCr (_ptCrIgnore pt) sp ep w of
((_,Left _):_) -> (doSound $ dodamage w , mvPt' 0.7)
((p,Right wl):_) -> (doSound $ dodamage w , rfl wl p)
_ -> (ptFlicker pt . damwls $ doSound damcrs , mvPt' 0.98)
_ -> (ptFlicker pt $ doSound $ dodamage w , mvPt' 0.98)
where
time = _ptTimer pt
doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2)
@@ -95,14 +96,11 @@ moveFlame rotd w pt
, _ptCrIgnore = Nothing
, _ptVel = speed *.* vel }
dodamage = damageInArea closeCrs closeWls pt
damwls w' = foldr (\wl -> fst . hiteff [(ep,Right wl)]) w' $ IM.filter closeWls $ wallsNearPoint ep w
damcrs = foldr (\cr -> fst . hiteff [(ep,Left cr)]) w $ IM.filter closeCrs $ _creatures w
closeWls wl = uncurry circOnSeg (_wlLine wl) ep 5
closeCrs cr = dist ep (_crPos cr)
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi )
hiteff = _ptHitEff pt pt
rfl wl p = Just $ pt
{ _ptTimer = time - 1
, _ptPos = pOut p
@@ -203,11 +201,12 @@ damageInRadius size pt = damageInArea isClose closeWls pt
isClose cr = dist p (_crPos cr) < _crRad cr + size
damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World
{-# INLINE damageInArea #-}
damageInArea crt wlt pt w = damwls damcrs
where
p = _ptPos pt
damcrs = foldr (\cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
damwls w' = foldr (\wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
damwls w' = foldl' (flip $ \wl -> fst . hiteff [(p,Right wl)]) w' $ IM.filter wlt $ wallsNearPoint p w
hiteff = _ptHitEff pt pt
-- | At writing the radius is half the size of the effect area
@@ -234,7 +233,7 @@ makeGasCloud pos vel w = w
(col, g) = runState (takeOne [green,yellow]) $ _randGen w
{- Attach poison cloud damage to creatures near cloud. -}
cloudPoisonDamage :: Cloud -> World -> World
cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
cloudPoisonDamage c w = w & creatures %~ flip (foldl' (flip $ IM.adjust doDam)) damagedCrs
where
damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint clpos w
f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
src/Dodge/Zone.hs
+22
View File
@@ -3,6 +3,7 @@ module Dodge.Zone
, zoneOfLineIntMap
, wallsNearPoint
, wallsAlongLine
, wallsAlongLineStream
, zoneSize
, zoneOfPoint
, wallsAlongCirc
@@ -30,10 +31,14 @@ import Geometry
import Geometry.Zone
import qualified FoldlHelp as L
import qualified Streaming.Prelude as S
import Streaming
import Data.Maybe
import Data.List
import Data.IntMap.Merge.Strict
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Control.Lens
--flattenZones :: Zone (IM.IntMap a) -> IM.IntMap a
--flattenZones = flattenIMIMIM . _znObjects
@@ -79,6 +84,9 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
--f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
zoneOfLineStream :: Monad m => Point2 -> Point2 -> Stream (Of (Int,Int)) m ()
zoneOfLineStream = ddaSqStream zoneSize
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
--{-# INLINE zoneOfLineIntMap #-}
--zoneOfLineIntMap = ddaExt zoneSize
@@ -168,6 +176,20 @@ wallsAlongLine a b w =
Just val -> val
_ -> IM.empty
restrictIMIM :: IM.IntMap (IM.IntMap a) -> IM.IntMap IS.IntSet -> IM.IntMap (IM.IntMap a)
restrictIMIM = merge dropMissing dropMissing (zipWithMatched $ const IM.restrictKeys)
wallsAlongLineStream :: Monad m => Point2 -> Point2 -> World -> Stream (Of Wall) m ()
wallsAlongLineStream sp ep w = flip S.for S.each $ S.mapMaybe f $ zoneOfLineStream sp ep
where
f (i,j) = w ^? wallsZone . znObjects . ix i . ix j
--wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
----{-# INLINE wallsAlongLine #-}
--wallsAlongLine a b w = _walls w
-- where
-- kps = zoneOfLineIntMap a b
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wallsAlongCirc p r w = IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r]
where
src/Geometry/Zone.hs
+11
View File
@@ -3,9 +3,12 @@ module Geometry.Zone
( ddaExt
, ddaExt'
, ddaSq
, ddaSqStream
) where
import Geometry.Data
import Streaming
import qualified Streaming.Prelude as S
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
@@ -89,6 +92,14 @@ ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs
xs = IS.fromDistinctAscList [minx-1..maxx+1]
ys = IS.fromDistinctAscList [miny-1..maxy+1]
ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (Int,Int)) m ()
ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [(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