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.Base.Wall
import Geometry
import FoldableHelp
import Data.List (sortOn)
import Data.Maybe
import qualified IntMapHelp as IM
import Control.Lens
@@ -52,11 +54,19 @@ import StreamingHelp
import qualified Streaming.Prelude as S
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
-> StreamOf Wall
-> [Wall]
-> (Point2, Maybe Wall)
{-# INLINE collidePoint #-}
collidePoint sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
collidePoint sp ep = foldl' findPoint (ep, Nothing)
where
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
-> StreamOf Wall
-> [Wall]
-> Maybe (Point2,Point2)
{-# 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)
{-# 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
-- whether this is actually faster
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
{-# INLINE collidePointTestFilter #-}
collidePointTestFilter t sp ep = runIdentity
. S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. S.filter t
collidePointTestFilter t sp ep
= any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. 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)
{-# INLINE collidePointWallsFilterStream #-}
collidePointWallsFilterStream t sp ep = collidePoint sp ep
. S.filter t
. filter t
. wlsNearSeg sp ep
overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
-> StreamOf (Point2,Wall)
--overlapSegWalls :: Point2 -> Point2 -> StreamOf 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 #-}
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 #-}
visibleWalls sp ep = S.take 1 <=< -- hlint, was using join and fmap
( S.span (not . wlIsOpaque . snd)
. sortStreamOn (dist sp . fst)
visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
. sortOn (dist sp . fst)
. 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 #-}
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
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
-> StreamOf (Point2,Wall)
--overlapCircWalls :: Point2 -> Float -> StreamOf 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 #-}
overlapCircWalls p r = S.mapMaybe dointersect
overlapCircWalls p r = mapMaybe dointersect
where
dointersect wl = f (_wlLine wl) <&> (,wl)
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
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
-> (Point2, Maybe Wall)
@@ -160,18 +218,28 @@ collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing)
where
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall)
{-# INLINE overlapCircWallsClosest #-}
overlapCircWallsClosest p r = minStreamOn (dist p . fst)
overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
. 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.
- Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
{-# INLINE circOnSomeWall #-}
circOnSomeWall p rad = runIdentity . S.any_ (uncurry (circOnSeg p rad) . _wlLine)
circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine)
. 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
{-# INLINE circOnAnyCr #-}
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)
|| bl
hitWl = collideCircWallsStream sp ep rad $ wlsNearPoint ep w
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
-- this should probably be wallsOnLine or something
src/Dodge/Block.hs
+2 -1
View File
@@ -1,4 +1,5 @@
module Dodge.Block where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Base.Collide
import Dodge.Material.Sound
@@ -65,7 +66,7 @@ maybeClearPaths ps w = foldl' maybeClearPath w ps
maybeClearPath :: World -> (Int,Int,PathEdge) -> World
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
| 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
, useAmmoParams
) where
import qualified ListHelp as List
import Dodge.EnergyBall
import Dodge.Creature.Test
import Dodge.Data
@@ -87,12 +88,12 @@ bulletSpawn bu = case _buSpawn bu of
BulBall TeslaBall -> Just makeStaticBall
hitEffFromBul :: Float -> Bullet
-> StreamOf (Point2, Either Creature Wall)
-> [(Point2, Either Creature Wall)]
-> World
-> (World,Maybe Bullet)
hitEffFromBul x bu hitstream w = case _buEffect bu of
PenetrateBullet -> movePenBullet x bu hitstream w
BounceBullet -> case runIdentity (S.head_ hitstream) of
BounceBullet -> case List.safeHead hitstream of
Nothing -> (w, moveBullet x bu)
Just (hp,crwl) -> fromMaybe (expireAndDamage x bu hitstream w) $ do
dir <- bounceDir (hp,crwl)
@@ -118,10 +119,10 @@ damageThingHit bu (p,crwl) = case crwl of
expireAndDamage :: Float
-> Bullet
-> Stream (Of (Point2, Either Creature Wall)) Identity ()
-> [(Point2, Either Creature Wall)]
-> World
-> (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)
Just x -> (damageThingHit bt x w, destroyAt (fst x) bt)
@@ -139,11 +140,11 @@ destroyAt hitp pt = Just $ pt
where
p = _buPos pt
movePenBullet :: Float -> Bullet -> StreamOf (Point2, Either Creature Wall)
movePenBullet :: Float -> Bullet -> [(Point2, Either Creature Wall)]
-> World -> (World, Maybe Bullet)
movePenBullet x bu hitstream w = case runIdentity (S.next hitstream) of
Left _ -> (w,moveBullet x bu)
Right ((p,crwl),strm) -> if penThing crwl
movePenBullet x bu hitstream w = case hitstream of
[] -> (w,moveBullet x bu)
((p,crwl):strm) -> if penThing crwl
then first (damageThingHit bu (p,crwl)) $ movePenBullet x bu strm 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.Creature.Volition
import Dodge.Base
import Dodge.Zone
import Geometry
import qualified Data.IntSet as IS
import qualified IntMapHelp as IM
import Control.Lens
import Control.Applicative
import Data.Maybe
import Data.Bifunctor
--import StreamingHelp
import qualified Streaming.Prelude as S
overrideMeleeCloseTarget :: Creature -> Creature
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
& creatures %~ addcreaturedamages
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
wldam p = Damage dt da sp p (sp +.+ r *.* normalizeV (p -.- sp)) NoDamageEffect
addcreaturedamages crs = foldl' (damageCrCircle crdam) crs crstodam
src/Dodge/Data.hs
+4 -3
View File
@@ -186,13 +186,14 @@ data World = World
, _boundBox :: [Point2]
, _boundDist :: (Float,Float,Float,Float) -- NSEW, S and W negative
, _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
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: [Cloud]
, _clZoning :: Zoning [] Cloud
, _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
, _projectiles :: IM.IntMap Proj
, _instantBullets :: [Bullet]
@@ -217,7 +218,7 @@ data World = World
, _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap Bool
, _wlZoning :: Zoning IM.IntMap Wall
, _wlZoning :: IM.IntMap (IM.IntMap IS.IntSet) -- Zoning IM.IntMap Wall
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)]
, _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
defaultWorld :: World
defaultWorld = World
{ _keys = S.empty
, _magnets = IM.empty
, _mouseButtons = mempty
, _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 1
, _itemZoom = 1
, _defaultZoom = 1
, _cameraViewFrom = V2 0 0
, _viewDistance = 1000
{ _keys = S.empty
, _magnets = IM.empty
, _mouseButtons = mempty
, _cameraCenter = V2 0 0
, _cameraRot = 0
, _cameraZoom = 1
, _itemZoom = 1
, _defaultZoom = 1
, _cameraViewFrom = V2 0 0
, _viewDistance = 1000
, _modifications = IM.empty
, _creatures = IM.empty
, _crZoning = CrZoning mempty --Zoning IM.empty crZoneSize zoneOfCreature
, _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature
, _creatureGroups = IM.empty
, _clouds = mempty
, _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos))
, _gusts = IM.empty
, _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos)
, _itemPositions = IM.empty
, _props = IM.empty
, _projectiles = IM.empty
, _instantBullets = []
, _bullets = []
, _gusts = IM.empty
, _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
, _itemPositions = IM.empty
, _props = IM.empty
, _projectiles = IM.empty
, _instantBullets = []
, _bullets = []
, _instantParticles = []
, _particles = []
, _flames = []
, _radarSweeps = []
, _sparks = []
, _posEvents = []
, _energyBalls = []
, _radarBlips = []
, _flares = []
, _particles = []
, _flames = []
, _radarSweeps = []
, _sparks = []
, _posEvents = []
, _energyBalls = []
, _radarBlips = []
, _flares = []
, _newBeams = WorldBeams [] [] [] []
, _beams = WorldBeams [] [] [] []
, _walls = IM.empty
@@ -57,7 +57,7 @@ defaultWorld = World
, _doors = IM.empty
, _coordinates = IM.empty
, _triggers = IM.empty
, _wlZoning = Zoning IM.empty wlZoneSize zoneOfWall
, _wlZoning = IM.empty --Zoning IM.empty wlZoneSize zoneOfWall
, _floorItems = IM.empty
, _floorTiles = []
, _randGen = mkStdGen 2
@@ -76,8 +76,8 @@ defaultWorld = World
, _clickMousePos = V2 0 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
-- , _pathGraphP = mempty
, _pnZoning = Zoning mempty wlZoneSize (zonePos snd)
, _peZoning = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
, _pnZoning = Zoning mempty peZoneSize (zonePos snd)
, _peZoning = Zoning mempty peZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
, _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0
src/Dodge/Flame.hs
+10 -9
View File
@@ -3,6 +3,8 @@ module Dodge.Flame
, makeFlame
, moveFlame
) where
import Dodge.Zoning.Wall
import qualified ListHelp as List
import Dodge.Data
import Dodge.LightSource
import Dodge.Zone
@@ -42,10 +44,10 @@ simpleDamFL dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ]
ep = sp +.+ bulVel
expireAndDamageFL :: (Flame -> Point2 -> [Damage])
-> Flame
-> Stream (Of (Point2, Either Creature Wall)) Identity ()
-> [(Point2, Either Creature Wall)]
-> World
-> (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)
Just x -> (doDamagesFL fdm x bt w, Nothing)
doDamagesFL :: (Flame -> Point2 -> [Damage])
@@ -65,7 +67,7 @@ moveFlame :: World
-> (World, Maybe Flame)
moveFlame w pt
| 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 (p,Right wl) -> (doSound $ dodamage w , rfl wl p)
_ -> (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
where
p = _flPos pt
damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w
damwls w' = runIdentity
. S.fold_
(flip $ \wl -> fst . hiteff (S.yield (p,Right wl)))
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'
id
. S.filter wlt
. filter wlt
$ wlsNearPoint p w'
hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt
src/Dodge/Floor.hs
+1 -1
View File
@@ -45,7 +45,7 @@ initialAnoTree = OnwardList
-- , AnRoom $ tanksRoom [] []
-- , AnRoom $ roomCCrits 0
-- , AnRoom $ return airlock0
-- , AnRoom slowDoorRoom
, AnRoom slowDoorRoom
-- , AnRoom $ roomCCrits 10
-- , AnTree firstBreather
-- , 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 Dodge.Data
import Dodge.Base
import Dodge.Zone
import Dodge.RadarSweep
import Dodge.SoundLogic
import Dodge.Item.Weapon.LaserPath
@@ -36,7 +35,6 @@ import Sound.Data
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Streaming.Prelude as S
import qualified SDL
autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World
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
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Base
import Dodge.Zone
src/Dodge/Layout.hs
+1 -1
View File
@@ -146,7 +146,7 @@ setupWorldBounds w = w & worldBounds %~
--polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
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 = concatMap _rmPath . flatten
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+2 -1
View File
@@ -3,6 +3,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor
( plDoor
, plSlideDoor
) where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Zone
import Dodge.Base
@@ -117,7 +118,7 @@ maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World
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)
| otherwise
= 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
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Zone
import Color
import Geometry
import LensHelp
import Data.Maybe
import qualified IntMapHelp as IM
import qualified Streaming.Prelude as S
@@ -68,10 +70,17 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems
where
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 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
wallBlips p r w = mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
$ map (over wlLine swp) (wlsNearCirc p r w)
<> wlsNearCirc p r w
where
swp (a,b) = (b,a)
src/Dodge/Render/ShapePicture.hs
+3 -2
View File
@@ -1,6 +1,7 @@
module Dodge.Render.ShapePicture
( worldSPic
) where
import Dodge.Zoning.Wall
import Dodge.Button.Draw
import Dodge.LightSource.Draw
import Dodge.Targeting.Draw
@@ -246,7 +247,7 @@ drawFarWallDetect w = setLayer DebugLayer
. color yellow
. foldMap (\q -> line
[ 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
where
@@ -282,7 +283,7 @@ innerSquare :: [Point2]
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
drawWallSearchRays :: World -> Picture
drawWallSearchRays w = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
drawWallSearchRays w = foldMap f $ map fst $ allVisibleWalls w
where
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
<> line [_cameraViewFrom w, p]
src/Dodge/Render/Walls.hs
+19 -3
View File
@@ -1,6 +1,9 @@
module Dodge.Render.Walls
( wallsToDraw
) where
import Dodge.Zoning.World
import Dodge.Zoning.Base
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Wall.Draw
import Dodge.Zone
@@ -21,13 +24,26 @@ wallsToDraw w
= ( wls, wins,spic)
where
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 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
) (wlsFromIXs w $ zonesExtract (w ^. wlZoning) $ zoneOfSight' wlZoneSize w)
--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 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 w = w
& crZoning . getCrZoning .~ mempty
& crZoning .~ mempty
& crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures w)
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
-- zn (_creatures w)
@@ -352,7 +352,7 @@ ppEvents :: World -> World
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
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
-- f w' !i -- = w' & walls . ix i . wlSeen .~ True
-- = 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
, farWallDistDirection
) where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Base
import Dodge.Zone
@@ -18,10 +19,8 @@ import Dodge.GameRoom
import LensHelp
import Bound
import Data.Foldable
import qualified Data.Map.Strict as M
--import qualified Data.List.NonEmpty as NEL
--import Control.Applicative
--import Data.Foldable
import Data.Maybe
import Control.Monad
import qualified Data.Set as Set
@@ -156,7 +155,7 @@ rotateToOverlappingWall :: World -> World
rotateToOverlappingWall w = maybe
id
(doWallRotate . snd)
(overlapCircWallsClosest p (_crRad cr + 5) (S.filter _wlRotateTo $ wlsNearPoint p w))
(overlapCircWallsClosest p (_crRad cr + 5) (filter _wlRotateTo $ wlsNearPoint p w))
w
where
cr = you w
@@ -228,8 +227,8 @@ farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float)
farWallDistDirection p w = boundPoints
$ S.map f vps
where
f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q))
wls q = S.filter wlIsOpaque $ wlsNearSeg p q w
f q = (rotateV (negate $ _cameraRot w) . (-.- p)) (foldl' findPoint q (wls q))
wls q = filter wlIsOpaque $ wlsNearSeg p q w
findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
vps = streamViewpoints p w
src/Dodge/Update/Cloud.hs
-3
View File
@@ -1,11 +1,8 @@
module Dodge.Update.Cloud where
import Dodge.Zoning.Creature
import Dodge.Data
import Dodge.Zone
import Geometry.Vector3D
import LensHelp
import StreamingHelp
import qualified Streaming.Prelude as S
import Data.Foldable
cloudPoisonDamage :: Cloud -> World -> World
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
where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Zone
import qualified IntMapHelp as IM
import Data.Foldable
import qualified Data.IntSet as IS
import Control.Lens
--import Data.Foldable
--import Streaming
@@ -12,12 +15,14 @@ import Control.Lens
-- need to verify that this not only inserts but also overwrites (updates) any
-- already existing walls
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
-- %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
-- where
-- doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
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)
src/Dodge/WallCreatureCollisions.hs
+5 -7
View File
@@ -5,9 +5,8 @@ module Dodge.WallCreatureCollisions
, pushCreatureOutFromWalls
, crOnWall
) where
import Dodge.Zoning.Wall
import Dodge.Data
--import Dodge.Data.DamageType
--import Dodge.Creature.State.Data
import Dodge.Zone
import Dodge.Base
import Geometry
@@ -47,8 +46,8 @@ colCrWall w c
p2 = _crPos c
ls = _wlLine <$> wls
ls' = filter (uncurry $ isLHS p1) ls
wls' = S.filter (not . _wlWalkable) $ wlsNearPoint p2 w
wls = runIdentity . S.toList_ . S.filter (not . _wlWalkable) $ wlsNearPoint p2 w
wls' = filter (not . _wlWalkable) $ wlsNearPoint p2 w
wls = filter (not . _wlWalkable) $ wlsNearPoint p2 w
--wallPoints = map fst ls
-- 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
crOnWall :: Creature -> World -> Bool
crOnWall cr = runIdentity
. S.any_ (uncurry (circOnSeg p r) . _wlLine)
. S.filter (not . _wlWalkable)
crOnWall cr = any (uncurry (circOnSeg p r) . _wlLine)
. filter (not . _wlWalkable)
. wlsNearPoint p
where
p = _crPos cr
src/Dodge/WorldEvent/Shockwave.hs
+4 -5
View File
@@ -4,6 +4,7 @@ module Dodge.WorldEvent.Shockwave
, drawShockwave
, mvShockwave
) where
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Wall.Damage
import Dodge.Base
@@ -12,7 +13,7 @@ import Geometry
import Picture
import LensHelp
--import Data.Foldable
import Data.Foldable
import qualified IntMapHelp as IM
import qualified Streaming.Prelude as S
-- currently very effective against walls
@@ -63,13 +64,11 @@ mvShockwave is w pt
tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
rad = r - (3/4) * r * tFraction
doDams w' = over creatures (IM.map damCr)
. runIdentity
$ S.fold_
$ foldl'
(flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect))
w'
id
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
damCr 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
)
where
import Dodge.Zoning.Wall
import Dodge.Zoning.Creature
import Dodge.Data
import Dodge.Base
import Dodge.Zone
import Geometry
import qualified ListHelp as List
import Control.Lens
import Data.Maybe
@@ -31,10 +33,19 @@ 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))
-> [(Point2, Either Creature Wall)]
thingsHit sp ep w = List.mergeOn (dist sp . fst)
(map (second Left) (crsHit 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 sp ep w
@@ -48,13 +59,20 @@ crsHit sp ep w
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
thingHitFilt fcr fwl sp ep = listToMaybe . filter (f . snd) . thingsHit sp ep
where
f (Left cr) = fcr cr
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 sp ep = runIdentity . S.head_ . thingsHit sp ep
thingHit sp ep = listToMaybe . thingsHit sp ep
{- List objects that appear on a line.
Can filter out a creature. -}
@@ -63,26 +81,51 @@ thingsHitExceptCr
-> Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> StreamOf (Point2, Either Creature Wall)
-> [(Point2, Either Creature Wall)]
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
crNotCid (_,Left cr) = _crID cr /= cid
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
| sp == ep = const mempty
| otherwise = sortStreamOn (dist sp . fst)
| otherwise = sortOn (dist sp . fst)
. overlapSegWalls 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 p r = S.mapMaybe f . wlsInsideCirc p r
wlsHitRadial :: Point2 -> Float -> World -> [(Point2, Wall)]
wlsHitRadial p r = mapMaybe f . wlsNearCirc p r
where
f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl)
where
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 p r = mapMaybe f . crsNearCirc p r
src/Dodge/Zone.hs
+15 -12
View File
@@ -4,12 +4,12 @@ module Dodge.Zone
, aroundPoint
, nearPoint
, nearSeg
, wlsNearPoint
--, wlsNearPoint
--, crsNearPoint
, clsNearPoint
, wlsNearSeg
--, wlsNearSeg
--, crsNearSeg
, wlsInsideCirc
--, wlsInsideCirc
--, crsInsideCirc
, clZoneOfPoint
--, crZoneOfPoint
@@ -78,9 +78,9 @@ clsNearPoint :: Point2 -> World -> StreamOf Cloud
{-# INLINE clsNearPoint #-}
clsNearPoint = nearPoint _clZoning
wlsNearPoint :: Point2 -> World -> StreamOf Wall
{-# INLINE wlsNearPoint #-}
wlsNearPoint = nearPoint _wlZoning
--wlsNearPoint :: Point2 -> World -> StreamOf Wall
--{-# INLINE wlsNearPoint #-}
--wlsNearPoint = nearPoint _wlZoning
--crsNearPoint :: Point2 -> World -> StreamOf Creature
--{-# INLINE crsNearPoint #-}
@@ -92,9 +92,9 @@ nearSeg f p r w = streamFromZone zn $ zoneOfSeg (_znSize zn) p r
where
zn = f w
wlsNearSeg :: Point2 -> Point2 -> World -> StreamOf Wall
{-# INLINE wlsNearSeg #-}
wlsNearSeg = nearSeg _wlZoning
--wlsNearSeg :: Point2 -> Point2 -> World -> StreamOf Wall
--{-# INLINE wlsNearSeg #-}
--wlsNearSeg = nearSeg _wlZoning
--crsNearSeg :: Point2 -> Point2 -> World -> StreamOf Creature
--{-# INLINE crsNearSeg #-}
@@ -106,9 +106,9 @@ 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
--wlsInsideCirc :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
--{-# INLINE wlsInsideCirc #-}
--wlsInsideCirc = insideCirc _wlZoning
--crsInsideCirc :: Point2 -> Float -> World -> StreamOf Creature
--{-# INLINE crsInsideCirc #-}
@@ -118,6 +118,9 @@ wlZoneOfPoint :: Point2 -> Int2
{-# INLINE wlZoneOfPoint #-}
wlZoneOfPoint = zoneOfPoint wlZoneSize
wlZoneSize :: Float
wlZoneSize = 50
clZoneOfPoint :: Point2 -> Int2
{-# INLINE clZoneOfPoint #-}
clZoneOfPoint = zoneOfPoint clZoneSize
src/Dodge/Zone/Size.hs
+3 -3
View File
@@ -3,8 +3,8 @@ module Dodge.Zone.Size where
pnZoneSize :: Float
pnZoneSize = 100
wlZoneSize :: Float
wlZoneSize = 50
clZoneSize :: Float
clZoneSize = 20
peZoneSize :: Float
peZoneSize = 50
src/Dodge/Zoning.hs
+2
View File
@@ -1,5 +1,7 @@
module Dodge.Zoning
( module Dodge.Zoning.Creature
, module Dodge.Zoning.Wall
) where
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 Geometry
import Dodge.Zoning.Base
import qualified FoldlHelp as L
--import qualified FoldlHelp as L
import qualified IntMapHelp as IM
import Data.Maybe
import Data.Function
--import Data.Function
import qualified Data.IntSet as IS
import Control.Lens
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 p w = mapMaybe (\cid -> w ^? creatures . ix cid) . IS.toList $ crIXsNearPoint p w
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 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
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 = 15
@@ -36,19 +36,13 @@ zoneOfCr :: Creature -> [Int2]
zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
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
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
h cr = (cr, f cr)
zoneCreature :: Creature -> CrZoning -> CrZoning
zoneCreature cr = over getCrZoning (zoneCr' cr)
zoneCr' :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
zoneCr' cr im = foldl' f im (zoneOfCr cr)
zoneCreature :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
zoneCreature cr im = foldl' f im (zoneOfCr cr)
where
f im i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im
--crsInZones :: [Int2] -> CrZoning -> IS.IntSet
--crsInZones is
f im' i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im'
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
, loopPairs
, slideWindow
, merge
, mergeBy
, mergeOn
) where
import Data.List
import Data.Ord
loopPairs :: [a] -> [(a,a)]
loopPairs (a:as) = snd $ foldr f (Just a,[]) (a:as)
@@ -65,3 +70,18 @@ errorHead s [] = error s
slideWindow :: Int -> [a] -> [[a]]
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))