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

Refactor wall zoning, remove streaming

Browse Source
This commit is contained in:
justin
2022-07-23 12:29:29 +01:00
parent 39f4555697
commit 39778f46fb
30 changed files with 396 additions and 163 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+94 -26
View File
@@ -43,7 +43,9 @@ import Dodge.Zone
import Dodge.Zoning import Dodge.Zoning
import Dodge.Base.Wall import Dodge.Base.Wall
import Geometry import Geometry
import FoldableHelp
import Data.List (sortOn)
import Data.Maybe import Data.Maybe
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Control.Lens import Control.Lens
@@ -52,11 +54,19 @@ import StreamingHelp
import qualified Streaming.Prelude as S import qualified Streaming.Prelude as S
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
--collidePoint :: Point2 -> Point2
-- -> StreamOf Wall
-- -> (Point2, Maybe Wall)
--{-# INLINE collidePoint #-}
--collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
-- where
-- findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
collidePoint :: Point2 -> Point2 collidePoint :: Point2 -> Point2
-> StreamOf Wall -> [Wall]
-> (Point2, Maybe Wall) -> (Point2, Maybe Wall)
{-# INLINE collidePoint #-} {-# INLINE collidePoint #-}
collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id collidePoint sp ep = foldl' findPoint (ep, Nothing)
where where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
@@ -94,10 +104,10 @@ doBounce x sp ep (p, mwl) = mwl <&> \wl ->
) )
bounceBall :: Float -> Point2 -> Point2 -> Float bounceBall :: Float -> Point2 -> Point2 -> Float
-> StreamOf Wall -> [Wall]
-> Maybe (Point2,Point2) -> Maybe (Point2,Point2)
{-# INLINE bounceBall #-} {-# INLINE bounceBall #-}
bounceBall x sp ep r = doBounce x sp ep . collideCircWallsStream sp ep r bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
{-# INLINE bouncePoint #-} {-# INLINE bouncePoint #-}
@@ -105,45 +115,93 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
-- this COULD be written in terms of collidePointWallsFilterStream, TODO test -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
-- whether this is actually faster -- whether this is actually faster
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
{-# INLINE collidePointTestFilter #-} {-# INLINE collidePointTestFilter #-}
collidePointTestFilter t sp ep = runIdentity collidePointTestFilter t sp ep
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) = any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. S.filter t . filter t
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
---- whether this is actually faster
--collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
--{-# INLINE collidePointTestFilter #-}
--collidePointTestFilter t sp ep = runIdentity
-- . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
-- . S.filter t
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
{-# INLINE collidePointWallsFilterStream #-} {-# INLINE collidePointWallsFilterStream #-}
collidePointWallsFilterStream t sp ep = collidePoint sp ep collidePointWallsFilterStream t sp ep = collidePoint sp ep
. S.filter t . filter t
. wlsNearSeg sp ep . wlsNearSeg sp ep
overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall --overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
-> StreamOf (Point2,Wall) -- -> StreamOf (Point2,Wall)
--{-# INLINE overlapSegWalls #-}
--overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2,Wall)]
{-# INLINE overlapSegWalls #-} {-# INLINE overlapSegWalls #-}
overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) overlapSegWalls sp ep = mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall) visibleWalls :: Point2 -> Point2 -> World -> [(Point2,Wall)]
{-# INLINE visibleWalls #-} {-# INLINE visibleWalls #-}
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
( S.span (not . wlIsOpaque . snd) . sortOn (dist sp . fst)
. sortStreamOn (dist sp . fst)
. overlapSegWalls sp ep . overlapSegWalls sp ep
. wlsNearSeg sp ep ) . wlsNearSeg sp ep
allVisibleWalls :: World -> StreamOf (Point2,Wall) --visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
--{-# INLINE visibleWalls #-}
--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 -> [(Point2,Wall)]
{-# INLINE allVisibleWalls #-} {-# INLINE allVisibleWalls #-}
allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20
where where
vPos = _cameraViewFrom w vPos = _cameraViewFrom w
--allVisibleWalls :: World -> StreamOf (Point2,Wall)
--{-# INLINE allVisibleWalls #-}
--allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
-- where
-- vPos = _cameraViewFrom w
overlapCircWalls :: Point2 -> Float -> StreamOf Wall --overlapCircWalls :: Point2 -> Float -> StreamOf Wall
-> StreamOf (Point2,Wall) -- -> StreamOf (Point2,Wall)
--{-# INLINE overlapCircWalls #-}
--overlapCircWalls p r = S.mapMaybe dointersect
-- where
-- dointersect wl = f (_wlLine wl) <&> (,wl)
-- f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
overlapCircWalls :: Point2 -> Float -> [Wall]
-> [(Point2,Wall)]
{-# INLINE overlapCircWalls #-} {-# INLINE overlapCircWalls #-}
overlapCircWalls p r = S.mapMaybe dointersect overlapCircWalls p r = mapMaybe dointersect
where where
dointersect wl = f (_wlLine wl) <&> (,wl) dointersect wl = f (_wlLine wl) <&> (,wl)
f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
-- | note that this does not push the circle away from the wall at all
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
{-# INLINE collideCircWalls #-}
collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
. shiftbyrad
. _wlLine $ wl
shiftbyrad (a,b) = bimap f f
(a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
)
where
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
-- | note that this does not push the circle away from the wall at all -- | note that this does not push the circle away from the wall at all
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
-> (Point2, Maybe Wall) -> (Point2, Maybe Wall)
@@ -160,18 +218,28 @@ collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing)
where where
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b)) f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall) overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall)
{-# INLINE overlapCircWallsClosest #-} {-# INLINE overlapCircWallsClosest #-}
overlapCircWallsClosest p r = minStreamOn (dist p . fst) overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
. overlapCircWalls p r . overlapCircWalls p r
--overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
--{-# INLINE overlapCircWallsClosest #-}
--overlapCircWallsClosest p r = minStreamOn (dist p . fst)
-- . overlapCircWalls p r
{- | Test if a circle collides with any wall. {- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -} - Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall :: Point2 -> Float -> World -> Bool
{-# INLINE circOnSomeWall #-} {-# INLINE circOnSomeWall #-}
circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine) circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine)
. wlsNearPoint p . wlsNearPoint p
--circOnSomeWall :: Point2 -> Float -> World -> Bool
--{-# INLINE circOnSomeWall #-}
--circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
-- . wlsNearPoint p
circOnAnyCr :: Point2 -> Float -> World -> Bool circOnAnyCr :: Point2 -> Float -> World -> Bool
{-# INLINE circOnAnyCr #-} {-# INLINE circOnAnyCr #-}
circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
@@ -226,5 +294,5 @@ anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
(w ^? creatures . ix cid) (w ^? creatures . ix cid)
|| bl || bl
hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
-- this should probably be wallsOnLine or something -- this should probably be wallsOnLine or something
src/Dodge/Block.hs
+2 -1
View File
@@ -1,4 +1,5 @@
module Dodge.Block where module Dodge.Block where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Base.Collide import Dodge.Base.Collide
import Dodge.Material.Sound import Dodge.Material.Sound
@@ -65,7 +66,7 @@ maybeClearPaths ps w = foldl' maybeClearPath w ps
maybeClearPath :: World -> (Int,Int,PathEdge) -> World maybeClearPath :: World -> (Int,Int,PathEdge) -> World
maybeClearPath w (x,y,pe) maybeClearPath w (x,y,pe)
| runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
= w = w
| otherwise = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles .~ mempty) . FGL.delEdge (x,y) | otherwise = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles .~ mempty) . FGL.delEdge (x,y)
src/Dodge/Bullet.hs
+9 -8
View File
@@ -2,6 +2,7 @@ module Dodge.Bullet
( updateBullet ( updateBullet
, useAmmoParams , useAmmoParams
) where ) where
import qualified ListHelp as List
import Dodge.EnergyBall import Dodge.EnergyBall
import Dodge.Creature.Test import Dodge.Creature.Test
import Dodge.Data import Dodge.Data
@@ -87,12 +88,12 @@ bulletSpawn bu = case _buSpawn bu of
BulBall TeslaBall -> Just makeStaticBall BulBall TeslaBall -> Just makeStaticBall
hitEffFromBul :: Float -> Bullet hitEffFromBul :: Float -> Bullet
-> StreamOf (Point2, Either Creature Wall) -> [(Point2, Either Creature Wall)]
-> World -> World
-> (World,Maybe Bullet) -> (World,Maybe Bullet)
hitEffFromBul x bu hitstream w = case _buEffect bu of hitEffFromBul x bu hitstream w = case _buEffect bu of
PenetrateBullet -> movePenBullet x bu hitstream w PenetrateBullet -> movePenBullet x bu hitstream w
BounceBullet -> case runIdentity (S.head_ hitstream) of BounceBullet -> case List.safeHead hitstream of
Nothing -> (w, moveBullet x bu) Nothing -> (w, moveBullet x bu)
Just (hp,crwl) -> fromMaybe (expireAndDamage x bu hitstream w) $ do Just (hp,crwl) -> fromMaybe (expireAndDamage x bu hitstream w) $ do
dir <- bounceDir (hp,crwl) dir <- bounceDir (hp,crwl)
@@ -118,10 +119,10 @@ damageThingHit bu (p,crwl) = case crwl of
expireAndDamage :: Float expireAndDamage :: Float
-> Bullet -> Bullet
-> Stream (Of (Point2, Either Creature Wall)) Identity () -> [(Point2, Either Creature Wall)]
-> World -> World
-> (World, Maybe Bullet) -> (World, Maybe Bullet)
expireAndDamage y bt things w = case runIdentity $ S.head_ things of expireAndDamage y bt things w = case List.safeHead things of
Nothing -> (w, moveBullet y bt) Nothing -> (w, moveBullet y bt)
Just x -> (damageThingHit bt x w, destroyAt (fst x) bt) Just x -> (damageThingHit bt x w, destroyAt (fst x) bt)
@@ -139,11 +140,11 @@ destroyAt hitp pt = Just $ pt
where where
p = _buPos pt p = _buPos pt
movePenBullet :: Float -> Bullet -> StreamOf (Point2, Either Creature Wall) movePenBullet :: Float -> Bullet -> [(Point2, Either Creature Wall)]
-> World -> (World, Maybe Bullet) -> World -> (World, Maybe Bullet)
movePenBullet x bu hitstream w = case runIdentity (S.next hitstream) of movePenBullet x bu hitstream w = case hitstream of
Left _ -> (w,moveBullet x bu) [] -> (w,moveBullet x bu)
Right ((p,crwl),strm) -> if penThing crwl ((p,crwl):strm) -> if penThing crwl
then first (damageThingHit bu (p,crwl)) $ movePenBullet x bu strm w then first (damageThingHit bu (p,crwl)) $ movePenBullet x bu strm w
else expireAndDamage x bu hitstream w else expireAndDamage x bu hitstream w
src/Dodge/Creature/ReaderUpdate.hs
-4
View File
@@ -19,17 +19,13 @@ import FoldableHelp
import Dodge.Data import Dodge.Data
import Dodge.Creature.Volition import Dodge.Creature.Volition
import Dodge.Base import Dodge.Base
import Dodge.Zone
import Geometry import Geometry
import qualified Data.IntSet as IS
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Control.Lens import Control.Lens
import Control.Applicative import Control.Applicative
import Data.Maybe import Data.Maybe
import Data.Bifunctor import Data.Bifunctor
--import StreamingHelp
import qualified Streaming.Prelude as S
overrideMeleeCloseTarget :: Creature -> Creature overrideMeleeCloseTarget :: Creature -> Creature
overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr) overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr)
src/Dodge/DamageCircle.hs
+2 -1
View File
@@ -14,7 +14,8 @@ damageCircle r sp dt da w = w
& wallDamages %~ addwalldamages & wallDamages %~ addwalldamages
& creatures %~ addcreaturedamages & creatures %~ addcreaturedamages
where where
addwalldamages wlds = runIdentity $ S.fold_ (damageWlCircle wldam) wlds id wlstodam --addwalldamages wlds = runIdentity $ S.fold_ (damageWlCircle wldam) wlds id wlstodam
addwalldamages wlds = foldl' (damageWlCircle wldam) wlds wlstodam
wlstodam = wlsHitRadial sp r w wlstodam = wlsHitRadial sp r w
wldam p = Damage dt da sp p (sp +.+ r *.* normalizeV (p -.- sp)) NoDamageEffect wldam p = Damage dt da sp p (sp +.+ r *.* normalizeV (p -.- sp)) NoDamageEffect
addcreaturedamages crs = foldl' (damageCrCircle crdam) crs crstodam addcreaturedamages crs = foldl' (damageCrCircle crdam) crs crstodam
src/Dodge/Data.hs
+4 -3
View File
@@ -186,13 +186,14 @@ data World = World
, _boundBox :: [Point2] , _boundBox :: [Point2]
, _boundDist :: (Float,Float,Float,Float) -- NSEW, S and W negative , _boundDist :: (Float,Float,Float,Float) -- NSEW, S and W negative
, _creatures :: IM.IntMap Creature , _creatures :: IM.IntMap Creature
, _crZoning :: CrZoning --Zoning IM.IntMap Creature , _crZoning :: IM.IntMap (IM.IntMap IS.IntSet) --Zoning IM.IntMap Creature
, _creatureGroups :: IM.IntMap CrGroupParams , _creatureGroups :: IM.IntMap CrGroupParams
, _itemPositions :: IM.IntMap ItemPos , _itemPositions :: IM.IntMap ItemPos
, _clouds :: [Cloud] , _clouds :: [Cloud]
, _clZoning :: Zoning [] Cloud , _clZoning :: Zoning [] Cloud
, _gusts :: IM.IntMap Gust , _gusts :: IM.IntMap Gust
, _gsZoning :: Zoning IM.IntMap Gust , _gsZoning :: IM.IntMap (IM.IntMap IS.IntSet)
--, _gsZoning :: Zoning IM.IntMap Gust
, _props :: IM.IntMap Prop , _props :: IM.IntMap Prop
, _projectiles :: IM.IntMap Proj , _projectiles :: IM.IntMap Proj
, _instantBullets :: [Bullet] , _instantBullets :: [Bullet]
@@ -217,7 +218,7 @@ data World = World
, _blocks :: IM.IntMap Block , _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2 , _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap Bool , _triggers :: IM.IntMap Bool
, _wlZoning :: Zoning IM.IntMap Wall , _wlZoning :: IM.IntMap (IM.IntMap IS.IntSet) -- Zoning IM.IntMap Wall
, _floorItems :: IM.IntMap FloorItem , _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)] , _floorTiles :: [(Point3,Point3)]
, _randGen :: StdGen , _randGen :: StdGen
src/Dodge/Default/World.hs
+29 -29
View File
@@ -15,38 +15,38 @@ import Data.Graph.Inductive.Graph hiding ((&))
--import Data.Graph.Inductive.NodeMap --import Data.Graph.Inductive.NodeMap
defaultWorld :: World defaultWorld :: World
defaultWorld = World defaultWorld = World
{ _keys = S.empty { _keys = S.empty
, _magnets = IM.empty , _magnets = IM.empty
, _mouseButtons = mempty , _mouseButtons = mempty
, _cameraCenter = V2 0 0 , _cameraCenter = V2 0 0
, _cameraRot = 0 , _cameraRot = 0
, _cameraZoom = 1 , _cameraZoom = 1
, _itemZoom = 1 , _itemZoom = 1
, _defaultZoom = 1 , _defaultZoom = 1
, _cameraViewFrom = V2 0 0 , _cameraViewFrom = V2 0 0
, _viewDistance = 1000 , _viewDistance = 1000
, _modifications = IM.empty , _modifications = IM.empty
, _creatures = IM.empty , _creatures = IM.empty
, _crZoning = CrZoning mempty --Zoning IM.empty crZoneSize zoneOfCreature , _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature
, _creatureGroups = IM.empty , _creatureGroups = IM.empty
, _clouds = mempty , _clouds = mempty
, _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos)) , _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
, _gusts = IM.empty , _gusts = IM.empty
, _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos) , _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
, _itemPositions = IM.empty , _itemPositions = IM.empty
, _props = IM.empty , _props = IM.empty
, _projectiles = IM.empty , _projectiles = IM.empty
, _instantBullets = [] , _instantBullets = []
, _bullets = [] , _bullets = []
, _instantParticles = [] , _instantParticles = []
, _particles = [] , _particles = []
, _flames = [] , _flames = []
, _radarSweeps = [] , _radarSweeps = []
, _sparks = [] , _sparks = []
, _posEvents = [] , _posEvents = []
, _energyBalls = [] , _energyBalls = []
, _radarBlips = [] , _radarBlips = []
, _flares = [] , _flares = []
, _newBeams = WorldBeams [] [] [] [] , _newBeams = WorldBeams [] [] [] []
, _beams = WorldBeams [] [] [] [] , _beams = WorldBeams [] [] [] []
, _walls = IM.empty , _walls = IM.empty
@@ -57,7 +57,7 @@ defaultWorld = World
, _doors = IM.empty , _doors = IM.empty
, _coordinates = IM.empty , _coordinates = IM.empty
, _triggers = IM.empty , _triggers = IM.empty
, _wlZoning = Zoning IM.empty wlZoneSize zoneOfWall , _wlZoning = IM.empty --Zoning IM.empty wlZoneSize zoneOfWall
, _floorItems = IM.empty , _floorItems = IM.empty
, _floorTiles = [] , _floorTiles = []
, _randGen = mkStdGen 2 , _randGen = mkStdGen 2
@@ -76,8 +76,8 @@ defaultWorld = World
, _clickMousePos = V2 0 0 , _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty , _pathGraph = Data.Graph.Inductive.Graph.empty
-- , _pathGraphP = mempty -- , _pathGraphP = mempty
, _pnZoning = Zoning mempty wlZoneSize (zonePos snd) , _pnZoning = Zoning mempty peZoneSize (zonePos snd)
, _peZoning = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e)) , _peZoning = Zoning mempty peZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
, _hud = HUD , _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory { _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0 , _carteCenter = V2 0 0
src/Dodge/Flame.hs
+10 -9
View File
@@ -3,6 +3,8 @@ module Dodge.Flame
, makeFlame , makeFlame
, moveFlame , moveFlame
) where ) where
import Dodge.Zoning.Wall
import qualified ListHelp as List
import Dodge.Data import Dodge.Data
import Dodge.LightSource import Dodge.LightSource
import Dodge.Zone import Dodge.Zone
@@ -42,10 +44,10 @@ simpleDamFL dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ]
ep = sp +.+ bulVel ep = sp +.+ bulVel
expireAndDamageFL :: (Flame -> Point2 -> [Damage]) expireAndDamageFL :: (Flame -> Point2 -> [Damage])
-> Flame -> Flame
-> Stream (Of (Point2, Either Creature Wall)) Identity () -> [(Point2, Either Creature Wall)]
-> World -> World
-> (World, Maybe Flame) -> (World, Maybe Flame)
expireAndDamageFL fdm bt things w = case runIdentity $ S.head_ things of expireAndDamageFL fdm bt things w = case List.safeHead things of
Nothing -> (w, Just $ bt & flTimer -~ 1) Nothing -> (w, Just $ bt & flTimer -~ 1)
Just x -> (doDamagesFL fdm x bt w, Nothing) Just x -> (doDamagesFL fdm x bt w, Nothing)
doDamagesFL :: (Flame -> Point2 -> [Damage]) doDamagesFL :: (Flame -> Point2 -> [Damage])
@@ -65,7 +67,7 @@ moveFlame :: World
-> (World, Maybe Flame) -> (World, Maybe Flame)
moveFlame w pt moveFlame w pt
| time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing) | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
| otherwise = case runIdentity . S.head_ $ thingsHit sp ep w of | otherwise = case List.safeHead $ thingsHit sp ep w of
Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7) Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7)
Just (p,Right wl) -> (doSound $ dodamage w , rfl wl p) Just (p,Right wl) -> (doSound $ dodamage w , rfl wl p)
_ -> (flFlicker pt $ doSound $ dodamage w , mvPt' 0.98) _ -> (flFlicker pt $ doSound $ dodamage w , mvPt' 0.98)
@@ -100,13 +102,12 @@ flDamageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Flame -> World -> Worl
flDamageInArea crt wlt pt w = damwls damcrs flDamageInArea crt wlt pt w = damwls damcrs
where where
p = _flPos pt p = _flPos pt
damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures w
damwls w' = runIdentity damwls w'
. S.fold_ = foldl'
(flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) (flip $ \wl -> fst . hiteff [(p,Right wl)])
w' w'
id . filter wlt
. S.filter wlt
$ wlsNearPoint p w' $ wlsNearPoint p w'
hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt
src/Dodge/Floor.hs
+1 -1
View File
@@ -45,7 +45,7 @@ initialAnoTree = OnwardList
-- , AnRoom $ tanksRoom [] [] -- , AnRoom $ tanksRoom [] []
-- , AnRoom $ roomCCrits 0 -- , AnRoom $ roomCCrits 0
-- , AnRoom $ return airlock0 -- , AnRoom $ return airlock0
-- , AnRoom slowDoorRoom , AnRoom slowDoorRoom
-- , AnRoom $ roomCCrits 10 -- , AnRoom $ roomCCrits 10
-- , AnTree firstBreather -- , AnTree firstBreather
-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward -- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
src/Dodge/Item/Weapon/ExtraEffect.hs
-2
View File
@@ -22,7 +22,6 @@ import Dodge.Zoning.Creature
import FoldableHelp import FoldableHelp
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone
import Dodge.RadarSweep import Dodge.RadarSweep
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.Item.Weapon.LaserPath import Dodge.Item.Weapon.LaserPath
@@ -36,7 +35,6 @@ import Sound.Data
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe import Data.Maybe
import qualified Streaming.Prelude as S
import qualified SDL import qualified SDL
autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World
autoEffect eff t sid itm cr w autoEffect eff t sid itm cr w
src/Dodge/Item/Weapon/Grenade.hs
+1
View File
@@ -1,4 +1,5 @@
module Dodge.Item.Weapon.Grenade where module Dodge.Item.Weapon.Grenade where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
src/Dodge/Layout.hs
+1 -1
View File
@@ -146,7 +146,7 @@ setupWorldBounds w = w & worldBounds %~
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges --polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
initWallZoning :: World -> World initWallZoning :: World -> World
initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning . znObjects .~ IM.empty) (_walls w) initWallZoning w = foldl' (flip insertWallInZones) (w & wlZoning .~ IM.empty) (_walls w)
--makePath :: Tree Room -> [(Point2,Point2)] --makePath :: Tree Room -> [(Point2,Point2)]
--makePath = concatMap _rmPath . flatten --makePath = concatMap _rmPath . flatten
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+2 -1
View File
@@ -3,6 +3,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor
( plDoor ( plDoor
, plSlideDoor , plSlideDoor
) where ) where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Zone import Dodge.Zone
import Dodge.Base import Dodge.Base
@@ -117,7 +118,7 @@ maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World
maybeClearDoorPath eo w (x,y,pe) maybeClearDoorPath eo w (x,y,pe)
| runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
= w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y) = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y)
| otherwise | otherwise
= w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y) = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y)
src/Dodge/RadarSweep.hs
+12 -3
View File
@@ -1,10 +1,12 @@
module Dodge.RadarSweep where module Dodge.RadarSweep where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Zone import Dodge.Zone
import Color import Color
import Geometry import Geometry
import LensHelp import LensHelp
import Data.Maybe
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import qualified Streaming.Prelude as S import qualified Streaming.Prelude as S
@@ -68,10 +70,17 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems
where where
f q = dist p q <= r && dist p q > r - 4 f q = dist p q <= r && dist p q > r - 4
--wallBlips :: Point2 -> Float -> World -> [Point2]
--wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
-- $ S.map (over wlLine swp) (wlsInsideCirc p r w)
-- <> wlsInsideCirc p r w
-- where
-- swp (a,b) = (b,a)
wallBlips :: Point2 -> Float -> World -> [Point2] wallBlips :: Point2 -> Float -> World -> [Point2]
wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) wallBlips p r w = mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
$ S.map (over wlLine swp) (wlsInsideCirc p r w) $ map (over wlLine swp) (wlsNearCirc p r w)
<> wlsInsideCirc p r w <> wlsNearCirc p r w
where where
swp (a,b) = (b,a) swp (a,b) = (b,a)
src/Dodge/Render/ShapePicture.hs
+3 -2
View File
@@ -1,6 +1,7 @@
module Dodge.Render.ShapePicture module Dodge.Render.ShapePicture
( worldSPic ( worldSPic
) where ) where
import Dodge.Zoning.Wall
import Dodge.Button.Draw import Dodge.Button.Draw
import Dodge.LightSource.Draw import Dodge.LightSource.Draw
import Dodge.Targeting.Draw import Dodge.Targeting.Draw
@@ -246,7 +247,7 @@ drawFarWallDetect w = setLayer DebugLayer
. color yellow . color yellow
. foldMap (\q -> line . foldMap (\q -> line
[ p [ p
, fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
] ) ] )
$ runIdentity $ S.toList_ $ streamViewpoints p w $ runIdentity $ S.toList_ $ streamViewpoints p w
where where
@@ -282,7 +283,7 @@ innerSquare :: [Point2]
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)] innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
drawWallSearchRays :: World -> Picture drawWallSearchRays :: World -> Picture
drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w drawWallSearchRays w = foldMap f $ map fst $ allVisibleWalls w
where where
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5) f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
<> line [_cameraViewFrom w, p] <> line [_cameraViewFrom w, p]
src/Dodge/Render/Walls.hs
+19 -3
View File
@@ -1,6 +1,9 @@
module Dodge.Render.Walls module Dodge.Render.Walls
( wallsToDraw ( wallsToDraw
) where ) where
import Dodge.Zoning.World
import Dodge.Zoning.Base
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Wall.Draw import Dodge.Wall.Draw
import Dodge.Zone import Dodge.Zone
@@ -21,13 +24,26 @@ wallsToDraw w
= ( wls, wins,spic) = ( wls, wins,spic)
where where
f wl = (_wlLine wl, _wlColor wl) f wl = (_wlLine wl, _wlColor wl)
(wls, wins, spic) = runIdentity $ L.purely S.fold_ (wls, wins, spic) = L.fold
((,,) ((,,)
<$> L.prefilter wlOpaqueDraw (L.premap f L.list) <$> L.prefilter wlOpaqueDraw (L.premap f L.list)
<*> L.prefilter wlSeeThroughDraw (L.premap f L.list) <*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
<*> L.premap getWallSPic L.mconcat <*> L.premap getWallSPic L.mconcat
) (S.concat $ S.mapMaybe g $ zoneOfSight wlZoneSize w) ) (wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight' wlZoneSize w)
g (V2 i j) = w ^? wlZoning . znObjects . ix i . ix j --wallsToDraw
-- :: World
-- -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)], SPic )
--wallsToDraw w
-- = ( wls, wins,spic)
-- where
-- f wl = (_wlLine wl, _wlColor wl)
-- (wls, wins, spic) = runIdentity $ L.purely S.fold_
-- ((,,)
-- <$> L.prefilter wlOpaqueDraw (L.premap f L.list)
-- <*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
-- <*> L.premap getWallSPic L.mconcat
-- ) (S.concat $ S.mapMaybe g $ zoneOfSight wlZoneSize w)
-- g (V2 i j) = w ^? wlZoning . znObjects . ix i . ix j
wlOpaqueDraw :: Wall -> Bool wlOpaqueDraw :: Wall -> Bool
wlOpaqueDraw wl = wlIsOpaque wl && _wlHeight wl == 100 wlOpaqueDraw wl = wlIsOpaque wl && _wlHeight wl == 100
src/Dodge/Update.hs
+2 -2
View File
@@ -174,7 +174,7 @@ doRewind w = case _maybeWorld w of
zoneCreatures :: World -> World zoneCreatures :: World -> World
zoneCreatures w = w zoneCreatures w = w
& crZoning . getCrZoning .~ mempty & crZoning .~ mempty
& crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures w) & crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures w)
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) -- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
-- zn (_creatures w) -- zn (_creatures w)
@@ -352,7 +352,7 @@ ppEvents :: World -> World
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
updateSeenWalls :: World -> World updateSeenWalls :: World -> World
updateSeenWalls w = runIdentity $ S.fold_ markWallSeen w id (S.map (_wlID . snd) $ allVisibleWalls w) updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
-- where -- where
-- f w' !i -- = w' & walls . ix i . wlSeen .~ True -- f w' !i -- = w' & walls . ix i . wlSeen .~ True
-- = w' { _walls = IM.adjust mw i $ _walls w' } -- = w' { _walls = IM.adjust mw i $ _walls w' }
src/Dodge/Update/Camera.hs
+5 -6
View File
@@ -7,6 +7,7 @@ module Dodge.Update.Camera
, streamViewpoints , streamViewpoints
, farWallDistDirection , farWallDistDirection
) where ) where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
@@ -18,10 +19,8 @@ import Dodge.GameRoom
import LensHelp import LensHelp
import Bound import Bound
import Data.Foldable
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
--import qualified Data.List.NonEmpty as NEL
--import Control.Applicative
--import Data.Foldable
import Data.Maybe import Data.Maybe
import Control.Monad import Control.Monad
import qualified Data.Set as Set import qualified Data.Set as Set
@@ -156,7 +155,7 @@ rotateToOverlappingWall :: World -> World
rotateToOverlappingWall w = maybe rotateToOverlappingWall w = maybe
id id
(doWallRotate . snd) (doWallRotate . snd)
(overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wlsNearPoint p w)) (overlapCircWallsClosest p (_crRad cr + 5) (filter _wlRotateTo $ wlsNearPoint p w))
w w
where where
cr = you w cr = you w
@@ -228,8 +227,8 @@ farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float)
farWallDistDirection p w = boundPoints farWallDistDirection p w = boundPoints
$ S.map f vps $ S.map f vps
where where
f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q)) f q = (rotateV (negate $ _cameraRot w) . (-.- p)) (foldl' findPoint q (wls q))
wls q = S.filter wlIsOpaque $ wlsNearSeg p q w wls q = filter wlIsOpaque $ wlsNearSeg p q w
findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
vps = streamViewpoints p w vps = streamViewpoints p w
src/Dodge/Update/Cloud.hs
-3
View File
@@ -1,11 +1,8 @@
module Dodge.Update.Cloud where module Dodge.Update.Cloud where
import Dodge.Zoning.Creature import Dodge.Zoning.Creature
import Dodge.Data import Dodge.Data
import Dodge.Zone
import Geometry.Vector3D import Geometry.Vector3D
import LensHelp import LensHelp
import StreamingHelp
import qualified Streaming.Prelude as S
import Data.Foldable import Data.Foldable
cloudPoisonDamage :: Cloud -> World -> World cloudPoisonDamage :: Cloud -> World -> World
cloudPoisonDamage c w = w & dodamagesto (filter f $ crsNearPoint clpos w) cloudPoisonDamage c w = w & dodamagesto (filter f $ crsNearPoint clpos w)
src/Dodge/Wall/Zone.hs
+8 -3
View File
@@ -1,9 +1,12 @@
module Dodge.Wall.Zone module Dodge.Wall.Zone
where where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Zone import Dodge.Zone
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Data.Foldable
import qualified Data.IntSet as IS
import Control.Lens import Control.Lens
--import Data.Foldable --import Data.Foldable
--import Streaming --import Streaming
@@ -12,12 +15,14 @@ import Control.Lens
-- need to verify that this not only inserts but also overwrites (updates) any -- need to verify that this not only inserts but also overwrites (updates) any
-- already existing walls -- already existing walls
insertWallInZones :: Wall -> World -> World insertWallInZones :: Wall -> World -> World
insertWallInZones wl = wlZoning %~ updateZoning (IM.insert (_wlID wl)) wl insertWallInZones wl = wlZoning %~ zoneWall wl
--insertWallInZones wl = wlZoning %~ updateZoning (IM.insert (_wlID wl)) wl
--insertWallInZones wl = wlZoning .updatets --insertWallInZones wl = wlZoning .updatets
-- %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl))) -- %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
-- where -- where
-- doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns -- doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
deleteWallFromZones :: Wall -> World -> World deleteWallFromZones :: Wall -> World -> World
deleteWallFromZones wl = wlZoning %~ updateZoning (const $ IM.delete (_wlID wl)) wl deleteWallFromZones wl = wlZoning %~ deZoneWall wl
-- %~ flip (foldl' (flip $ \(a,b) updateeIMInZone a b (_wlID wl))) (zoneOfWall wl) -- %~ flip (foldl' (flip $ \(a,b) updateeIMInZone a b (_wlID wl))) (zoneOfWall wl)
src/Dodge/WallCreatureCollisions.hs
+5 -7
View File
@@ -5,9 +5,8 @@ module Dodge.WallCreatureCollisions
, pushCreatureOutFromWalls , pushCreatureOutFromWalls
, crOnWall , crOnWall
) where ) where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
--import Dodge.Data.DamageType
--import Dodge.Creature.State.Data
import Dodge.Zone import Dodge.Zone
import Dodge.Base import Dodge.Base
import Geometry import Geometry
@@ -47,8 +46,8 @@ colCrWall w c
p2 = _crPos c p2 = _crPos c
ls = _wlLine <$> wls ls = _wlLine <$> wls
ls' = filter (uncurry $ isLHS p1) ls ls' = filter (uncurry $ isLHS p1) ls
wls' = S.filter (not . _wlWalkable) $ wlsNearPoint p2 w wls' = filter (not . _wlWalkable) $ wlsNearPoint p2 w
wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wlsNearPoint p2 w wls = filter (not . _wlWalkable) $ wlsNearPoint p2 w
--wallPoints = map fst ls --wallPoints = map fst ls
-- the amount to push creatures out from walls, extra to their radius -- the amount to push creatures out from walls, extra to their radius
@@ -85,9 +84,8 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
-- note the inclusion of endpoints in circOnSeg -- note the inclusion of endpoints in circOnSeg
crOnWall :: Creature -> World -> Bool crOnWall :: Creature -> World -> Bool
crOnWall cr = runIdentity crOnWall cr = any (uncurry (circOnSeg p r) . _wlLine)
. S.any_ (uncurry (circOnSeg p r) . _wlLine) . filter (not . _wlWalkable)
. S.filter (not . _wlWalkable)
. wlsNearPoint p . wlsNearPoint p
where where
p = _crPos cr p = _crPos cr
src/Dodge/WorldEvent/Shockwave.hs
+4 -5
View File
@@ -4,6 +4,7 @@ module Dodge.WorldEvent.Shockwave
, drawShockwave , drawShockwave
, mvShockwave , mvShockwave
) where ) where
import Dodge.Zoning.Wall
import Dodge.Data import Dodge.Data
import Dodge.Wall.Damage import Dodge.Wall.Damage
import Dodge.Base import Dodge.Base
@@ -12,7 +13,7 @@ import Geometry
import Picture import Picture
import LensHelp import LensHelp
--import Data.Foldable import Data.Foldable
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import qualified Streaming.Prelude as S import qualified Streaming.Prelude as S
-- currently very effective against walls -- currently very effective against walls
@@ -63,13 +64,11 @@ mvShockwave is w pt
tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt) tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
rad = r - (3/4) * r * tFraction rad = r - (3/4) * r * tFraction
doDams w' = over creatures (IM.map damCr) doDams w' = over creatures (IM.map damCr)
. runIdentity $ foldl'
$ S.fold_
(flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)) (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
w' w'
id
hitBlocks hitBlocks
hitBlocks = S.map snd . overlapCircWalls p rad $ wlsInsideCirc p rad w hitBlocks = map snd . overlapCircWalls p rad $ wlsNearCirc p rad w
-- this is not expansive enough -- this is not expansive enough
damCr cr damCr cr
| _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr
src/Dodge/WorldEvent/ThingsHit.hs
+55 -12
View File
@@ -11,11 +11,13 @@ module Dodge.WorldEvent.ThingsHit
, wlsHitRadial , wlsHitRadial
) )
where where
import Dodge.Zoning.Wall
import Dodge.Zoning.Creature import Dodge.Zoning.Creature
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
import Geometry import Geometry
import qualified ListHelp as List
import Control.Lens import Control.Lens
import Data.Maybe import Data.Maybe
@@ -31,10 +33,19 @@ thingsHit
:: Point2 -- ^ Line start point :: Point2 -- ^ Line start point
-> Point2 -- ^ Line end point -> Point2 -- ^ Line end point
-> World -> World
-> StreamOf (Point2, Either Creature Wall) -> [(Point2, Either Creature Wall)]
thingsHit sp ep w = void $ S.mergeOn (dist sp . fst) thingsHit sp ep w = List.mergeOn (dist sp . fst)
(S.map (second Left) (S.each $ crsHit sp ep w)) (map (second Left) (crsHit sp ep w))
(S.map (second Right) (wlsHit sp ep w)) (map (second Right) (wlsHit sp ep w))
--{- List those objects that appear on a line. -}
--thingsHit
-- :: Point2 -- ^ Line start point
-- -> Point2 -- ^ Line end point
-- -> World
-- -> StreamOf (Point2, Either Creature Wall)
--thingsHit sp ep w = void $ S.mergeOn (dist sp . fst)
-- (S.map (second Left) (S.each $ crsHit sp ep w))
-- (S.map (second Right) (wlsHit sp ep w))
crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)] crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)]
crsHit sp ep w crsHit sp ep w
@@ -48,13 +59,20 @@ crsHit sp ep w
thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool)
-> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep thingHitFilt fcr fwl sp ep = listToMaybe . filter (f . snd) . thingsHit sp ep
where where
f (Left cr) = fcr cr f (Left cr) = fcr cr
f (Right wl) = fwl wl f (Right wl) = fwl wl
--thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool)
-- -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
--thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep
-- where
-- f (Left cr) = fcr cr
-- f (Right wl) = fwl wl
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHit sp ep = runIdentity . S.head_ . thingsHit sp ep thingHit sp ep = listToMaybe . thingsHit sp ep
{- List objects that appear on a line. {- List objects that appear on a line.
Can filter out a creature. -} Can filter out a creature. -}
@@ -63,26 +81,51 @@ thingsHitExceptCr
-> Point2 -- ^ Line start point -> Point2 -- ^ Line start point
-> Point2 -- ^ Line end point -> Point2 -- ^ Line end point
-> World -> World
-> StreamOf (Point2, Either Creature Wall) -> [(Point2, Either Creature Wall)]
thingsHitExceptCr Nothing sp ep = thingsHit sp ep thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where where
crNotCid (_,Left cr) = _crID cr /= cid crNotCid (_,Left cr) = _crID cr /= cid
crNotCid _ = True crNotCid _ = True
--{- List objects that appear on a line.
--Can filter out a creature. -}
--thingsHitExceptCr
-- :: Maybe Int -- ^ A possible creature ID
-- -> Point2 -- ^ Line start point
-- -> Point2 -- ^ Line end point
-- -> World
-- -> StreamOf (Point2, Either Creature Wall)
--thingsHitExceptCr Nothing sp ep = thingsHit sp ep
--thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
-- where
-- crNotCid (_,Left cr) = _crID cr /= cid
-- crNotCid _ = True
wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall) wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)]
wlsHit sp ep wlsHit sp ep
| sp == ep = const mempty | sp == ep = const mempty
| otherwise = sortStreamOn (dist sp . fst) | otherwise = sortOn (dist sp . fst)
. overlapSegWalls sp ep . overlapSegWalls sp ep
. wlsNearSeg sp ep . wlsNearSeg sp ep
--wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall)
--wlsHit sp ep
-- | sp == ep = const mempty
-- | otherwise = sortStreamOn (dist sp . fst)
-- . overlapSegWalls sp ep
-- . wlsNearSeg sp ep
wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall) wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
where where
f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl) f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl)
where where
v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl
--wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall)
--wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r
-- where
-- f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl)
-- where
-- v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl
crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)] crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
crsHitRadial p r = mapMaybe f . crsNearCirc p r crsHitRadial p r = mapMaybe f . crsNearCirc p r
src/Dodge/Zone.hs
+15 -12
View File
@@ -4,12 +4,12 @@ module Dodge.Zone
, aroundPoint , aroundPoint
, nearPoint , nearPoint
, nearSeg , nearSeg
, wlsNearPoint --, wlsNearPoint
--, crsNearPoint --, crsNearPoint
, clsNearPoint , clsNearPoint
, wlsNearSeg --, wlsNearSeg
--, crsNearSeg --, crsNearSeg
, wlsInsideCirc --, wlsInsideCirc
--, crsInsideCirc --, crsInsideCirc
, clZoneOfPoint , clZoneOfPoint
--, crZoneOfPoint --, crZoneOfPoint
@@ -78,9 +78,9 @@ clsNearPoint :: Point2 -> World -> StreamOf Cloud
{-# INLINE clsNearPoint #-} {-# INLINE clsNearPoint #-}
clsNearPoint = nearPoint _clZoning clsNearPoint = nearPoint _clZoning
wlsNearPoint :: Point2 -> World -> StreamOf Wall --wlsNearPoint :: Point2 -> World -> StreamOf Wall
{-# INLINE wlsNearPoint #-} --{-# INLINE wlsNearPoint #-}
wlsNearPoint = nearPoint _wlZoning --wlsNearPoint = nearPoint _wlZoning
--crsNearPoint :: Point2 -> World -> StreamOf Creature --crsNearPoint :: Point2 -> World -> StreamOf Creature
--{-# INLINE crsNearPoint #-} --{-# INLINE crsNearPoint #-}
@@ -92,9 +92,9 @@ nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
where where
zn = f w zn = f w
wlsNearSeg :: Point2 -> Point2 -> World -> StreamOf Wall --wlsNearSeg :: Point2 -> Point2 -> World -> StreamOf Wall
{-# INLINE wlsNearSeg #-} --{-# INLINE wlsNearSeg #-}
wlsNearSeg = nearSeg _wlZoning --wlsNearSeg = nearSeg _wlZoning
--crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature --crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
--{-# INLINE crsNearSeg #-} --{-# INLINE crsNearSeg #-}
@@ -106,9 +106,9 @@ insideCirc f p r w = streamFromZone zn $ zoneInsideCirc (_znSize zn) p r
where where
zn = f w zn = f w
wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity () --wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
{-# INLINE wlsInsideCirc #-} --{-# INLINE wlsInsideCirc #-}
wlsInsideCirc = insideCirc _wlZoning --wlsInsideCirc = insideCirc _wlZoning
--crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature --crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
--{-# INLINE crsInsideCirc #-} --{-# INLINE crsInsideCirc #-}
@@ -118,6 +118,9 @@ wlZoneOfPoint :: Point2 -> Int2
{-# INLINE wlZoneOfPoint #-} {-# INLINE wlZoneOfPoint #-}
wlZoneOfPoint = zoneOfPoint wlZoneSize wlZoneOfPoint = zoneOfPoint wlZoneSize
wlZoneSize :: Float
wlZoneSize = 50
clZoneOfPoint :: Point2 -> Int2 clZoneOfPoint :: Point2 -> Int2
{-# INLINE clZoneOfPoint #-} {-# INLINE clZoneOfPoint #-}
clZoneOfPoint = zoneOfPoint clZoneSize clZoneOfPoint = zoneOfPoint clZoneSize
src/Dodge/Zone/Size.hs
+3 -3
View File
@@ -3,8 +3,8 @@ module Dodge.Zone.Size where
pnZoneSize :: Float pnZoneSize :: Float
pnZoneSize = 100 pnZoneSize = 100
wlZoneSize :: Float
wlZoneSize = 50
clZoneSize :: Float clZoneSize :: Float
clZoneSize = 20 clZoneSize = 20
peZoneSize :: Float
peZoneSize = 50
src/Dodge/Zoning.hs
+2
View File
@@ -1,5 +1,7 @@
module Dodge.Zoning module Dodge.Zoning
( module Dodge.Zoning.Creature ( module Dodge.Zoning.Creature
, module Dodge.Zoning.Wall
) where ) where
import Dodge.Zoning.Creature import Dodge.Zoning.Creature
import Dodge.Zoning.Wall
src/Dodge/Zoning/Creature.hs
+10 -16
View File
@@ -3,22 +3,22 @@ import FoldableHelp
import Dodge.Data import Dodge.Data
import Geometry import Geometry
import Dodge.Zoning.Base import Dodge.Zoning.Base
import qualified FoldlHelp as L --import qualified FoldlHelp as L
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Data.Maybe import Data.Maybe
import Data.Function --import Data.Function
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Control.Lens import Control.Lens
crIXsNearPoint :: Point2 -> World -> IS.IntSet crIXsNearPoint :: Point2 -> World -> IS.IntSet
crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. crZoning . getCrZoning) crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. crZoning)
crsNearPoint :: Point2 -> World -> [Creature] crsNearPoint :: Point2 -> World -> [Creature]
crsNearPoint p w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearPoint p w crsNearPoint p w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearPoint p w
crsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet crsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
crsNearSeg sp ep w = zonesExtract (w ^. crZoning . getCrZoning) (zoneOfSeg' crZoneSize sp ep) crsNearSeg sp ep w = zonesExtract (w ^. crZoning) (zoneOfSeg' crZoneSize sp ep)
crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r) crIXsNearCirc p r = crsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -27,7 +27,7 @@ crsNearCirc :: Point2 -> Float -> World -> [Creature]
crsNearCirc p r w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearCirc p r w crsNearCirc p r w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearCirc p r w
crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
crsNearRect sp ep w = zonesExtract (w ^. crZoning . getCrZoning) $ zoneOfRect' crZoneSize sp ep crsNearRect sp ep w = zonesExtract (w ^. crZoning) $ zoneOfRect' crZoneSize sp ep
crZoneSize :: Float crZoneSize :: Float
crZoneSize = 15 crZoneSize = 15
@@ -36,19 +36,13 @@ zoneOfCr :: Creature -> [Int2]
zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr) zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
minCrIXOn f is w = fmap fst $ IS.foldl' (g w) Nothing is minCrIXOn f is w = fmap fst $ IS.foldl' g Nothing is
where where
g w mcrx cid = minOn snd <$> getpair cid <*> mcrx g mcrx cid = minOn snd <$> getpair cid <*> mcrx
getpair cid = fmap h $ w ^? creatures . ix cid getpair cid = fmap h $ w ^? creatures . ix cid
h cr = (cr, f cr) h cr = (cr, f cr)
zoneCreature :: Creature -> CrZoning -> CrZoning zoneCreature :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
zoneCreature cr = over getCrZoning (zoneCr' cr) zoneCreature cr im = foldl' f im (zoneOfCr cr)
zoneCr' :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
zoneCr' cr im = foldl' f im (zoneOfCr cr)
where where
f im i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im f im' i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im'
--crsInZones :: [Int2] -> CrZoning -> IS.IntSet
--crsInZones is
src/Dodge/Zoning/Wall.hs
+61
View File
@@ -0,0 +1,61 @@
module Dodge.Zoning.Wall where
import FoldableHelp
import Dodge.Data
import Geometry
import Dodge.Zoning.Base
import qualified IntMapHelp as IM
import Data.Maybe
import qualified Data.IntSet as IS
import Control.Lens
wlIXsNearPoint :: Point2 -> World -> IS.IntSet
wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. wlZoning)
wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
wlIXsNearSeg sp ep w = zonesExtract (w ^. wlZoning) (zoneOfSeg' wlZoneSize sp ep)
wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
wlIXsNearRect sp ep w = zonesExtract (w ^. wlZoning) $ zoneOfRect' wlZoneSize sp ep
wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
wlsFromIXs :: World -> IS.IntSet -> [Wall]
wlsFromIXs w = mapMaybe (\wlid -> w ^? walls . ix wlid) . IS.toList
wlsNearPoint :: Point2 -> World -> [Wall]
wlsNearPoint p w = wlsFromIXs w $ wlIXsNearPoint p w
wlsNearSeg :: Point2 -> Point2 -> World -> [Wall]
wlsNearSeg sp ep w = wlsFromIXs w $ wlIXsNearSeg sp ep w
wlsNearRect :: Point2 -> Point2 -> World -> [Wall]
wlsNearRect sp ep w = wlsFromIXs w $ wlIXsNearRect sp ep w
wlsNearCirc :: Point2 -> Float -> World -> [Wall]
wlsNearCirc p r w = wlsFromIXs w $ wlIXsNearCirc p r w
wlZoneSize :: Float
wlZoneSize = 50
zoneOfWl :: Wall -> [Int2]
zoneOfWl = uncurry (zoneOfSeg' wlZoneSize) . _wlLine
--minCrIXOn :: Ord a => (Creature -> a) -> IS.IntSet -> World -> Maybe Creature
--minCrIXOn f is w = fmap fst $ IS.foldl' g Nothing is
-- where
-- g mcrx cid = minOn snd <$> getpair cid <*> mcrx
-- getpair cid = fmap h $ w ^? creatures . ix cid
-- h cr = (cr, f cr)
zoneWall :: Wall -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
zoneWall wl im = foldl' f im (zoneOfWl wl)
where
f im' i2 = zoneMonoid i2 (IS.singleton $ _wlID wl) im'
deZoneWall :: Wall -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
deZoneWall wl im = foldl' (deZoneIX (_wlID wl)) im (zoneOfWl wl)
deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet)
deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i
src/Dodge/Zoning/World.hs
+17
View File
@@ -0,0 +1,17 @@
module Dodge.Zoning.World where
import Dodge.Data
import Geometry.Data
zoneOfSight' :: Float -> World -> [Int2]
zoneOfSight' s w =
[ V2 a b
| a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys]
]
where
--(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w]
(xs,ys) = unzip $ map sizeZoneOfPoint $ _boundBox w -- ++ [_cameraViewFrom w]
sizeZoneOfPoint (V2 x y) = (f x, f y)
where
f = floor . (/ s)
src/ListHelp.hs
+20
View File
@@ -10,8 +10,13 @@ module ListHelp
, foldPairs , foldPairs
, loopPairs , loopPairs
, slideWindow , slideWindow
, merge
, mergeBy
, mergeOn
) where ) where
import Data.List import Data.List
import Data.Ord
loopPairs :: [a] -> [(a,a)] loopPairs :: [a] -> [(a,a)]
loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as) loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as)
@@ -65,3 +70,18 @@ errorHead s [] = error s
slideWindow :: Int -> [a] -> [[a]] slideWindow :: Int -> [a] -> [[a]]
slideWindow n = foldr (zipWith (:)) (repeat []) . take n . tails slideWindow n = foldr (zipWith (:)) (repeat []) . take n . tails
merge :: Ord a => [a] -> [a] -> [a]
merge = mergeBy compare
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy _ xs [] = xs
mergeBy _ [] ys = ys
mergeBy f (x:xs) (y:ys)
| f x y /= GT = x : mergeBy f xs (y:ys)
| otherwise = y : mergeBy f (x:xs) ys
mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
mergeOn f xs = map snd . mergeBy (comparing fst) (g xs) . g
where
g = map (\x -> let y = f x in y `seq` (y,x))