Rethink damage data type, work on damage sensors

src/Dodge/Creature/Impulse.hs

@@ -73,6 +73,7 @@ followImpulse cr w imp = case imp of
     cid  = _crID cr
     posFromID cid' = _crPos $ _creatures w IM.! cid'
     rr a = fst $ randomR (-a,a) $ _randGen w
-    hitCr i = (creatures . ix i . crState . crDamage %~ addDam i)
+    hitCr i = (creatures . ix i . crState . crDamage 
+        .:~ Damage Blunt 100 cpos (posFromID i) (posFromID i) NoDamageEffect
+        )
         . soundStart (CrSound cid) cpos hitS Nothing
-    addDam i = ( Blunt 100 cpos (posFromID i) (posFromID i) : )

src/Dodge/Creature/Inanimate.hs

@@ -85,18 +85,21 @@ updateExpBarrel cr w
          | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] (_crPos cr) foamSprayLoopS (Just 1)
     stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
 
-damToExpBarrel :: [DamageType] -> Creature -> Creature
+damToExpBarrel :: [Damage] -> Creature -> Creature
 damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
   where 
     (pierceDam,otherDam) = partition isPierce ds
-    isPierce Piercing{} = True
+    isPierce (Damage {_dmType = Piercing{}}) = True
     isPierce _             = False
 
-damToExpBarrel' :: DamageType -> Creature -> Creature
+damToExpBarrel' :: Damage -> Creature -> Creature
-damToExpBarrel' (Piercing amount _ int _) cr 
+damToExpBarrel' dm cr = case _dmType dm of
-    = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) 
+    Piercing -> over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) 
         $ over crHP (\hp -> hp - div amount 200) cr
-damToExpBarrel' PoisonDam {} cr = cr
+    PoisonDam -> cr
-damToExpBarrel' SparkDam {}  cr = cr
+    SparkDam -> cr
-damToExpBarrel' PushDam{_dmPushBack = v} cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
+    PushDam -> cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* (_dePushBack $ _dmEffect dm))
-damToExpBarrel' dt             cr = cr Control.Lens.& crHP -~ _dmAmount dt
+    dt  -> cr Control.Lens.& crHP -~ amount
+  where
+    amount = _dmAmount dm
+    int = _dmAt dm

src/Dodge/Creature/State.hs

@@ -88,7 +88,7 @@ doDamage cr = set (crState . crDamage) []
   where 
     dams = _crDamage $ _crState cr
 
-advancePastDamages :: [DamageType] -> V.Vector [DamageType] -> V.Vector [DamageType]
+advancePastDamages :: [Damage] -> V.Vector [Damage] -> V.Vector [Damage]
 advancePastDamages newDs v = f $ V.backpermute v bpVector
   where
     f = V.modify $ \v' -> MV.write v' 0 newDs

src/Dodge/Creature/State/Data.hs

@@ -11,8 +11,8 @@ import Control.Lens
 import qualified Data.IntSet as IS
 import qualified Data.Vector as V
 data CreatureState = CrSt 
-    { _crDamage  :: [DamageType]
+    { _crDamage  :: [Damage]
-    , _crPastDamage :: V.Vector [DamageType]
+    , _crPastDamage :: V.Vector [Damage]
     , _crSpState :: CrSpState
     , _crDropsOnDeath :: CreatureDropType
     }

src/Dodge/Data.hs

@@ -259,7 +259,7 @@ data Creature = Creature
     , _crLeftInvSel     :: Maybe Int
     , _crState          :: CreatureState
     , _crCorpse         :: Picture
-    , _crApplyDamage    :: [DamageType] -> Creature -> (World -> World,Creature)
+    , _crApplyDamage    :: [Damage] -> Creature -> (World -> World,Creature)
     , _crStance         :: Stance
     , _crActionPlan     :: ActionPlan
     , _crMeleeCooldown  :: Int
@@ -720,8 +720,9 @@ data Machine = Machine
     , _mcPos     :: Point2
     , _mcDir     :: Float
     , _mcHP      :: Int
-    , _mcSensor  :: Int
+    , _mcSensorAmount  :: Int
-    , _mcDamage  :: [DamageType]
+    , _mcSensorToggle  :: Bool
+    , _mcDamage  :: [Damage]
     , _mcLSs     :: [Int]
     , _mcType    :: MachineType
     }
@@ -772,7 +773,7 @@ data WallStructure
     | BlockPart   { _wlStBlock   :: Int }
     | CreaturePart 
         { _wlStCreature :: Int 
-        , _wlStDamCreature :: DamageType -> Wall -> Int -> World -> World
+        , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World
         }
 -- | Strict maybe
 data Maybe' a = Just' {__Just' :: a} | Nothing'

src/Dodge/Data/DamageType.hs

@@ -11,34 +11,48 @@ import Geometry.Data
 
 import Control.Lens
 
-data DamageType
+data DamageType = Piercing 
-    = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Blunt    
-    | Blunt    {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+    | Cutting  
-    | Cutting  {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+    | SparkDam 
-    | SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } 
+    | Flaming  
-    | Flaming  {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Lasering 
-    | Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Electrical
-    | Electrical {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
+    | Explosive
-    | Explosive {_dmAmount :: Int , _dmFrom :: Point2 }
     | Concussive
-        { _dmAmount :: Int 
+    | TorqueDam 
-        , _dmFrom :: Point2 
+    | PushDam   
-        , _dmPush :: Float 
+    | PoisonDam 
-        , _dmPushExp :: Float
-        , _dmPushRadius :: Float
-        }
-    | TorqueDam {_dmAmount :: Int , _dmTorque :: Float }
-    | PushDam   {_dmAmount :: Int , _dmPushBack :: Point2 }
-    | PoisonDam {_dmAmount :: Int}
   deriving (Eq,Ord,Show)
 
-isElectrical :: DamageType -> Bool
+data DamageEffect
-isElectrical Electrical {} = True
+    = PushDamage 
-isElectrical _ = False
+        { _dePush :: Float 
+        , _dePushExp :: Float
+        , _dePushRadius :: Float
+        }
+    | TorqueDamage { _deTorque :: Float }
+    | PushBackDamage {_dePushBack :: Point2 }
+    | NoDamageEffect
+  deriving (Eq,Ord,Show)
 
-isMovementDam :: DamageType -> Bool
+data Damage = Damage 
-isMovementDam TorqueDam{} = True
+    { _dmType :: DamageType
-isMovementDam PushDam{} = True
+    , _dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 
-isMovementDam _ = False
+    , _dmEffect :: DamageEffect
+    }
+  deriving (Eq,Ord,Show)
 
-makeLenses ''DamageType
+isElectrical :: Damage -> Bool
+isElectrical dm = case _dmType dm of
+    Electrical{} -> True
+    _ -> False
+
+isMovementDam :: Damage -> Bool
+isMovementDam dm = case _dmType dm of
+    TorqueDam{} -> True
+    PushDam{} -> True
+    _ -> False
+
+makeLenses ''Damage
+makeLenses ''DamageEffect

src/Dodge/Default.hs

@@ -183,35 +183,37 @@ defaultConsumable = Item
     , _itScope = NoScope
     , _itTargeting = NoTargeting
     }
-defaultApplyDamage :: [DamageType] -> Creature -> (World -> World, Creature)
+defaultApplyDamage :: [Damage] -> Creature -> (World -> World, Creature)
 defaultApplyDamage ds cr = (id, doPoisonDam $ foldl' (flip $ \d c -> snd $ applyIndividualDamage d c) cr ds')
   where 
     (ps,ds') = partition isPoison ds
-    isPoison PoisonDam{} = True
+    isPoison Damage{_dmType=PoisonDam} = True
     isPoison _ = False
     poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10
     doPoisonDam = over crHP (\hp -> hp - poisonDam)
 
-applyIndividualDamage :: DamageType -> Creature -> (World -> World, Creature)
+applyDamageEffect :: Damage -> DamageEffect -> Creature -> Creature
-applyIndividualDamage (Concussive amount fromDir push pushexp pushRad) cr
+applyDamageEffect dm de cr = case de of
-        = ( id
+    NoDamageEffect -> cr
-          , over crHP (\hp -> hp - amount) 
+    PushDamage push pushexp pushRad -> cr 
-                $ over crPos (+.+ (pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir))) 
+        & crPos %~ (+.+ (pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir))) 
-                cr
+      where
-          )
+        pushAmount
+            | dist (_crPos cr) fromDir == 0 = 0
+            | otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp
+    PushBackDamage pback -> cr
+        & crPos %~ (+.+ ((1/_crMass cr) *.* pback ))
+    TorqueDamage rot -> cr & crDir +~ rot
   where
-    pushAmount 
+    fromDir = _dmFrom dm
-        | dist (_crPos cr) fromDir == 0 = 0
+
-        | otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp
+applyIndividualDamage :: Damage -> Creature -> (World -> World, Creature)
-applyIndividualDamage (TorqueDam amount rot) cr
+applyIndividualDamage dm cr = ( id
-    = ( id
+    , cr
-      , over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr)
+      & crHP -~ _dmAmount dm
-applyIndividualDamage (PushDam amount pback) cr
+      & applyDamageEffect dm (_dmEffect dm)
-    = ( id
+    )
-      , over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr
+
-      )
-applyIndividualDamage dt cr 
-    = ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
 defaultFlIt :: FloorItem
 defaultFlIt = FlIt {_flItRot=0,_flIt = defaultConsumable, _flItPos = V2 0 0, _flItID = 0}
 defaultMachine :: Machine
@@ -223,7 +225,8 @@ defaultMachine = Machine
     , _mcPos = V2 0 0
     , _mcDir = 0
     , _mcHP = 1000
-    , _mcSensor = 0
+    , _mcSensorAmount = 0
+    , _mcSensorToggle = False
     , _mcDamage = []
     , _mcLSs = []
     , _mcType = StaticMachine

src/Dodge/Floor.hs

@@ -8,9 +8,11 @@ module Dodge.Floor
 import Dodge.LockAndKey
 --import Dodge.Creature.State.Data
 import Dodge.Room
+import Dodge.Data.DamageType
 --import Dodge.Placement.Instance.Button
 import Dodge.Tree
 import Dodge.Annotation
+import Dodge.Placement.Instance.Sensor
 --import Dodge.Creature
 --import Dodge.LevelGen.Data
 --import Dodge.LevelGen.Switch
@@ -34,7 +36,7 @@ import System.Random
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
---    , [SpecificRoom $ fmap (return . UseAll) lasTunnelRunnable]
+    , [SpecificRoom $ sensorRoom Flaming 50]
     , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [SpecificRoom randomChallenges]
     , [AnoApplyInt 1 lasSensorTurretTest]

src/Dodge/Item/Equipment.hs

@@ -118,12 +118,15 @@ shieldWall crid = defaultWall
     ,_wlStructure = CreaturePart crid shieldWallDamage
     }
 
-shieldWallDamage :: DamageType -> Wall -> Int -> World -> World
+shieldWallDamage :: Damage -> Wall -> Int -> World -> World
-shieldWallDamage dt wl crid w = case dt of
+shieldWallDamage dm wl crid w = case _dmType dm of
-    Lasering {_dmFrom=df,_dmAt=da} -> 
+    Lasering -> 
         w & instantParticles .:~ lasRayAt 5 (da +.+ normalizeV (df -.- da)) (reflDirWall df da wl)
-    d | isMovementDam d -> w & creatures . ix crid . crState . crDamage .:~ d
+    d | isMovementDam dm -> w & creatures . ix crid . crState . crDamage .:~ dm
     _ -> w
+  where
+    df = _dmFrom dm
+    da = _dmAt dm
 
 createShieldWall :: Creature -> Int -> World -> World
 createShieldWall cr invid w = case _itEffectID $ _itEffect it of

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -179,7 +179,7 @@ mvLaser :: Float    -- ^ Phase velocity, controls deflection through windows
     -> Particle 
     -> (World, Maybe Particle)
 mvLaser phasev pos dir w pt
-    = ( damThingHitWith (Lasering 19) pos xp thHit w
+    = ( damThingHitWith (\p1 p2 p3 -> Damage Lasering 19 p1 p2 p3 NoDamageEffect) pos xp thHit w
       , Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 }
       )
   where
@@ -190,7 +190,6 @@ mvLaser phasev pos dir w pt
         , setDepth 19.5 . color (brightX 10 1 yellow)  $ thickLine 3  (pos:ps)
         ]
 
-
 aTractorBeam :: Item -> Creature -> World -> World
 aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir
   where 

src/Dodge/Item/Weapon/SprayGuns.hs

@@ -171,7 +171,9 @@ overNozzles' eff it cr w = neww & creatures . ix cid . crInv . ix i . itParams .
 
 overNozzle :: (Nozzle -> Item -> Creature -> World -> World)
     -> Item -> Creature -> World -> Nozzle -> (World, Nozzle)
-overNozzle eff it cr w nz = (eff nz it (cr & crDir +~ wa + na) w & randGen .~ g,nz & nzCurrentWalkAngle .~ wa)
+overNozzle eff it cr w nz = 
+    ( eff nz it (cr & crDir +~ wa + na) w & randGen .~ g
+    , nz & nzCurrentWalkAngle .~ wa)
   where
     na = _nzDir nz
     (walkamount, g) = randomR (-aspeed,aspeed) (_randGen w)

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -26,8 +26,9 @@ bulHitCr bt p cr w
     sp = head $ _ptTrail bt
     bulVel = _ptVel bt
     ep = sp +.+ bulVel
-    mvDams = [ PushDam 1 $ 2 *.* bulVel ]
+    mvDams = [ Damage PushDam 1 sp p ep . PushBackDamage $ 2 *.* bulVel ]
-    addDamage = creatures . ix cid . crState . crDamage .++~ (Piercing 100 sp p ep : mvDams)
+    addDamage = creatures . ix cid . crState . crDamage .++~ 
+        (Damage Piercing 100 sp p ep NoDamageEffect : mvDams)
     addDamageArmoured = creatures . ix cid . crState . crDamage .++~ mvDams
     cid = _crID cr
     p1 = p +.+ 2 *.* squashNormalizeV (p -.- _crPos cr)
@@ -43,8 +44,9 @@ bulBounceArmCr' bt p cr w
     sp = head $ _ptTrail bt
     bulVel = _ptVel bt
     ep = sp +.+ bulVel
-    mvDams = [ PushDam 1 $ 2 *.* bulVel ]
+    mvDams = [ Damage PushDam 1 sp p ep . PushBackDamage $ 2 *.* bulVel ]
-    addDamage = creatures . ix cid . crState . crDamage .++~ (Piercing 100 sp p ep : mvDams)
+    addDamage = creatures . ix cid . crState . crDamage .++~ 
+        (Damage Piercing 100 sp p ep NoDamageEffect : mvDams)
     addDamageArmoured = creatures . ix cid . crState . crDamage .++~ mvDams
     cid = _crID cr
     newDir = squashNormalizeV (p -.- _crPos cr)
@@ -60,11 +62,12 @@ bulPenCr' bt p cr w = w
     & instantParticles .:~ piercer
     & bulletHitSound ep
     & creatures . ix cid . crState . crDamage .++~
-        [Piercing 50 sp p ep
+        damageGamut 50 50 d1 sp p ep
-        ,Blunt    50  sp p ep
+--        [Damage Piercing 50 sp p ep NoDamageEffect
-        ,TorqueDam 1 d1
+--        ,Damage Blunt    50  sp p ep NoDamageEffect
-        ,PushDam 1 $ 3 *.* (ep -.- sp)
+--        ,Damage TorqueDam 1 sp p ep $ TorqueDamage d1
-        ] 
+--        ,Damage PushDam 1 sp p ep . PushBackDamage $ 3 *.* (ep -.- sp)
+--        ] 
   where 
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
     cid = _crID cr
@@ -78,23 +81,33 @@ piercing, blunt, twisting and pushback damage all applied.  -}
 hvBulHitCr :: Particle -> Point2 -> Creature -> World -> World
 hvBulHitCr bt p cr w = w
     & creatures . ix cid . crState . crDamage .++~
-        [Piercing 200 sp p ep
+        damageGamut 200 100 d1 sp p ep
-        ,Blunt    100  sp p ep
+--        [Piercing 200 sp p ep
-        ,TorqueDam 1 d1
+--        ,Blunt    100  sp p ep
-        ,PushDam 1 $ 3 *.* (ep -.- sp)
+--        ,TorqueDam 1 d1
-        ] 
+--        ,PushDam 1 $ 3 *.* (ep -.- sp)
+--        ] 
     & bulletHitSound ep
   where 
     (d1,_)  = randomR (-0.7,0.7) $ _randGen w
     cid = _crID cr
     sp = head $ _ptTrail bt
     ep = sp +.+ _ptVel bt
+damageGamut :: Int -> Int -> Float -> Point2 -> Point2 -> Point2 
+    -> [Damage]
+damageGamut pdam bdam tor sp p ep = 
+    [Damage Piercing pdam sp p ep NoDamageEffect
+    ,Damage Blunt    bdam  sp p ep NoDamageEffect
+    ,Damage TorqueDam 1 sp p ep $ TorqueDamage tor
+    ,Damage PushDam 1 sp p ep . PushBackDamage $ 3 *.* (ep -.- sp)
+    ] 
+
 {- | Create a flamelet when hitting a creature.  -}
 bulIncCr :: Particle -> Point2 -> Creature -> World -> World
 bulIncCr bt p cr w = w
     & makeFlamelet p 20 v Nothing 3 20
     & bulletHitSound p
-    & creatures . ix cid . crState . crDamage .:~ Piercing 60 sp p ep
+    & creatures . ix cid . crState . crDamage .:~ Damage Piercing 60 sp p ep NoDamageEffect
   where   
     cid = _crID cr
     sp = head $ _ptTrail bt
@@ -102,7 +115,8 @@ bulIncCr bt p cr w = w
     v = evalState (randInCirc 1) $ _randGen w
 {- | Creates a shockwave when hitting a creature.  -}
 bulConCr :: Particle -> Point2 -> Creature -> World -> World
-bulConCr bt p cr = over (creatures . ix cid . crState . crDamage) (Blunt 10 sp p ep :)
+bulConCr bt p cr 
+    = over (creatures . ix cid . crState . crDamage) (Damage Blunt 10 sp p ep NoDamageEffect :)
     . makeShockwaveAt [] p 15 4 1 white
     . bulletHitSound p
   where   
@@ -111,13 +125,13 @@ bulConCr bt p cr = over (creatures . ix cid . crState . crDamage) (Blunt 10 sp p
     ep = sp +.+ _ptVel bt
 {- | Hitting wall effects: create a spark, damage blocks.  -}
 bulHitWall :: Particle -> Point2 -> Wall -> World -> World
-bulHitWall bt p = damageWall (Piercing 100 sp p ep)
+bulHitWall bt p = damageWall (Damage Piercing 100 sp p ep NoDamageEffect)
   where 
     ep = sp +.+ _ptVel bt
     sp = head $ _ptTrail bt
 {- | Bounce off walls, do damage to blocks.  -}
 bulBounceWall :: Particle -> Point2 -> Wall -> World -> World
-bulBounceWall bt p wl = damageWall (Blunt 50 sp p ep) wl 
+bulBounceWall bt p wl = damageWall (Damage Blunt 50 sp p ep NoDamageEffect) wl 
     . over instantParticles (bouncer :)
   where 
     ep = sp +.+ _ptVel bt
@@ -137,7 +151,7 @@ bulIncWall
     -> Wall 
     -> World 
     -> World
-bulIncWall bt p wl = damageWall (Blunt 50 sp p ep) wl 
+bulIncWall bt p wl = damageWall (Damage Blunt 50 sp p ep NoDamageEffect) wl 
     . makeFlamelet pOut 20 reflectVel Nothing 3 20
   where   
     ep = sp +.+ _ptVel bt
@@ -152,7 +166,7 @@ bulConWall
     -> Wall 
     -> World 
     -> World
-bulConWall bt p wl = damageWall (Blunt 10 sp p ep) wl .
+bulConWall bt p wl = damageWall (Damage Blunt 10 sp p ep NoDamageEffect) wl .
     makeShockwaveAt [] p 15 4 1 white
   where   
     ep = sp +.+ _ptVel bt
@@ -164,8 +178,8 @@ hvBulHitWall
     -> Wall 
     -> World 
     -> World
-hvBulHitWall bt p wl w = damageWall (Piercing 200 sp p ep) wl 
+hvBulHitWall bt p wl w = damageWall (Damage Piercing 200 sp p ep NoDamageEffect) wl 
-    . damageWall (Blunt 100 sp p ep) wl  
+    . damageWall (Damage Blunt 100 sp p ep NoDamageEffect) wl  
     $ set randGen g $ foldr ($) w (sparks pOut sv)
   where 
     ep = sp +.+ _ptVel bt

src/Dodge/Particle/Spark.hs

@@ -29,7 +29,8 @@ createBarrelSpark pos dir maycid time colid = instantParticles .:~ BulletPt
     , _ptHitEff = destroyOnImpact sparkEff noEff
     }
   where 
-    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage .:~ SparkDam 1 sp p ep
+    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage 
+        .:~ Damage SparkDam 1 sp p ep NoDamageEffect
       where
         sp = head (_ptTrail bt)
         ep = sp +.+ _ptVel bt
@@ -54,7 +55,8 @@ colSparkRandDir randDir time col pos baseDir w = w
         , _ptTimer = time
         , _ptHitEff = destroyOnImpact sparkEff noEff
         }
-    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage .:~ SparkDam 1 sp p ep
+    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage 
+        .:~ Damage SparkDam 1 sp p ep NoDamageEffect
       where 
         sp = head (_ptTrail bt)
         ep = sp +.+ _ptVel bt

src/Dodge/Particle/TeslaArc.hs

@@ -12,8 +12,8 @@ import Dodge.RandomHelp
 import Picture
 import Geometry
 import qualified IntMapHelp as IM
+import LensHelp
 
-import Control.Lens
 import System.Random
 import Control.Monad.State
 import Data.Function (on)
@@ -44,7 +44,8 @@ moveTeslaArc
 moveTeslaArc p d w pt
     | t == 2 = 
         (foldr damCrs w hitCrs & randGen .~ g & colSpark 8 nc q2 (argV sv)
-             & damThingHitWith (Electrical 50) q1 ((2 *.* q2) -.- q1) thHit
+             & damThingHitWith (\p1 p2 p3 -> Damage Electrical 50 p1 p2 p3 NoDamageEffect) 
+                    q1 ((2 *.* q2) -.- q1) thHit
         , Just $ pt & ptTimer -~ 1 & ptPoints .~ ps'
         )
     | t < 1     = (w , Nothing)
@@ -62,7 +63,8 @@ moveTeslaArc p d w pt
     f1 (E3x1 cr) = Just $ _crID cr
     f1 _         = Nothing
     hitCrs       = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
-    damCrs cid = over (creatures . ix cid . crState . crDamage) (Electrical 5 cpos cpos cpos :)
+    damCrs cid = creatures . ix cid . crState . crDamage 
+        .:~ Damage Electrical 5 cpos cpos cpos NoDamageEffect
       where 
         cpos = _crPos (_creatures w IM.! cid)
     q1 = last $ init ps'

src/Dodge/Placement/Instance/LightSource.hs

@@ -124,11 +124,12 @@ mntLSLampCol shp (V4 x y z _) wallp lampp = mntLSOn shp Nothing (defaultLS & lsP
     col = V3 x y z
 
 mntLSCond :: (Point2 -> Point3 -> Shape) 
-    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) 
+--    -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) 
+    -> PlacementSpot
     -> Placement
-mntLSCond shp shift = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ 
+mntLSCond shp ps = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ 
     mntLS shp 0 (V3 0 (-40) 90)
-    & plSpot .~ PSPos shift (const id) Nothing
+    & plSpot .~ ps
     -- note that this perhaps pushes the vshape light out too far
 
 mntLight :: Point2 -> Point2 -> Placement
@@ -136,11 +137,10 @@ mntLight a b = RandomPlacement $ do
     shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
     return $ mntLS shp a (addZ 90 b)
 
-mntLightLnkCond :: (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) 
+mntLightLnkCond :: PlacementSpot -> Placement
-    -> Placement
+mntLightLnkCond ps = RandomPlacement $ do
-mntLightLnkCond f = RandomPlacement $ do
     shp <- takeOne [vShape,iShape,lShape,jShape,liShape]
-    return $ mntLSCond shp f
+    return $ mntLSCond shp ps
 
 spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
 spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h)

src/Dodge/Placement/Instance/Sensor.hs

@@ -1,5 +1,6 @@
 module Dodge.Placement.Instance.Sensor
     ( lightSensor
+    , damageSensor
     ) where
 import Color
 import Dodge.LightSource
@@ -14,41 +15,42 @@ import Control.Lens
 import Data.Either
 
 damageSensor 
-    :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
+    :: DamageType -- Left gets sensed, Right does damage
     -> Float
     -> (Machine -> World -> World)
     -> PlacementSpot -> Placement
-damageSensor damF wdth upf ps = pContID ps ( PutLS theLS)
+damageSensor damF wdth upf ps = pContID ps (PutLS theLS)
     $ \lsid -> Just $ spNoID ps $ PutMachine yellow (reverse $ square wdth) defaultMachine
         { _mcDraw = sensorSPic wdth
-        , _mcUpdate = \mc w -> upf mc $ sensorUpdate damF mc w
+        , _mcUpdate = \mc -> upf mc . sensorUpdate damF mc
         , _mcLSs = [lsid]
         }
   where
     theLS = lsPosCol (V3 0 0 30) 0.1
 
 lightSensor :: Float -> (Machine -> World -> World) -> PlacementSpot -> Placement
-lightSensor = damageSensor senseLasering
+lightSensor = damageSensor Lasering
 
-senseLasering :: DamageType -> Either Int Int
+sensorUpdate :: DamageType -> Machine -> World -> World
-senseLasering Lasering {_dmAmount = x} = Left x
-senseLasering _ = Right 0
-
-sensorUpdate :: (DamageType -> Either Int Int) -> Machine -> World -> World
 sensorUpdate damF mc w = w & machines . ix mcid %~ upmc
     & lightSources . ix lsid %~ upls
   where
-    upmc = ( mcSensor %~ \x' -> min 1000 (max 0 (x' - 5 + newSense)) )
+    upmc = ( mcSensorAmount %~ \x' -> min 1000 (max 0 (x' - 5 + newSense)) )
         . ( mcHP -~ sum dam )
         . (mcDamage .~ [])
-    x = _mcSensor mc
+    x = _mcSensorAmount mc
     mcid = _mcID mc
     lsid = head (_mcLSs mc)
-    (senseData,dam) = partitionEithers $ map damF $ _mcDamage mc
+    (senseData,dam) = partitionEithers $ map (damageUsing damF) $ _mcDamage mc
     newSense = sum senseData
     ni = fromIntegral x / 1000
     upls = lsParam . lsCol .~ V3 ni ni ni
 
+damageUsing :: DamageType -> Damage -> Either Int Int
+damageUsing dt dm
+    | _dmType dm == dt = Left $ _dmAmount dm
+    | otherwise = Right 0
+
 sensorSPic :: Float -> Machine -> SPic
 sensorSPic wdth _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth)
     , mempty )

src/Dodge/Placement/Instance/Turret.hs

@@ -82,7 +82,7 @@ updateTurret rotSpeed mc w
             & creatures . ix cid . crPos .~ mcpos
             & creatures . ix cid . crDir .~ mcdir
     dodamage = machines . ix mcid %~ 
-        ( (mcDamage .~ [Electrical (min 2500 $ max 0 (elecDam - 10)) 0 0 0])
+        ( (mcDamage .~ [Damage Electrical (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect])
         . (mcHP -~ dam)
         )
     elecDamBranch

src/Dodge/PlacementSpot.hs

@@ -9,7 +9,6 @@ module Dodge.PlacementSpot
     , unusedSpotAwayFromLink
     , isUnusedLnk
     , isInLnk
-    , unusedLnkToPS
     , unusedSpotNearInLink
     , randDirPS
     , unusedSpotAwayFromInLink
@@ -21,8 +20,10 @@ module Dodge.PlacementSpot
     , setFallback
     , twoRoomPoss
     , isUnusedLinkType
-    , roomPosRoomBoolShift 
+    , rprBoolShift 
+    , rpBool
     , shiftInBy
+    , resetPLUse
     ) where
 import Dodge.LevelGen.Data
 import Geometry
@@ -46,19 +47,25 @@ randDirPS ps = do
     a <- state $ randomR (0,pi*2)
     return $ setDirPS a ps
 
-roomPosBool :: (RoomPos -> Bool) -> PlacementSpot
+rpBool :: (RoomPos -> Bool) -> PlacementSpot
-roomPosBool t = PSPos (useRoomPosCond t) (const id) Nothing
+rpBool t = PSPos (useRoomPosCond t) (const id) Nothing
 
 anyUnusedSpot :: PlacementSpot
-anyUnusedSpot = roomPosBool $ \rp -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0 
+anyUnusedSpot = rpBool $ \rp -> _rpLinkStatus rp == NotLink && _rpPlacementUse rp == 0 
 
-roomPosRoomBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
+rprBool :: (RoomPos -> Room -> Bool) -> PlacementSpot
-roomPosRoomBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
+rprBool t = PSPos (useRoomPosRoomCond t) (const id) Nothing
 
-roomPosRoomBoolShift :: (RoomPos -> Room -> Bool) 
+resetPLUse :: PlacementSpot -> PlacementSpot
+resetPLUse (PSPos f g fallback) = PSPos f' g fallback
+  where
+    f' rp = fmap (second (rpPlacementUse .~ 0)) . f rp
+resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"
+
+rprBoolShift :: (RoomPos -> Room -> Bool) 
     -> ((Point2,Float) -> (Point2,Float))
     -> PlacementSpot
-roomPosRoomBoolShift t shift = PSPos f (const id) Nothing
+rprBoolShift t shift = PSPos f (const id) Nothing
   where
     f rp r
         | t rp r    = Just (PS p a, rp & rpPlacementUse +~ 1)
@@ -67,22 +74,24 @@ roomPosRoomBoolShift t shift = PSPos f (const id) Nothing
         (p,a) = shift (_rpPos rp, _rpDir rp)
 
 unusedSpotAwayFromLink :: Float -> PlacementSpot
-unusedSpotAwayFromLink x = roomPosRoomBool $ \rp r -> _rpLinkStatus rp == NotLink 
+unusedSpotAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
     && _rpPlacementUse rp == 0 
     && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
 
 setFallback :: Placement -> Placement -> Placement
-setFallback fallback = (plSpot . psFallback %~ maybe (Just fallback) Just)
+setFallback fallback 
-    . (plIDCont %~ fmap (fmap $ setFallback fallback))
+    = (plSpot . psFallback %~ maybe (Just fallback) Just)
+    . (plIDCont %~ fmap (fmap $ setFallback fallback)
+    )
 
 unusedOffPathAwayFromLink :: Float -> PlacementSpot
-unusedOffPathAwayFromLink x = roomPosRoomBool $ \rp r -> _rpLinkStatus rp == NotLink 
+unusedOffPathAwayFromLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
     && _rpPlacementUse rp == 0 
     && all ( (>x) . dist (_rpPos rp) ) (usedRoomLinkPoss r)
     && RoomPosOffPath `S.member` _rpType rp
 
 unusedSpotAwayFromInLink :: Float -> PlacementSpot
-unusedSpotAwayFromInLink x = roomPosRoomBool $ \rp r -> _rpLinkStatus rp == NotLink 
+unusedSpotAwayFromInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink 
     && _rpPlacementUse rp == 0 
     && all ( (>x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
 
@@ -93,8 +102,8 @@ twoRoomPoss :: (RoomPos -> Bool)
     -> (RoomPos -> Bool)
     -> (PlacementSpot -> PlacementSpot -> Placement)
     -> Placement
-twoRoomPoss cond1 cond2 f = Placement (roomPosBool cond1) PutNothing Nothing
+twoRoomPoss cond1 cond2 f = Placement (rpBool cond1) PutNothing Nothing
-    $ \pl1 -> Just $ Placement (roomPosBool cond2) PutNothing Nothing
+    $ \pl1 -> Just $ Placement (rpBool cond2) PutNothing Nothing
     $ \pl2 -> Just $ f (_plSpot pl1) (_plSpot pl2)
 
 isUnusedLnk :: RoomPos -> Bool
@@ -108,7 +117,7 @@ isInLnk rp = case _rpLinkStatus rp of
     _ -> False
 
 useUnusedLnk :: PlacementSpot
-useUnusedLnk = roomPosBool isUnusedLnk
+useUnusedLnk = rpBool isUnusedLnk
 
 isUsedLnkUnplaced :: RoomPos -> Bool
 isUsedLnkUnplaced  rp = case _rpLinkStatus rp of
@@ -117,32 +126,20 @@ isUsedLnkUnplaced  rp = case _rpLinkStatus rp of
     _ -> False
 
 useRoomPosCond :: (RoomPos -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
-useRoomPosCond t rp _
+useRoomPosCond f = useRoomPosRoomCond $ \rp _ -> f rp
-    | t rp = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
-    | otherwise = Nothing
 
 useRoomPosRoomCond :: (RoomPos -> Room -> Bool) -> RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
 useRoomPosRoomCond t rp r
     | t rp r = Just (PS (_rpPos rp) (_rpDir rp), rp & rpPlacementUse +~ 1)
     | otherwise = Nothing
 
-unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
-unusedLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
-    UnusedLink {} -> True
-    _ -> False
-
---usedInLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
---usedInLnkToPS = useRoomPosCond $ \rp -> case _rpLinkStatus rp of
---    UsedInLink {} -> True
---    _ -> False
-
 isUnusedLinkType :: RoomLinkType -> RoomPos -> Bool
 isUnusedLinkType rlt rp = case _rpLinkStatus rp of
     UnusedLink{_rplsType = rlts} -> rlt `S.member` rlts
     _ -> False
 
 unusedSpotNearInLink :: Float -> PlacementSpot
-unusedSpotNearInLink x = roomPosRoomBool $ \rp r -> _rpLinkStatus rp == NotLink
+unusedSpotNearInLink x = rprBool $ \rp r -> _rpLinkStatus rp == NotLink
     && _rpPlacementUse rp == 0 
     && any ( (<x) . dist (_rpPos rp) ) (usedRoomInLinkPoss r)
 
@@ -162,17 +159,19 @@ usedRoomLinkPoss r = mapMaybe f $ _rmPos r
         _ -> Nothing
 
 atFstLnkOut :: PlacementSpot
-atFstLnkOut = roomPosBool $ \rp -> rp ^? rpLinkStatus . rplsChildNum == Just 0
+atFstLnkOut = rpBool $ \rp -> rp ^? rpLinkStatus . rplsChildNum == Just 0
 
 atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
-atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
+atNthLnkOutShiftBy n = rprBoolShift 
-  where
+    $ \ rp _ -> rp ^? rpLinkStatus . rplsChildNum == Just n
-    f rp _ = case _rpLinkStatus rp of
+--atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing
-        UsedOutLink {_rplsChildNum = i} | i == n 
+--  where
-            -> Just (PS p a, rp & rpPlacementUse +~ 1)
+--    f rp _ = case _rpLinkStatus rp of
-        _   -> Nothing
+--        UsedOutLink {_rplsChildNum = i} | i == n 
-      where
+--            -> Just (PS p a, rp & rpPlacementUse +~ 1)
-        (p,a) = theshift (_rpPos rp,_rpDir rp)
+--        _   -> Nothing
+--      where
+--        (p,a) = theshift (_rpPos rp,_rpDir rp)
 
 atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot
 atFstLnkOutShiftBy = atNthLnkOutShiftBy 0
@@ -181,9 +180,8 @@ atFstLnkOutShiftInward :: Float -> PlacementSpot
 atFstLnkOutShiftInward = atNthLnkOutShiftInward 0
 
 atNthLnkOutShiftInward :: Int -> Float -> PlacementSpot
-atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f
+atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n
-  where
+    $ \ (p,a) -> (p +.+ rotateV a (V2 0 (negate x)),a)
-    f (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)
 
 shiftInBy :: Float -> (Point2,Float) -> (Point2,Float)
 shiftInBy x (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a)

src/Dodge/Room.hs

@@ -20,6 +20,7 @@ module Dodge.Room
     , module Dodge.Room.GlassLesson
     , module Dodge.Room.Tanks
     , module Dodge.Room.Containing
+    , module Dodge.Room.SensorDoor
     ) where
 import Dodge.Room.Room
 import Dodge.Room.RoadBlock
@@ -41,3 +42,4 @@ import Dodge.Room.LongRoom
 import Dodge.Room.GlassLesson
 import Dodge.Room.Tanks
 import Dodge.Room.Containing
+import Dodge.Room.SensorDoor

src/Dodge/Room/Door.hs

@@ -28,12 +28,12 @@ door = defaultRoom
         ,uncurry inLink (V2 20  5,pi)
         ]
 
-switchDoorRoom :: Int -> Room
+triggerDoorRoom :: Int -> Room
-switchDoorRoom inplid = defaultRoom
+triggerDoorRoom inplid = defaultRoom
-    { _rmPolys = [rectNSWE 40 0 0 40]
+    { _rmPolys  = [rectNSWE 40 0 0 40]
-    , _rmLinks = init lnks++ [last lnks]
+    , _rmLinks  = init lnks++ [last lnks]
-    , _rmPath  = [(V2 20 35,V2 20 5)]
+    , _rmPath   = [(V2 20 35,V2 20 5)]
-    , _rmInPmnt = [InPlacement f  inplid]
+    , _rmInPmnt = [InPlacement f inplid]
 -- door extends into side walls (for shadows as rendered 12/03/21)
 -- note no bounds
     }

src/Dodge/Room/LasTurret.hs

@@ -33,8 +33,8 @@ import System.Random
 cenLasTur :: Room
 cenLasTur = roomNgon 8 200 & rmPmnts .~
     [ putLasTurret 0.02
-    , heightWallPS (roomPosRoomBoolShift (\rp _ -> isInLnk rp) (shiftInBy 100)) 30 covershape
+    , heightWallPS (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100)) 30 covershape
-    , mntLightLnkCond unusedLnkToPS
+    , mntLightLnkCond $ rpBool isInLnk
     ]
   where
     covershape = rectNSEW 10 (-10) 20 (-20)
@@ -53,7 +53,7 @@ lasSensLightAboveDoor wth ps = extTrigLitPos
     (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
     ( \tp -> Just $ lightSensor wth (upf $ fromJust $ _plMID tp) ps )
   where
-    upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True
+    upf trid mc w | _mcSensorAmount mc > 900 = w & triggers . ix trid .~ const True
         | otherwise = w
 
 lightSensByDoor :: Int -> Room -> Room
@@ -72,13 +72,13 @@ lightSensByDoor outplid rm = rm
 lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room)
 lasSensorTurretTest n = do
     cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
-    let doorroom = switchDoorRoom n
+    let doorroom = triggerDoorRoom n
     return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
 
 lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room)
 lasCenSensEdge n = do
     cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
-    let doorroom = switchDoorRoom n
+    let doorroom = triggerDoorRoom n
     return $ treeFromTrunk [PassDown door] $ Node (PassDown cenroom) 
         [ treeFromPost [PassDown doorroom] (UseAll door)
         , treeFromPost [PassDown door]     (UseLabel 0 corridor)

src/Dodge/Room/Procedural.hs

@@ -101,7 +101,7 @@ roomRectAutoLinks :: Float -> Float -> Room
 roomRectAutoLinks x y = (roomRect x y (f x) (f y)) {_rmPmnts = plmnts}
   where
     f z = max 1 $ (ceiling z - 40) `div` 60
-    plmnts = replicate 3 . mntLightLnkCond $ useRoomPosCond isUsedLnkUnplaced
+    plmnts = [mntLightLnkCond $ resetPLUse $ rpBool isInLnk]
 {- Combines two rooms into one room.
  - will have to work out exactly what to do with combining links
 Mostly involves concatenation.  -}

src/Dodge/Room/Room.hs

@@ -156,8 +156,8 @@ roomCenterPillar = randomiseAllLinks . restrictInLinks ((\p -> dist p (V2 120 0)
         , blockLine (V2 125 115) (V2 125 125)
         --, sPS (V2 40 120) 0 putLamp
         --, sPS (V2 200 120) 0 putLamp
-        , mntLightLnkCond unusedLnkToPS
+        , mntLightLnkCond useUnusedLnk
-        , mntLightLnkCond unusedLnkToPS
+        , mntLightLnkCond useUnusedLnk
         ]
 
 roomOctogon :: Room
@@ -187,7 +187,7 @@ roomNgon n x = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = muout (init lnks) ++ muin[last lnks]
     , _rmPath  = [] -- TODO
-    , _rmPmnts = []
+    , _rmPmnts = [mntLightLnkCond $ resetPLUse $ rpBool isInLnk]
     , _rmBound = [poly]
     , _rmFloor = Tiled [makeTileFromPoly poly 9]
     , _rmName = show n ++ "gon"
@@ -225,7 +225,7 @@ weaponEmptyRoom = do
             ,sPS   (V2 20 20) (pi/2) randC1
             ,sPS (V2 (w-20) 20) (pi/2) randC1
             --,sPS (V2 (w/2) (h/2))      0 putLamp
-            ,mntLightLnkCond unusedLnkToPS
+            ,mntLightLnkCond useUnusedLnk
             ]
         f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
     rm <- shuffleLinks $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
@@ -396,7 +396,7 @@ pillarGrid = do
 --        cornerRestrict (V2 x y,_)
 --             = (x > 40 && x < h - 40)
 --            || (y > 40 && y < h - 40)
-    let plmnts = replicate 8 (mntLightLnkCond unusedLnkToPS)
+    let plmnts = replicate 8 (mntLightLnkCond useUnusedLnk)
                   ++ 
                  concat [f x y | x<-xs,y<-ys]
     return $ roomRect w h (max i 2) (max i 2)

src/Dodge/Room/RunPast.hs

@@ -60,7 +60,7 @@ runPastRoom i = do
             {_rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i]
             ,_rmPmnts = []
             }
-        switchdoor = switchDoorRoom i 
+        switchdoor = triggerDoorRoom i 
         n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom
         controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door)
         critrooms :: [SubCompTree Room]

src/Dodge/Room/SensorDoor.hs

@@ -0,0 +1,57 @@
+module Dodge.Room.SensorDoor where
+import Dodge.LevelGen.Data
+import Dodge.PlacementSpot
+import Dodge.Data
+import Dodge.Tree
+--import Dodge.RoomLink
+import Dodge.Room.Door
+import Dodge.Room.Procedural
+import Dodge.Room.Room
+--import Dodge.Room.Corridor
+import Dodge.Room.Link
+--import Dodge.Room.Procedural
+import Dodge.Room.Foreground
+--import Dodge.Room.RoadBlock
+import Dodge.Placement.Instance
+--import Dodge.Default.Room
+--import Dodge.Item.Weapon.BulletGuns
+--import Dodge.Item.Weapon.Utility
+--import Dodge.LevelGen.Data
+--import Geometry.Data
+import Geometry
+--import Padding
+import Color
+import Shape
+import LensHelp
+import Dodge.RandomHelp
+
+--import qualified Data.Set as S
+import Data.Maybe
+--import Data.Tree
+import Control.Monad.State
+import System.Random
+
+sensorRoom :: RandomGen g => DamageType -> Int -> State g (SubCompTree Room)
+sensorRoom senseType n = do
+    rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
+    cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
+    let doorroom = triggerDoorRoom n
+    return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
+
+
+sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
+sensAboveDoor sensetype wth ps = extTrigLitPos 
+    (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
+    ( \tp -> Just $ damageSensor sensetype wth (upf $ fromJust $ _plMID tp) ps )
+  where
+    upf trid mc w | _mcSensorAmount mc > 900 = w & triggers . ix trid .~ const True
+        | otherwise = w
+
+sensInsideDoor :: DamageType -> Int -> Room -> Room
+sensInsideDoor senseType outplid rm = rm 
+    & rmPmnts .:~ psPt atFstLnkOut 
+        (PutShape $ colorSH yellow $
+        thinHighBar 0 (V2 20 (-1)) (V2 20 (-100))
+        <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100))
+        <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80))
+    & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]

src/Dodge/Wall/Damage.hs

@@ -13,7 +13,7 @@ import Geometry
 import Color
 import LensHelp
 
-damageWall :: DamageType -> Wall -> World -> World
+damageWall :: Damage -> Wall -> World -> World
 damageWall dt wl = case _wlStructure wl of
     MachinePart mcid -> wallEff dt wl . (machines . ix mcid . mcDamage .:~ dt)
     BlockPart blid   -> wallEff dt wl . (blocks . ix blid %~ damageBlockWith dt)
@@ -21,33 +21,35 @@ damageWall dt wl = case _wlStructure wl of
     _   -> wallEff dt wl
 {- | Damage effects on indestructible walls -}
 -- TODO take into account damage amount for amount of dust/sparks?
-wallEff :: DamageType -> Wall -> World -> World
+wallEff :: Damage -> Wall -> World -> World
-wallEff dt wl = case dt of
+wallEff dm wl = case _dmType dm of
-    Lasering _ sp p _ -> colSpark 8 lSparkCol (outTo sp p) (reflDirWall sp p wl)
+    Lasering -> colSpark 8 lSparkCol outTo (reflDirWall sp p wl)
-    Piercing _ sp p _ -> colSparkRandDir 0.2 8 pSparkCol (outTo sp p) (reflDirWall sp p wl)
+    Piercing -> colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl)
-        . wlDustAt wl (outTo sp p)
+        . wlDustAt wl outTo
-    Blunt    _ sp p _ -> wlDustAt wl (outTo sp p)
+    Blunt    -> wlDustAt wl outTo
-    Explosive _ _ -> id
+    Explosive-> id
-    Cutting {} -> id
+    Cutting -> id
-    SparkDam {} -> id
+    SparkDam -> id
-    Flaming  {} -> id
+    Flaming  -> id
-    Electrical {} -> id
+    Electrical -> id
-    Concussive {} -> id
+    Concussive -> id
-    TorqueDam {} -> id
+    TorqueDam -> id
-    PushDam {} -> id
+    PushDam -> id
-    PoisonDam {} -> id
+    PoisonDam -> id
   where
-    outTo sp p = p +.+ squashNormalizeV (sp -.- p)
+    sp = _dmFrom dm
+    p = _dmTo dm
+    outTo = p +.+ squashNormalizeV (sp -.- p)
     pSparkCol = brightX 100 1.5 white
     lSparkCol = V4 20 (-5) 0 1
 
-damageBlockWith :: DamageType -> Block -> Block
+damageBlockWith :: Damage -> Block -> Block
-damageBlockWith dt = case dt of
+damageBlockWith dm = case _dmType dm of
-    Piercing dam _ _ _ -> blHPs %~ reduceHead dam
+    Piercing -> blHPs %~ reduceHead dam
-    Blunt    dam _ _ _ -> blHPs %~ reduceHead dam
+    Blunt    -> blHPs %~ reduceHead dam
-    Cutting  dam _ _ _ -> blHPs %~ reduceHead dam
+    Cutting  -> blHPs %~ reduceHead dam
-    Explosive dam _    -> blHPs %~ reduceHead dam
+    Explosive -> blHPs %~ reduceHead dam
-    Concussive dam _ _ _ _ -> blHPs %~ reduceHead dam
+    Concussive -> blHPs %~ reduceHead dam
     Lasering {} -> id
     SparkDam {} -> id
     Flaming {} -> id
@@ -55,6 +57,8 @@ damageBlockWith dt = case dt of
     TorqueDam {} -> id
     PushDam {} -> id
     PoisonDam {} -> id
+  where
+    dam = _dmAmount dm
 
 reduceHead :: Int -> [Int] -> [Int]
 reduceHead y (x:xs) = x-y:xs

src/Dodge/WorldEvent/Damage.hs

@@ -4,17 +4,16 @@ module Dodge.WorldEvent.Damage
 import Dodge.Data
 import Geometry
 import Dodge.Wall.Damage
-
+import LensHelp
-import Control.Lens
 
 damThingHitWith 
-    :: (Point2 -> Point2 -> Point2 -> DamageType)
+    :: (Point2 -> Point2 -> Point2 -> Damage)
     -> Point2
     -> Point2
     -> Maybe (Point2, Either Creature Wall)
     -> World 
     -> World
 damThingHitWith partDT sp ep mayEiCrWl = case mayEiCrWl of
-    Just (hitp,Left cr )  -> creatures . ix (_crID cr) . crState . crDamage %~ (partDT sp hitp ep :)
+    Just (hitp,Left  cr) -> creatures . ix (_crID cr) . crState . crDamage .:~ partDT sp hitp ep
     Just (hitp,Right wl) -> damageWall (partDT sp hitp ep) wl
     Nothing -> id

src/Dodge/WorldEvent/HitEffect.hs

@@ -63,7 +63,7 @@ penWalls crEff wlEff pt hitThings w = case hitThings of
 
 doFlameDam :: Int -> Particle -> Point2 -> Creature -> World -> World
 doFlameDam amount pt p cr = creatures . ix (_crID cr) . crState . crDamage .:~
-    Flaming amount sp p ep
+    Damage Flaming amount sp p ep NoDamageEffect
   where 
     sp = _ptPos pt
     ep = sp +.+ _ptVel pt

src/Dodge/WorldEvent/Shockwave.hs

@@ -60,13 +60,17 @@ mvShockwave is w pt
     t    = _ptTimer pt
     tFraction = fromIntegral t / fromIntegral (_ptMaxTime pt)
     rad = r - (3/4) * r * tFraction
-    doDams = over creatures (IM.map damCr) . flip (IM.foldl' (flip $ damageWall (Explosive 10000 p))) 
+    doDams = over creatures (IM.map damCr) 
+        . flip (IM.foldl' (flip $ damageWall (Damage Explosive 10000 p p p NoDamageEffect))) 
         hitBlocks
     hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w 
     damCr cr 
         | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr  = cr
         | otherwise = cr & crState . crDamage .:~
-            PushDam dam (25 * push *.* squashNormalizeV (_crPos cr -.- p))
+            Damage PushDam dam cpos cpos cpos 
+                (PushBackDamage (25 * push *.* squashNormalizeV (_crPos cr -.- p)))
+          where
+            cpos = _crPos cr
 {- Create a shockwave going from an outside circle into a center point.  -}
 inverseShockwaveAt 
     :: Point2   -- Center position
@@ -103,7 +107,9 @@ moveInverseShockwave w pt
     damCr cr 
         | dist (_crPos cr) p >= rad + _crRad cr = cr
         | otherwise = cr & crState . crDamage .:~
-            PushDam 1 (25 *.* squashNormalizeV (p -.- _crPos cr))
+            Damage PushDam 1 cpos cpos cpos (PushBackDamage $ 25 *.* squashNormalizeV (p -.- cpos))
+          where
+            cpos = _crPos cr
 
 drawInverseShockwave :: Particle -> Picture
 drawInverseShockwave  pt 

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -12,6 +12,7 @@ import Dodge.WorldEvent.Cloud
 import Dodge.WorldEvent.Flash
 import Dodge.SoundLogic
 import Dodge.RandomHelp
+import Dodge.Wall.Damage
 import Picture
 import Geometry
 import qualified IntMapHelp as IM
@@ -27,16 +28,17 @@ aFlameParticle
     -> Maybe Int -- ^ Creature id
     -> Particle
 aFlameParticle t pos vel maycid = PtZ
-    { _ptDraw         = drawFlame vel
+    { _ptDraw       = drawFlame vel
-    , _ptUpdate       = moveFlame vel
+    , _ptUpdate     = moveFlame vel
-    , _ptVel          = vel
+    , _ptVel        = vel
-    , _ptColor        = red
+    , _ptColor      = red
-    , _ptPos         = pos
+    , _ptPos        = pos
-    , _ptCrIgnore = maycid
+    , _ptCrIgnore   = maycid
-    , _ptWidth       = 4
+    , _ptWidth      = 4
-    , _ptTimer       = t
+    , _ptTimer      = t
-    , _ptHitEff   = destroyOnImpact (doFlameDam 1) noEff
+    , _ptHitEff     = destroyOnImpact (doFlameDam 1) 
-    , _ptZ            = 20
+        (\_ p -> damageWall (Damage Flaming 19 p p p NoDamageEffect))
+    , _ptZ           = 20
     }
 drawFlame
     :: Point2 -- ^ Rotate direction
@@ -44,9 +46,9 @@ drawFlame
     -> Picture
 drawFlame rotd pt = pictures
     [ glow 
-    , aPic 3 prot2 25 (V2 (scaleChange + 1)   2  ) $ V4 2 (-1)  (-1) 0.5
+    , aPic 3 prot2 25 (V2 (scaleChange + 1)   2  ) $ V4 2 (-1) (-1) 0.5
-    , aPic 3 prot  22 (V2 (scaleChange + 0.5) 1) $ V4 1 0.5 0 2
+    , aPic 3 prot  22 (V2 (scaleChange + 0.5) 1  ) $ V4 1 0.5    0  2
-    , aPic 1 prot3 20 (V2  scaleChange        0.5  ) $ V4 1 1   1 1
+    , aPic 1 prot3 20 (V2  scaleChange        0.5) $ V4 1 1      1  1
     ]
   where
     ep = _ptPos pt
@@ -69,17 +71,16 @@ drawFlame rotd pt = pictures
     prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1)
     prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2)
 {- TODO: add generalised area damage particles/hiteffects.  -}
-moveFlame 
+moveFlame :: Point2   -- ^ Rotation direction
-    :: Point2   -- ^ Rotation direction
     -> World 
     -> Particle
     -> (World, Maybe Particle)
 moveFlame rotd w pt 
     | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
     | otherwise = case thingsHitExceptCr (_ptCrIgnore pt) sp ep w of
-        ((_,Left _):_)       -> (doSound damcrs        , mvPt 0.7)
+        ((_,Left _):_)      -> (doSound damcrs                      , mvPt 0.7)
-        (thing@(p,Right wl):_) -> (doSound . fst $ hiteff [thing] damcrs , rfl wl p)
+        (th@(p,Right wl):_) -> (doSound . fst $ hiteff [th] damcrs  , rfl wl p)
-        _                     -> (flameFlicker pt $ doSound damcrs        , mvPt 0.98)
+        _                   -> (flameFlicker pt $ doSound damcrs    , mvPt 0.98)
   where 
     time = _ptTimer pt
     doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2)
@@ -98,7 +99,7 @@ moveFlame rotd w pt
     angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi )
     hiteff = _ptHitEff pt pt
     rfl wl p = Just $ pt 
-        { _ptTimer = time -1
+        { _ptTimer = time - 1
         , _ptPos = pOut p
         , _ptVel = reflV wl
         }
@@ -195,7 +196,7 @@ moveFlamelet w pt
     damcrs = w & creatures %~ IM.map damifclose
     isClose cr = dist ep (_crPos cr) < _crRad cr + size
     damifclose cr 
-        | isClose cr = cr & crState . crDamage .:~ Flaming 3 sp ep ep
+        | isClose cr = cr & crState . crDamage .:~ Damage Flaming 3 sp ep ep NoDamageEffect
         | otherwise  = cr
 -- | At writing the radius is half the size of the effect area
 makeGasCloud 
@@ -223,6 +224,7 @@ makeGasCloud pos vel w = w
 cloudPoisonDamage :: Cloud -> World -> World
 cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
   where 
-    damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (stripZ $ _clPos c) w
+    damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint clpos w
     f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
-    doDam cr = cr & crState . crDamage .:~ PoisonDam 1
+    doDam cr = cr & crState . crDamage .:~ Damage PoisonDam 1 clpos clpos clpos NoDamageEffect
+    clpos = stripZ $ _clPos c