Cleanup

src/Dodge/Creature.hs

@@ -69,7 +69,7 @@ spawnerCrit = defaultCreature
 miniGunCrit :: Creature
 miniGunCrit = defaultCreature
     { _crPict = basicCrPict red
-    , _crUpdate = stateUpdate $ impulsiveAI $
+    , _crUpdate = stateUpdate' $ impulsiveAI' $
         sentinelFireType (const shootTillEmpty)
     , _crActionPlan = ActionPlan
         { _crImpulse    = []

src/Dodge/Creature/Impulse.hs

@@ -1,6 +1,7 @@
 module Dodge.Creature.Impulse
     ( impulsiveAIR
     , impulsiveAI
+    , impulsiveAI'
     ) where
 import Dodge.Data
 import Dodge.Creature.Vocalization
@@ -20,31 +21,29 @@ impulsiveAIR
     -> Creature
     -> World
     -> (World -> World , Maybe Creature)
-impulsiveAIR impf cr w = bimap id Just $ followImpulses w . ($ w) . runReader $ impf cr
+impulsiveAIR impf cr w = second Just $ followImpulses w . ($ w) . runReader $ impf cr
 
 impulsiveAI :: (World -> Creature -> Creature)
     -> Creature
     -> World
     -> (World -> World , Maybe Creature)
-impulsiveAI impf cr w = bimap id Just $ followImpulses w $ impf w cr
+impulsiveAI impf cr w = second Just $ followImpulses w $ impf w cr
 
-followImpulses 
-    :: World 
-    -> Creature 
-    -> (World -> World, Creature)
-followImpulses w cr
-    = foldr 
-        foldf
-        (id, cr) 
-        (_crImpulse $ _crActionPlan cr)
+impulsiveAI' :: (World -> Creature -> Creature)
+    -> Creature
+    -> World
+    -> (World -> World , Creature)
+impulsiveAI' impf cr w = followImpulses w $ impf w cr
+
+followImpulses :: World -> Creature -> (World -> World, Creature)
+followImpulses w cr = foldr 
+    foldf
+    (id, cr) 
+    (_crImpulse $ _crActionPlan cr)
   where
     foldf imp (f,cr') = first ( . f) $ followImpulse cr' w imp
 
-followImpulse
-    :: Creature
-    -> World
-    -> Impulse
-    -> (World -> World , Creature)
+followImpulse :: Creature -> World -> Impulse -> (World -> World , Creature)
 followImpulse cr w imp = case imp of
     Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr)
     Move p  -> (id, crMvBy p cr)

src/Dodge/Creature/Inanimate.hs

@@ -65,7 +65,7 @@ updateBarrel cr
 -- should generate the sparks externally using new random generators
 updateExpBarrel :: Creature -> World -> World
 updateExpBarrel cr w 
-    | _crHP cr > 0 = foldr (.) id pierceSparks $ hiss w & creatures . at (_crID cr) .~ newCr
+    | _crHP cr > 0 = foldr ($) (hiss w & creatures . at (_crID cr) .~ newCr) pierceSparks
     | otherwise    = makeExplosionAt (_crPos cr) $ stopSounds w & creatures . at (_crID cr) .~ Nothing
   where 
     g = _randGen w

src/Dodge/Creature/Lamp.hs

@@ -0,0 +1,68 @@
+module Dodge.Creature.Lamp 
+    ( lamp
+    , colorLamp
+    ) where
+import Dodge.Data
+import Dodge.Default
+import Dodge.Creature.Picture
+import Dodge.LightSource
+import Dodge.WorldEvent.Flash
+import Dodge.WorldEvent.Sound
+import Dodge.Creature.State
+import Geometry
+import Picture
+import Polyhedra
+import qualified IntMapHelp as IM
+import LensHelp
+
+colorLamp 
+    :: Point3   -- color of lamp
+    -> Float    -- height of lamp
+    -> Creature
+colorLamp col h = defaultInanimate
+    { _crUpdate = initialiseColorLamp col h
+    , _crHP = 100
+    , _crPict = picAtCrPosNoRot (lampCrPic h)
+    , _crRad = 3
+    , _crMass = 3
+    }
+
+lamp :: Float -> Creature
+lamp h = defaultInanimate
+    { _crUpdate = initialiseLamp h
+    , _crHP = 100
+    , _crPict = picAtCrPosNoRot (lampCrPic h)
+    , _crRad = 3
+    , _crMass = 3
+    }
+lampCrPic :: Float -> Picture
+lampCrPic h = pictures 
+    [ setLayer 1 (setDepth h . color white $ circleSolid 3)
+    , concatMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
+    ]
+  where
+    f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] 0 polyNum
+
+initialiseLamp :: Float -> Creature -> World -> World
+initialiseLamp = initialiseColorLamp 0.75
+
+initialiseColorLamp :: Point3 -> Float -> Creature -> World -> World
+initialiseColorLamp col h cr w = w
+    & lightSources . at lsid ?~ lsColPosID col (addZ h $ _crPos cr) lsid
+    & creatures . ix (_crID cr) . crUpdate .~ updateLamp h lsid 
+  where
+    lsid = IM.newKey $ _lightSources w
+
+updateLamp :: Float -> Int -> Creature -> World -> World
+updateLamp h i cr w 
+    | _crHP cr < 0 = w
+        & explosionFlashAt cpos 
+        & mkSoundBreakGlass cpos 
+        & lightSources . at i .~ Nothing
+        & creatures . at cid .~ Nothing
+    | otherwise = w 
+        & lightSources . ix i . lsParam . lsPos .~ addZ h cpos
+        & creatures . ix cid %~ doDamage
+  where
+    cpos = _crPos cr
+    cid  = _crID cr

src/Dodge/Creature/ReaderUpdate.hs

@@ -121,14 +121,14 @@ doStrategyActionsR cr = return $ case cr ^? crActionPlan . crStrategy of
         & crActionPlan . crStrategy .~ strat
     _ -> cr
 
-doStrategyActions :: World -> Creature -> Creature
-doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of
+doStrategyActions :: Creature -> Creature
+doStrategyActions cr = case cr ^? crActionPlan . crStrategy of
     Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs
         & crActionPlan . crStrategy .~ strat
     _ -> cr
 
-reloadOverride :: World -> Creature -> Creature
-reloadOverride w cr
+reloadOverride :: Creature -> Creature
+reloadOverride cr
     | cr ^? crInv . ix (_crInvSel cr) . itConsumption . ammoLoaded == Just 0 
             && cr ^. crStance . posture == Aiming
         = cr & crActionPlan . crStrategy .~ StrategyActions Reload reloadActions
@@ -163,10 +163,9 @@ overrideInternalRRR test update cr = do
 overrideInternal
     :: (Creature -> Bool)
     -> (Creature -> Creature)
-    -> World
     -> Creature
     -> Creature
-overrideInternal test update w cr
+overrideInternal test update cr
     | test cr = update cr
     | otherwise = cr
 

src/Dodge/Creature/SentinelAI.hs

@@ -41,13 +41,21 @@ sentinelAI = sentinelExtraWatchUpdate
     tcid cr = _crID <$> _targetCr (_crIntention cr)
     lostest (w,cr) = maybe False (\cid -> canSee (_crID cr) cid w) (tcid cr)
 
-chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature
-chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls
+--chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature
+--chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls
+
+chainCreatureUpdatesLR 
+    :: [Either (World -> Creature -> Creature) (Creature -> Creature)] 
+    -> World -> Creature -> Creature
+chainCreatureUpdatesLR ls w cr = foldr unf cr ls
+  where
+    unf (Left g) = g w
+    unf (Right g) = g
 
 sentinelFireType :: (Int -> Action) -> World -> Creature -> Creature
-sentinelFireType f = chainCreatureUpdates
-    [ performActions
-    ,  watchUpdateStrat
+sentinelFireType f = chainCreatureUpdatesLR
+    [ Left performActions
+    , Left $ watchUpdateStrat
       [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) 
             [ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
             , aiming
@@ -55,13 +63,13 @@ sentinelFireType f = chainCreatureUpdates
         )
       , (crAwayFromPost, goToPostStrat)
       ] 
-    , perceptionUpdate' [0]
-    , doStrategyActions
-    , reloadOverride
-    , targetYouWhenCognizant
-    , overrideInternal
+    , Left $ perceptionUpdate' [0]
+    , Right doStrategyActions
+    , Right reloadOverride
+    , Left targetYouWhenCognizant
+    , Right $ overrideInternal
         (\cr -> crHasTarget' cr && crStratConMatches' (GetTo (V2 0 0)) cr)
-        ((crActionPlan . crStrategy .~ WatchAndWait))
+        (crActionPlan . crStrategy .~ WatchAndWait)
     ]
   where
     drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))

src/Dodge/Creature/State.hs

@@ -1,5 +1,6 @@
 module Dodge.Creature.State 
     ( stateUpdate
+    , stateUpdate'
     , stateUpdateDamage
     , doDamage
     , clearDamage
@@ -45,6 +46,10 @@ stateUpdate :: CRUpdate -> Creature -> World -> World
 stateUpdate f cr w = let (fw,mcr) = stateUpdateDamage doDamage f cr w
     in fw $ w & creatures . at (_crID cr) .~ mcr
 
+stateUpdate' :: CRUpdate' -> Creature -> World -> World
+stateUpdate' f cr w = let (fw,mcr) = stateUpdateDamage' doDamage f cr w
+    in fw $ w & creatures . at (_crID cr) .~ mcr
+
 stateUpdateDamage :: (Creature -> Creature) -> CRUpdate -> CRUpdate
 stateUpdateDamage damageupdate u cr w = case u (updateMovement cr) w of
     (f, maybeCr) -> 
@@ -64,6 +69,25 @@ stateUpdateDamage damageupdate u cr w = case u (updateMovement cr) w of
         $ uncurryV translate (_crOldPos cr) 
         $ rotate (_crDir cr)
         (_crCorpse cr)
+stateUpdateDamage' :: (Creature -> Creature) -> CRUpdate' -> CRUpdate
+stateUpdateDamage' damageupdate u cr w = case u (updateMovement cr) w of
+    (f, upcr) -> 
+        ( invSideEff upcr . movementSideEff cr . deathEff . f
+        , (stepReloading . damageupdate) <$> crOrCorpse upcr
+        )
+  where   
+    crOrCorpse cr' 
+        | cr' ^. crHP > 0 = Just cr'
+        | otherwise      = Nothing
+    deathEff 
+        | cr ^.crHP > 0 = id
+        | otherwise = stopSoundFrom (CrWeaponSound (_crID cr) 0) 
+            . over decorations addCorpse 
+            . dropByState cr
+    addCorpse = IM.insertNewKey 
+        $ uncurryV translate (_crOldPos cr) 
+        $ rotate (_crDir cr)
+        (_crCorpse cr)
 -- | Drop items according to the creature state.
 dropByState :: Creature -> World -> World
 dropByState cr w = foldr (copyInvItemToFloor cr) w is

src/Dodge/Creature/Update.hs

@@ -3,10 +3,6 @@ module Dodge.Creature.Update
     ) where
 import Dodge.Data
 
-
-unrandUpdate 
-    :: (Creature -> World -> World) 
-    -> (Creature -> Maybe Creature)
-    -> CRUpdate
+unrandUpdate :: (Creature -> World -> World) -> (Creature -> Maybe Creature) -> CRUpdate
 {-# INLINE unrandUpdate #-}
-unrandUpdate h cF cr _ = ( (h cr) , cF cr )
+unrandUpdate h cF cr _ = ( h cr , cF cr )

src/Dodge/Data.hs

@@ -53,6 +53,8 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
 import SDL (Scancode, MouseButton)
 type CRUpdate = Creature -> World -> (World -> World, Maybe Creature)
+type CRUpdate' = Creature -> World -> (World -> World, Creature)
+
 data Universe = Universe
     { _uvWorld :: World
     , _preloadData          :: PreloadData
@@ -78,7 +80,7 @@ data World = World
     , _props                :: IM.IntMap Prop
     , _instantParticles     :: [Particle]
     , _particles            :: [Particle]
-    , _walls                :: (IM.IntMap Wall)
+    , _walls                :: IM.IntMap Wall
     , _doors                :: IM.IntMap Door
     , _machines             :: IM.IntMap Machine
     , _magnets              :: IM.IntMap Magnet
@@ -109,7 +111,7 @@ data World = World
     , _carteCenter          :: Point2
     , _carteZoom            :: Float
     , _carteRot             :: Float
-    , _lightSources         :: (IM.IntMap LightSource)
+    , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]
     , _closeObjects         :: [Either FloorItem Button]
     , _seenLocations        :: IM.IntMap (World -> Point2,String)

src/Dodge/RemoveCreatureEndo.hs

@@ -0,0 +1,15 @@
+-- | stopgap module, making creature update simpler
+-- should probably end up removed after further refactoring
+module Dodge.RemoveCreatureEndo 
+    (
+    toCrUpdate'
+    )where
+import Dodge.Data
+import Control.Lens
+
+toCrUpdate' :: (Creature -> World -> (World -> World, Maybe Creature))
+    -> Creature
+    -> World
+    -> World
+toCrUpdate' f cr w = let (fw,mcr) = f cr w
+    in fw $ w & creatures . at (_crID cr) .~ mcr