From 0aa437d03555849854c1aa5fa92225ce8b6f7abb Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 21 Jul 2021 14:38:57 +0200 Subject: [PATCH] Commit before generalising picture transformation to alternative --- src/Dodge/Default.hs | 2 +- src/Dodge/Item/Weapon/TriggerType.hs | 5 +++-- src/Dodge/Layout.hs | 19 ++++++++++--------- src/Dodge/RandomHelp.hs | 2 +- src/Dodge/Update.hs | 14 +++++++------- src/Picture/Data.hs | 3 +++ 6 files changed, 25 insertions(+), 20 deletions(-) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index b581fca87..4475c206f 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -98,7 +98,7 @@ defaultConsumable = Consumable , _itAimStance = LeaveHolstered } defaultApplyDamage :: [DamageType] -> Creature -> (World -> World, Creature) -defaultApplyDamage ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ applyIndividualDamage d c) cr ds') +defaultApplyDamage ds cr = (id, doPoisonDam $ foldl' (flip $ \d c -> snd $ applyIndividualDamage d c) cr ds') where (ps,ds') = partition isPoison ds isPoison PoisonDam{} = True diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index ac4561053..30a13222c 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -18,13 +18,14 @@ import Control.Lens import Control.Monad.State import Data.Maybe import qualified Data.IntMap.Strict as IM +import Data.Foldable withThinSmoke :: (Creature -> World -> World) -- ^ Underlying effect -> Creature -> World -> World -withThinSmoke eff cr w = eff cr $ foldr (makeThinSmokeAt . (+.+ pos)) w ps +withThinSmoke eff cr w = eff cr $ foldl' (flip $ makeThinSmokeAt . (+.+ pos)) w ps where dir = _crDir cr pos = _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir @@ -35,7 +36,7 @@ withThickSmoke -> Creature -> World -> World -withThickSmoke eff cr w = eff cr $ foldr (makeThickSmokeAt . (+.+ pos)) w ps +withThickSmoke eff cr w = eff cr $ foldl' (flip $ makeThickSmokeAt . (+.+ pos)) w ps where dir = _crDir cr pos = _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 3e04f5412..ded45cc07 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -26,6 +26,7 @@ import System.Random import Data.Tree import Data.Graph.Inductive.Graph (labNodes) import qualified Data.Map as M +import Data.Foldable generateLevelFromRoomList :: State StdGen [Room] -> World -> World generateLevelFromRoomList gr w = updateWallZoning @@ -48,7 +49,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts $ w {_walls = wallsFromTree tr ,_pathGraph = path ,_pathGraph' = pairGraph - ,_pathPoints = foldr insertPoint IM.empty (labNodes path) + ,_pathPoints = foldl' (flip insertPoint) IM.empty (labNodes path) ,_pathInc = pinc } where @@ -60,7 +61,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts pinc = M.fromList $ pairsToIncidence pairGraph initializeStaticWalls :: World -> World -initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldr wallToWall wls' wls) +initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldl' (flip wallToWall) wls' wls) & walls %~ IM.filter (not . wlIsWall) where wls = [wl | wl@Wall{} <- (IM.elems $ _walls w)] @@ -68,18 +69,18 @@ initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldr wallToWall wls' wls wlIsWall _ = False wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall']) -wallToWall wl wls = foldr f wls is +wallToWall wl wls = foldl' (flip f) wls is where is = uncurry zoneOfLine (_wlLine wl) wl' = Wall' {_wlLine' = _wlLine wl, _wlColor' = _wlColor wl} f (x,y) = insertInZoneWith x y (++) [wl'] updateWallZoning :: World -> World -updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w +updateWallZoning w = set wallsZone (foldl' (flip wallInZone) IM.empty (_walls w)) w where wallInZone wl | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl - | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + | otherwise = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b wlid wl)) ips where (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) wlid = _wlID wl @@ -96,7 +97,7 @@ wallsFromTree t = divideWalls . assignKeys . removeInverseWalls - . foldr cutWalls [] -- map (map (g . roundPoint2)) + . foldl' (flip cutWalls) [] -- map (map (g . roundPoint2)) -- . map (map roundPoint2) $ concatMap _rmPolys (flatten t) where @@ -107,7 +108,7 @@ wallsFromRooms :: [Room] -> IM.IntMap Wall wallsFromRooms = -- divideWalls . IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls - . foldr cutWalls [] . concatMap _rmPolys + . foldl' (flip cutWalls) [] . concatMap _rmPolys where f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} @@ -125,10 +126,10 @@ divideWallIn wl wls = let (wl':newWls) = divideWall wl k = IM.newKey wls newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls - in foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls') + in foldl' (flip $ \w -> IM.insert (_wlID w) w) wls (wl':newWls') divideWalls :: IM.IntMap Wall -> IM.IntMap Wall -divideWalls wls = IM.foldr divideWallIn wls wls +divideWalls wls = foldl' (flip divideWallIn) wls wls insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a) insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 8adde7293..af493a08c 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -36,7 +36,7 @@ takeOneMore (xs,ys) = do return (w:xs, zs ++ ws) takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a]) -takeNMore n p = foldr (const (>>= takeOneMore)) (return p) [1..n] +takeNMore n p = foldl' (flip $ const (>>= takeOneMore)) (return p) [1..n] takeN :: RandomGen g => Int -> [a] -> State g [a] takeN 0 _ = return [] diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 4be866718..fe4f82a05 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -75,7 +75,7 @@ update' w = case _menuLayers w of . updateSoundQueue $ updateCloseObjects w where - zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w)) + zoneCreatures = set creaturesZone (IM.foldl' (flip creatureInZone) IM.empty (_creatures w)) creatureInZone cr = insertIMInZone x y cid cr where (x,y) = crZoneOfPoint $ _crPos cr @@ -120,7 +120,7 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w' (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w updateProjectiles :: World -> World -updateProjectiles w = IM.foldr' (dbArg _pjUpdate) w $ _projectiles w +updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _projectiles w {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World @@ -137,13 +137,13 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w {- | Apply door mechanisms. -} updateWalls :: World -> World -updateWalls w = IM.foldr (fromMaybe id . (^? doorMech)) w (_walls w) +updateWalls w = IM.foldl' (flip $ fromMaybe id . (^? doorMech)) w (_walls w) ppEvents :: World -> World -ppEvents w = IM.foldr (\pp w' -> _ppEvent pp pp w') w $ _pressPlates w +ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w updateSeenWalls :: World -> World -updateSeenWalls w = foldr markSeen w wallsToUpdate +updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate where vPos = _cameraViewFrom w wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w) @@ -190,10 +190,10 @@ clClSpringVel a v b radDist = (_clRad a + _clRad b) / 2 simpleCrSprings :: World -> World -simpleCrSprings w = IM.foldr' crSpring w $ _creatures w +simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w crSpring :: Creature -> World -> World -crSpring c w = IM.foldr' (crCrSpring c) w cs +crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs where cs = creaturesNearPoint (_crPos c) w diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 87ce8739f..67fe97cc2 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -4,6 +4,8 @@ module Picture.Data where import Geometry.Data +import Data.Foldable + --import Data.Monoid --import Data.Traversable --import qualified Data.Foldable as F @@ -55,6 +57,7 @@ instance Foldable LTree where instance Functor LTree where fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts fmap f (LLeaf x) = LLeaf (f x) + {-# INLINE fmap #-} data RTree a b = RBranches a [RTree a b]