diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 79a177664..88eb9eeb7 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -66,6 +66,7 @@ import Dodge.GameRoom import Color import Data.Tile import MaybeHelp +--import StreamingHelp.Data --import qualified Data.Vector as V import qualified Linear.Quaternion as Q diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index afc0495c6..8690a6fe3 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -35,7 +35,7 @@ defaultWorld = World , _creatures = IM.empty , _crZoning = Zoning IM.empty crZoneSize zoneOfCreature , _creatureGroups = IM.empty - , _clouds = [] + , _clouds = mempty , _clZoning = Zoning IM.empty clZoneSize (zonePos (stripZ . _clPos)) , _gusts = IM.empty , _gsZoning = Zoning IM.empty clZoneSize (zonePos _guPos) diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index a2e626176..ffa337bf5 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -93,10 +93,9 @@ removePathsCrossing :: Point2 -> Point2 -> World -> World removePathsCrossing a b w = w & pathGraph .~ newGraph & pathGraphP .~ pg' - & phZoning %~ \zn -> foldl' (flip $ insertInZoning (:)) (zn & znObjects .~ mempty) + & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (labNodes newGraph) where pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w - insertpoint zn (i,p) = insertInZoneWith (wlZoneOfPoint p) (++) [(i,p)] zn -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp] newGraph = pairsToGraph dist pg' diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 777998398..fe3045588 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -73,6 +73,7 @@ extraPics cfig w = pictures (_decorations w) <> concatMapPic (dbArg _lsPict) (_lightSources w) <> testPic cfig w <> _debugPicture w +-- <> runIdentity (S.foldMap_ clDraw (_clouds w)) <> concatMapPic clDraw (_clouds w ) <> concatMapPic ppDraw (_pressPlates w ) <> soundPics cfig w diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 77f3216bb..f3573188d 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -98,11 +98,8 @@ functionalUpdate cfig w = checkEndGame zoneClouds :: World -> World zoneClouds w = w & clZoning %~ \zn -> - foldl' (flip $ insertInZoning (:)) (zn & znObjects .~ mempty) (_clouds w) --- where --- cloudInZone cl = insertInZoneWith p (++) [cl] --- where --- p = clZoneOfPoint $ stripZ $ _clPos cl + foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) (_clouds w) + --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w)) updateWorldSelect :: World -> World updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of @@ -150,25 +147,8 @@ doRewind w = case _maybeWorld w of zoneCreatures :: World -> World zoneCreatures w = w & crZoning %~ \zn -> - foldl' (flip $ insertInZoning (\cr -> IM.insert (_crID cr) cr)) + foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) (zn & znObjects .~ mempty) (_creatures w) --- . znObjects .~ --- IM.foldl' zoneCreature IM.empty (_creatures w) ----- runIdentity (S.fold_ zoneCreature IM.empty id (S.each $ _creatures w)) --- ---zoneCreature :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) --- -> Creature --- -> IM.IntMap (IM.IntMap (IM.IntMap Creature)) ---zoneCreature m cr = runIdentity $ S.fold_ doinsert m id (zoneOfCreature cr) --- where --- doinsert m' (V2 x y) = insertIMInZone x y (_crID cr) cr m' - --- IM.foldl' (flip creatureInZone) IM.empty (_creatures w) --- where --- creatureInZone cr = insertIMInZone x y cid cr --- where --- V2 x y = crZoneOfPoint $ _crPos cr --- cid = _crID cr updateCreatureSoundPositions :: World -> World updateCreatureSoundPositions w = M.foldlWithKey' insertSound w @@ -338,6 +318,7 @@ mvGust _ gu updateClouds :: World -> World updateClouds w = w' & clouds .~ catMaybes mclouds where +-- cls = _clouds w (w',mclouds) = mapAccumR updateCloud w (_clouds w) updateCloud :: World -> Cloud -> (World,Maybe Cloud) diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs index a499613da..4197f68e5 100644 --- a/src/Dodge/Wall/Zone.hs +++ b/src/Dodge/Wall/Zone.hs @@ -1,23 +1,21 @@ module Dodge.Wall.Zone where import Dodge.Data -import Geometry import Dodge.Zone -import Dodge.Base import qualified Data.IntMap.Strict as IM import Control.Lens --import Data.Foldable --import Streaming -import qualified Streaming.Prelude as S +--import qualified Streaming.Prelude as S insertWallInZones :: Wall -> World -> World -insertWallInZones wl = wlZoning %~ insertInZoning (IM.insert (_wlID wl)) wl ---insertWallInZones wl = wlZoning . znObjects +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 %~ insertInZoning (const $ IM.delete (_wlID wl)) wl --- %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl) +deleteWallFromZones wl = wlZoning %~ updateZoning (const $ IM.delete (_wlID wl)) wl +-- %~ flip (foldl' (flip $ \(a,b) updateeIMInZone a b (_wlID wl))) (zoneOfWall wl) diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index bf6cc291c..f5c0d53f2 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -13,6 +13,7 @@ import Geometry.Data import Picture import LensHelp +--import qualified Streaming.Prelude as S --import Control.Lens import System.Random @@ -25,6 +26,7 @@ makeCloudAt -> World -> World makeCloudAt drawFunc rad t alt p = clouds .:~ Cloud +--makeCloudAt drawFunc rad t alt p = clouds %~ S.cons Cloud { _clPos = p , _clVel = V3 0 0 0 , _clPict = drawFunc diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 881062be4..5e4b5ccd7 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -225,6 +225,7 @@ makeGasCloud -> World makeGasCloud pos vel w = w & clouds .:~ theCloud +-- & clouds %~ S.cons theCloud & randGen .~ g where theCloud = Cloud diff --git a/src/Dodge/Zone/Object.hs b/src/Dodge/Zone/Object.hs index e73a56b90..a548a6fde 100644 --- a/src/Dodge/Zone/Object.hs +++ b/src/Dodge/Zone/Object.hs @@ -2,7 +2,6 @@ module Dodge.Zone.Object where import Dodge.Data import Geometry.Zone import Geometry.Data -import Geometry.Vector3D import StreamingHelp import qualified Streaming.Prelude as S diff --git a/src/Dodge/Zone/Update.hs b/src/Dodge/Zone/Update.hs index d0de30ea6..1bbfa09be 100644 --- a/src/Dodge/Zone/Update.hs +++ b/src/Dodge/Zone/Update.hs @@ -6,8 +6,8 @@ import qualified Data.IntMap.Strict as IM import Geometry import LensHelp -insertInZoning :: Monoid (t a) => (a -> t a -> t a) -> a -> Zoning t a -> Zoning t a -insertInZoning f obj zn = runIdentity (S.fold_ doinsert zn id (_znFunc zn (_znSize zn) obj)) +updateZoning :: Monoid (t a) => (a -> t a -> t a) -> a -> Zoning t a -> Zoning t a +updateZoning f obj zn = runIdentity (S.fold_ doinsert zn id (_znFunc zn (_znSize zn) obj)) where doinsert znobs vxy = insertInZoneWith vxy (\_ -> f obj) (f obj mempty) znobs diff --git a/src/StreamingHelp.hs b/src/StreamingHelp.hs index 21307acde..91febca54 100644 --- a/src/StreamingHelp.hs +++ b/src/StreamingHelp.hs @@ -1,15 +1,15 @@ module StreamingHelp ( minStreamOn , sortStreamOn - , StreamOf , module Streaming + , module StreamingHelp.Data ) where import Streaming +import StreamingHelp.Data import qualified Streaming.Prelude as S import qualified Control.Foldl as L import Data.Function (on) -type StreamOf a = Stream (Of a) Identity () minStreamOn :: Ord a => (b -> a) -> StreamOf b -> Maybe b {-# INLINE minStreamOn #-} diff --git a/src/StreamingHelp/Data.hs b/src/StreamingHelp/Data.hs new file mode 100644 index 000000000..77a8ff797 --- /dev/null +++ b/src/StreamingHelp/Data.hs @@ -0,0 +1,5 @@ +module StreamingHelp.Data where +import Streaming +type StreamOf a = Stream (Of a) Identity () + +newtype StreamOf' a = StreamOf' (Stream (Of a) Identity ())