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

Commit before generalising picture transformation to alternative

Browse Source
This commit is contained in:
jgk
2021-07-21 14:38:57 +02:00
parent e5bee30f5b
commit 0aa437d035
6 changed files with 25 additions and 20 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Default.hs
+1 -1
View File
@@ -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
+3 -2
View File
@@ -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
+10 -9
View File
@@ -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
+1 -1
View File
@@ -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
+7 -7
View File
@@ -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
+3
View File
@@ -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]