Commit before generalising picture transformation to alternative

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

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

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

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 []

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
 

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]