Cleanup

There are probably possible errors from the use of cutPoly

src/Dodge/Barreloid.hs

@@ -29,8 +29,8 @@ updateExpBarrel ps cr w = case cr ^. crHP of
             & flip (foldl' f) ps
     HP _ ->
         w
-            & makeExplosionAt ((cr ^. crPos) & _z +~ 20) 0
+            & makeExplosionAt (CrIndirectO (cr ^. crID)) ((cr ^. crPos) & _z +~ 20) 0
-            & cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ CrDestroyed Gibbed
+            & cWorld . lWorld . creatures . at (_crID cr) .~ Nothing
     _ -> w
   where
     f w' p = makeSpark NormalSpark (p + normalizeV p + cr ^. crPos . _xy) (argV p) w'
@@ -43,7 +43,7 @@ updateExpBarrel ps cr w = case cr ^. crHP of
 updateBarrel :: Creature -> World -> World
 updateBarrel cr = case cr ^. crHP of
     HP x | x > 0 -> doDamage (cr ^. crID)
-    HP _ -> cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ CrDestroyed Gibbed
+    HP _ -> cWorld . lWorld . creatures . at (_crID cr) .~ Nothing
     _ -> id
 
 damsToExpBarrel :: [Damage] -> Creature -> Creature
@@ -51,7 +51,7 @@ damsToExpBarrel = flip $ foldl' damToExpBarrel
 
 damToExpBarrel :: Creature -> Damage -> Creature
 damToExpBarrel cr dm = case dm of
-    Piercing x p _ ->
+    Piercing x p _ _ ->
         cr & crHP . _HP -~ div x 200
             & crType . barrelType . piercedPoints .:~ (p - cr ^. crPos . _xy)
     Poison{} -> cr

src/Dodge/Base/Collide.hs

@@ -36,6 +36,7 @@ module Dodge.Base.Collide (
     crHeight,
 ) where
 
+import AesonHelp
 import Control.Applicative
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
@@ -192,12 +193,13 @@ crHeight cr = case cr ^. crHP of
         Avatar {} -> 25
         CrabCrit {} -> 25
         SlinkCrit {} -> 25
-        SlimeCrit {_slimeRad = r} -> min 15 r
+        SlimeCrit {_slimeSlime = r} -> min 15 $ slimeToRad r
         BeeCrit {} -> 10
         HiveCrit {} -> 25
-        _ -> error "Need to define crHeight for this crType"
+        BarrelCrit{} -> 20
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
     CrIsCorpse{} -> Just 5
-    CrDestroyed{} -> Nothing
+    AvatarDestroyed{} -> Nothing
 
 wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
 wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])

src/Dodge/Bullet.hs

@@ -119,15 +119,17 @@ useBulletPayload bu = case _buPayload bu of
     BulPlain _ -> const id
     BulFlak -> makeFlak bu
     BulFrag -> makeFragBullets
-    BulGas -> (`makeGasCloud` V2 0 0)
+    BulGas -> (\p -> makeGasCloud o p (V2 0 0))
-    BulBall ExplosiveBall -> makeMovingEB (_buVel bu) ExplosiveBall
+    BulBall eb@ExplosiveBall{} -> makeMovingEB (_buVel bu) eb o
     BulBall ElectricalBall{} ->
         makeMovingEB
             (_buVel bu)
-            (ElectricalBall (round $ bu ^. buPos . _1))
+            (ElectricalBall (round $ bu ^. buPos . _1)) o
-    BulBall FlashBall -> makeMovingEB (_buVel bu) FlashBall
+    BulBall eb@FlashBall{} -> makeMovingEB (_buVel bu) eb o
-    BulBall (FlameletBall x) -> makeMovingEB (_buVel bu) (FlameletBall x)
+    BulBall eb@FlameletBall{} -> makeMovingEB (_buVel bu) eb o
-    BulBall IncendiaryBall -> makeMovingEB (_buVel bu) IncendiaryBall
+    BulBall eb@IncendiaryBall{} -> makeMovingEB (_buVel bu) eb o
+  where
+    o = bu ^. buOrigin
 
 makeFragBullets :: Point2 -> World -> World
 makeFragBullets p w = w & cWorld . lWorld . bullets .++~ bus
@@ -172,8 +174,8 @@ hitEffFromBul w bu = case _buEffect bu of
 
 getBulHitDams :: Bullet -> Point2 -> [Damage]
 getBulHitDams bu p = case _buPayload bu of
-    BulPlain x -> [Piercing x p v
+    BulPlain x -> [Piercing x p v (bu ^. buOrigin)
-        ,Inertial 0 p v]
+        ,Inertial 0 p v (bu ^. buOrigin)]
     _ -> []
   where
     v = _buVel bu

src/Dodge/Creature.hs

@@ -12,7 +12,6 @@ module Dodge.Creature (
     module Dodge.Creature.Perception,
     module Dodge.Creature.ReaderUpdate,
     module Dodge.Creature.State,
-    module Dodge.Creature.Strategy,
     module Dodge.Creature.Test,
     module Dodge.Creature.Volition,
     module Dodge.Creature.YourControl,
@@ -35,7 +34,6 @@ import Dodge.Creature.Perception
 import Dodge.Creature.ReaderUpdate
 import Dodge.Creature.SpreadGunCrit
 import Dodge.Creature.State
-import Dodge.Creature.Strategy
 import Dodge.Creature.Test
 import Dodge.Creature.Volition
 import Dodge.Creature.YourControl

src/Dodge/Creature/Action.hs

@@ -84,7 +84,7 @@ performAction cr w ac = case ac of
 --    DoActions acs ->
 --        let (imps, newAcs) = foldMap (performAction cr w) acs
 --         in (imps, newAcs)
-    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], NoAction)
+--    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], NoAction)
     PathTo p a -> performPathTo a cr w p
     EvadeAim -> tryEvadeSideways cr w
     TurnToPoint p -> performTurnToA cr p
@@ -92,8 +92,8 @@ performAction cr w ac = case ac of
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
         return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], NoAction)
-    UseSelf f -> performAction cr w $ doCrAc f cr
+--    UseSelf f -> performAction cr w $ doCrAc f cr
-    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
+--    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
     DoImpulsesAlongside sideImp mainAc -> performAction cr w mainAc & _1 <>~ sideImp
     DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
     DoReplicatePartial _ 0 pac -> performAction cr w pac
@@ -147,6 +147,8 @@ crMoveImpulses cr p = case crMvType cr of
     MvWalking {} -> [MvTurnToward p, MvForward]
     JitMvType {_mvTurnJit = x} -> [MvTurnToward p, MvForward, RandomTurn x]
     StartStopMvType {} -> [MvTurnToward p, MvForward]
+    BeeMvType {} | cr ^?! crType . startStopMv == 0 -> [SetBeeRandomMovement, MvForward, MvTurnToward p]
+    BeeMvType {} -> [MvTurnToward p, MvForward]
 
 performTurnToA :: Creature -> Point2 -> ActionUpdate
 performTurnToA cr p

src/Dodge/Creature/Action/Blink.hs

@@ -29,7 +29,7 @@ blinkActionMousePos cr w =
         & blinkDistortions cpos p3
         & cWorld . lWorld . creatures . ix cid . crPos . _xy .~ p3
         & blinkShockwave cid p3
-        & inverseShockwaveAt (cpos `v2z` 20) 40 2 2
+        & inverseShockwaveAt (cpos `v2z` 20) 40 2 2 (CrIndirectO cid)
   where
     cid = _crID cr
     p1 = w ^. cWorld . lWorld . lAimPos
@@ -63,11 +63,11 @@ unsafeBlinkAction cr w
             . blinkDistortions cpos mwp
             . set (cWorld . lWorld . creatures . ix cid . crPos . _xy) mwp
             . blinkShockwave cid mwp
-            $ inverseShockwaveAt (cpos `v2z` 20) 40 2 2 w
+            $ inverseShockwaveAt (cpos `v2z` 20) 40 2 2 (CrIndirectO cid) w 
     | otherwise =
         w
             & blinkActionFail cr
-            & cWorld . lWorld . creatures . ix cid . crDamage .:~ Enterrement 100000000
+            & cWorld . lWorld . creatures . ix cid . crDamage .:~ Enterrement 100000000 (CrIndirectO cid)
   where
     success = fromMaybe True $ do
         wl <- snd $ collidePointWallsFilter (const True) mwp cpos w
@@ -82,7 +82,7 @@ blinkShockwave ::
     Point2 ->
     World ->
     World
-blinkShockwave i p = makeShockwaveAt [i] (p `v2z` 20) 60 1 2 cyan
+blinkShockwave i p = makeShockwaveAt [i] (p `v2z` 20) 60 1 2 cyan (CrIndirectO i)
 
 -- | Like a blink action, but no ingoing distortion
 blinkActionFail :: Creature -> World -> World
@@ -91,7 +91,7 @@ blinkActionFail cr w =
         & soundMultiFrom [TeleSound 0, TeleSound 1] p3 teleS Nothing
 --        & cWorld . lWorld . distortions .:~ distortionBulge
         & cWorld . lWorld . creatures . ix cid . crPos . _xy .~ p3
-        & inverseShockwaveAt (cpos `v2z` 20) 40 2 2
+        & inverseShockwaveAt (cpos `v2z` 20) 40 2 2 (CrIndirectO cid)
   where
 --    distR = 120
 --    distortionBulge = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9

src/Dodge/Creature/ArmourChase.hs

@@ -24,7 +24,7 @@ flockArmourChaseCrit =
             ActionPlan
                 { _apAction = NoAction
                 , _apStrategy = FollowImpulses
-                , _apGoal = [Kill 0]
+                , _apGoal = Kill 0
                 }
         , _crGroup = ShieldGroup
 --        , _crMvType = defaultChaseMvType

src/Dodge/Creature/ChaseCrit.hs

@@ -69,13 +69,14 @@ slimeCrit :: Creature
 slimeCrit = defaultCreature
         & crName .~ "slimeCrit"
         & crHP .~ HP 1000
-        & crType .~ SlimeCrit r 0 0 (V2 r 0) False 0
+--        & crType .~ SlimeCrit r 0 0 (V2 (slimeToRad r) 0) False 0
+        & crType .~ SlimeCrit r 0 Nothing 1 False 0
         & crFaction .~ ColorFaction (light green)
         & crPerception . cpVision . viFOV .~ FloatFOV pi
         & crActionPlan .~ SlimeIntelligence
         & crStance . carriage .~ Crawling
   where
-    r = 50
+    r = 250000
 
 hoverCrit :: Creature
 hoverCrit =
@@ -91,7 +92,7 @@ beeCrit =
     defaultCreature
         & crName .~ "beeCrit"
         & crHP .~ HP 100
-        & crType .~ BeeCrit 0 Nothing 0 0
+        & crType .~ BeeCrit 0 Nothing 0 0 0 Nothing 1
         & crFaction .~ ColorFaction yellow
         & crStance . carriage .~ Flying 15
 
@@ -100,6 +101,6 @@ hiveCrit =
     defaultCreature
         & crName .~ "hiveCrit"
         & crHP .~ HP 100000
-        & crType .~ HiveCrit mempty 0
+        & crType .~ HiveCrit mempty 0 400
         & crStance . carriage .~ Rooted
         & crFaction .~ ColorFaction yellow

src/Dodge/Creature/Damage.hs

@@ -12,32 +12,17 @@ import Dodge.Data.World
 --import Geometry
 import LensHelp
 
-applyCreatureDamage :: [Damage] -> Creature -> World -> World
+applyCreatureDamage :: Int -> Creature -> World -> World
-applyCreatureDamage dms cr w = foldl' (applyIndividualDamage cr) w dms
+applyCreatureDamage cid cr w = foldl' (applyIndividualDamage cid cr) w (cr ^. crDamage)
 
-applyIndividualDamage :: Creature -> World -> Damage -> World
+applyIndividualDamage :: Int -> Creature -> World -> Damage -> World
-applyIndividualDamage cr w (Inertial _ _ v) = w 
+applyIndividualDamage cid cr w (Inertial _ _ v _) = w 
-    & cWorld . lWorld . creatures . ix (_crID cr) . crPos . _xy +~ fmap (/ crMass (cr ^. crType)) v
+    & cWorld . lWorld . creatures . ix cid . crPos . _xy +~ fmap (/ crMass (cr ^. crType)) v
-applyIndividualDamage cr w dm = 
+applyIndividualDamage cid cr w dm = 
-    let (i,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
+    let (x,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
-    in w' & damageHP cr i
+    in w' & damageHP cid x
---  case dm of
---    Piercing{} -> applyPiercingDamage cr dm w
---    _ -> w & damageHP cr (_dmAmount dm)
 
---applyPiercingDamage :: Creature -> Damage -> World -> World
+damageHP :: Int -> Int -> World -> World
---applyPiercingDamage cr dm w
+damageHP cid x =
---    | crIsArmouredFrom (w ^. cWorld . lWorld . items) p cr 
+    (cWorld . lWorld . creatures . ix cid . crHP . _HP -~ x)
---        = f . makeSpark NormalSpark p1 (argV (p1 - p)) $ w
+    . (cWorld . lWorld . creatures . ix cid . crPain +~ x)
---    | otherwise = f . damageHP cr (_dmAmount dm) $ w
---  where
---    f = cWorld . lWorld . creatures . ix (_crID cr) . crPos . _xy +~ _dmVector dm
---            / V2 x x
---    x = crMass (_crType cr)
---    p = _dmPos dm
---    p1 = p + 2 *.* squashNormalizeV (p - cr ^. crPos . _xy)
-
-damageHP :: Creature -> Int -> World -> World
-damageHP cr x =
-    (cWorld . lWorld . creatures . ix (_crID cr) . crHP . _HP -~ x)
-    . (cWorld . lWorld . creatures . ix (_crID cr) . crPain +~ x)

src/Dodge/Creature/Impulse.hs

@@ -3,8 +3,9 @@
 
 module Dodge.Creature.Impulse (followImpulse) where
 
+import RandomHelp
 import Control.Applicative
-import Control.Monad.Trans.State.Lazy
+--import Control.Monad.Trans.State.Lazy
 --import Control.Monad.State -- moving from mtl to transformers
 import Data.Maybe
 import Dodge.Creature.Impulse.Movement
@@ -19,12 +20,12 @@ import Dodge.SoundLogic
 import Geometry
 import LensHelp
 import Linear
-import System.Random
+--import System.Random
 
 -- note SwitchToItem doesn't necessarily update the root item correctly
 followImpulse :: Int -> World -> Impulse -> World
 followImpulse cid w = \case
-    UpdateRandGen -> w & randGen %~ (snd . (randomR (0::Int,0)))
+    UpdateRandGen -> w & randGen %~ (snd . randomR (0::Int,1))
     ImpulseNothing -> w
     RandomImpulse rimp ->
         let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w)
@@ -42,11 +43,8 @@ followImpulse cid w = \case
     ChangePosture post -> crup $ crStance . posture .~ post
     UseItem -> undefined
 --    SwitchToItem i -> crup $ crManipulation . manObject .~ SelectedItem (NInt i) (NInt i) mempty
-    Melee cid' ->
+    Melee tid ->
-        hitCr cid' $
+        hitCr tid $ crup $ meleeMovement w tid . (crType . meleeCooldown .~ 20)
-            crup
-                ( crMvAbsolute (w ^. cWorld . lWorld) (10 *.* normalizeV (posFromID cid' -.- cpos)) . (crType . meleeCooldown .~ 20)
-                )
     MeleeL cid' ->
         hitCrd (-pi/2) cid' $
             crup
@@ -66,7 +64,7 @@ followImpulse cid w = \case
     MakeSound sid -> soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) sid Nothing w
     DropItem -> undefined
     ChangeStrategy strat -> crup $ crActionPlan . apStrategy .~ strat
-    AddGoal gl -> crup $ crActionPlan . apGoal .:~ gl
+--    AddGoal gl -> crup $ crActionPlan . apGoal .:~ gl
     ImpulseUseTarget f -> fromMaybe w $ do
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
@@ -74,7 +72,8 @@ followImpulse cid w = \case
     MvForward -> crup $ crMvForward' (w ^. cWorld . lWorld)
     MvTurnToward p ->
         crup $
-            creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir))
+            mvTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir))
+    SetBeeRandomMovement -> w & setBeeRandomMovement cid
   where
     clens = cWorld . lWorld . creatures . ix cid
     cr = w ^?! cWorld . lWorld . creatures . ix cid
@@ -91,9 +90,30 @@ followImpulse cid w = \case
     rr a = randomR (- a, a) $ _randGen w
     hitCr i =
         cWorld . lWorld . creatures . ix i . crDamage
-            .:~ Blunt 100 (posFromID i) (posFromID i - cpos)
+            .:~ Blunt 100 (posFromID i) (posFromID i - cpos) (CrMeleeO cid)
     hitCrd a i =
         cWorld . lWorld . creatures . ix i . crDamage
-            <>~ [Blunt 100 (posFromID i) (posFromID i - cpos)
+            <>~ [Blunt 100 (posFromID i) (posFromID i - cpos) (CrMeleeO cid)
-                , Inertial 0 (posFromID i) (50 * unitVectorAtAngle (cr ^. crDir + a))
+                , Inertial 0 (posFromID i) (50 * unitVectorAtAngle (cr ^. crDir + a)) (CrMeleeO cid)
                 ]
+
+meleeMovement :: World -> Int -> Creature -> Creature
+meleeMovement w tid cr = case cr ^. crType of
+    HoverCrit {} -> fromMaybe cr $ do
+        txy <- w ^? cWorld . lWorld . creatures . ix tid . crPos . _xy
+        return $ crMvAbsolute (w ^. cWorld . lWorld) (5 *^ normalizeV (cr ^. crPos . _xy - txy)) cr
+    ChaseCrit {} -> fromMaybe cr $ do
+        txy <- w ^? cWorld . lWorld . creatures . ix tid . crPos . _xy
+        return $ crMvAbsolute (w ^. cWorld . lWorld) (5 *^ normalizeV (txy - cr ^. crPos . _xy)) cr
+    _ -> cr
+
+setBeeRandomMovement :: Int -> World -> World
+setBeeRandomMovement cid w = fromMaybe w $ do
+    mff <- w ^? cWorld . lWorld . creatures . ix cid . crType . beeRandomMovement
+    return $ case mff of
+        Just _ -> w & cWorld . lWorld . creatures . ix cid . crType . beeRandomMovement .~ Nothing
+        Nothing -> w & cWorld . lWorld . creatures . ix cid . crType . beeRandomMovement .~ x
+            & randGen .~ g
+  where
+    (x,g) = runState (takeOne [Nothing,Just LeftForward,Just RightForward]) (w ^. randGen)
+    

src/Dodge/Creature/Impulse/Movement.hs

@@ -8,8 +8,10 @@ module Dodge.Creature.Impulse.Movement (
     crMvForward,
     crMvForward',
     creatureTurnTo,
+    mvTurnToward,
 ) where
 
+import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.MoveType
 import Linear
 import Control.Lens
@@ -26,20 +28,12 @@ p is the movement translation vector, will be made relative to creature directio
 crMvBy :: Point2 -> LWorld -> Creature -> Creature
 crMvBy p lw cr = crMvAbsolute lw (rotateV (_crDir cr) p) cr
 
-crWalk ::
+-- | p is the movement translation vector, made relative to creature direction
-    -- | Movement translation vector, will be made relative to creature direction
+crWalk :: Point2 -> LWorld -> Creature -> Creature
-    Point2 ->
-    LWorld ->
-    Creature ->
-    Creature
 crWalk p lw cr = crWalkAbsolute lw (rotateV (_crDir cr) p) cr
 
-crMvByNoStride ::
+-- | p is the movement translation vector, made relative to creature direction
-    -- | Movement translation vector, will be made relative to creature direction
+crMvByNoStride :: Point2 -> LWorld -> Creature -> Creature
-    Point2 ->
-    LWorld ->
-    Creature ->
-    Creature
 crMvByNoStride p lw cr = crMvAbsoluteNoStride lw (rotateV (_crDir cr) p) cr
 
 crMvAbsolute :: LWorld -> Point2 -> Creature -> Creature
@@ -48,7 +42,7 @@ crMvAbsolute lw p' cr =
         & crPos . _xy +~ p
         & crMvDir .~ argV (p + cr ^. crOldPos . _xy - cr ^. crOldOldPos . _xy)
   where
-    p = strengthFactor (getCrMoveSpeed lw cr) *.* p'
+    p = strengthFactor (getCrMoveSpeed lw cr) *^ p'
 
 crWalkAbsolute :: LWorld -> Point2 -> Creature -> Creature
 crWalkAbsolute lw p' cr 
@@ -78,6 +72,15 @@ crMvForward' lw cr = case crMvType cr of
                 | otherwise = s
         in crMvBy (V2 speed 0) lw cr
             & crType . startStopMv %~ ((`mod` (n*2)) . (+1))
+    BeeMvType s _ n ->
+        let speed | cr ^?! crType . startStopMv > n = 0
+                | otherwise = s
+            v = case cr ^?! crType . beeRandomMovement of
+                Nothing -> V2 speed 0
+                Just LeftForward -> V2 0 speed
+                Just RightForward -> V2 0 (-speed)
+        in crMvBy v lw cr
+            & crType . startStopMv %~ ((`mod` (n*2)) . (+1))
     NoMvType -> cr
     MvWalking s -> crMvBy (V2 s 0) lw cr
     
@@ -117,3 +120,23 @@ creatureTurnToward p turnSpeed cr
   where
     vToTarg = p -.- cr ^. crPos . _xy
     dirToTarget = argV vToTarg
+
+-- I feel like this is inefficient
+mvTurnToward :: Point2 -> Float -> Creature -> Creature
+mvTurnToward p' turnSpeed cr
+    | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error
+    | angleVV vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed =
+        cr & crDir .~ dirToTarget
+    | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
+    | otherwise = cr & crDir -~ turnSpeed
+  where
+    -- when flying, inertia is high enough that overturning can be useful
+    p | Flying {} <- cr ^. crStance . carriage
+            = let v = flyInertia cr *^ (cr ^. crOldPos . _xy - cr ^. crOldOldPos . _xy)
+               --   u = normalize $ vNormal $ p' - cxy
+               --in p' - dot v u *^ u
+               in p' - v
+        | otherwise = p'
+    cxy = cr ^. crPos . _xy
+    vToTarg = p -.- cxy
+    dirToTarget = argV vToTarg

src/Dodge/Creature/Mass.hs

@@ -13,6 +13,6 @@ crMass = \case
     BarrelCrit{} -> 10
     SlinkCrit{} -> 100
     LampCrit {} -> 3
-    SlimeCrit {_slimeRad = r} -> r * r / 10
+    SlimeCrit {_slimeSlime = r} -> fromIntegral r / 1000
-    BeeCrit {_beeSlime = x} -> 3 + x
+    BeeCrit {_beeSlime = x} -> 3 + fromIntegral x / 100
     HiveCrit {} -> 100

src/Dodge/Creature/MoveType.hs

@@ -17,7 +17,8 @@ crMvType cr = case _crType cr of
     BarrelCrit {} -> defaultAimMvType
     LampCrit {} -> defaultAimMvType
     SlimeCrit {} -> NoMvType
-    BeeCrit {} -> StartStopMvType 0.2 0.1 25
+    BeeCrit {} -> BeeMvType 0.2 0.1 15
+    --BeeCrit {} -> BeeMvType 0.2 0.1 25
     HiveCrit{} -> NoMvType
 
 defaultAimMvType :: CrMvType

src/Dodge/Creature/Perception.hs

@@ -132,14 +132,10 @@ decreaseAwareness (Cognizant 0) = Just $ Suspicious 1000
 decreaseAwareness (Cognizant x) = Just $ Cognizant $ x - 50
 
 {- | Given a fixed group of creatures, direct attention to those of them that
- - are in view.
+are in view.
+The ints are ids of creatures that may attract this creature's attention
 -}
-basicAttentionUpdate ::
+basicAttentionUpdate :: [Int] -> World -> Creature -> Creature
-    -- | Creatures that may attract this creature's attention
-    [Int] ->
-    World ->
-    Creature ->
-    Creature
 basicAttentionUpdate cids w cr =
     cr & crPerception . cpAttention
         .~ AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids)

src/Dodge/Creature/Picture.hs

@@ -7,30 +7,29 @@ module Dodge.Creature.Picture (
     drawCreature,
 ) where
 
-import Data.Foldable
-import qualified Data.Strict.Tuple as ST
-import RandomHelp
-import Dodge.Base.Collide
-import Control.Monad
-import Data.Maybe
-import Dodge.Data.World
-import Linear
-import Dodge.Data.Equipment.Misc
-import Dodge.Creature.HandPos
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
+import Control.Monad
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.Strict.Tuple as ST
+import Dodge.Base.Collide
+import Dodge.Creature.HandPos
 import Dodge.Creature.Radius
 import Dodge.Creature.Shape
---import Dodge.Creature.Test
+import Dodge.Creature.Slime
 import Dodge.Damage
---import Dodge.Data.Creature
+import Dodge.Data.Equipment.Misc
+import Dodge.Data.World
 import Dodge.Item.Draw
 import Dodge.Item.Grammar
 import Geometry
+import Geometry.Zone
+import Linear
 import Picture
 import qualified Quaternion as Q
+import RandomHelp
 import Shape
---import Shape
 import ShapePicture
 
 drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
@@ -40,11 +39,11 @@ drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
         _ | null (cr ^? crHP . _HP) -> mempty
         BarrelCrit{} -> barrelShape
         LampCrit{_lampHeight = h} -> lampCrSPic h
-        ChaseCrit {} -> noPic $ drawChaseCrit w cr
+        ChaseCrit{} -> noPic $ drawChaseCrit w cr
-        Avatar {} -> basicCrPict m cr
+        Avatar{} -> basicCrPict m cr
         SwarmCrit -> basicCrPict m cr
         AutoCrit -> basicCrPict m cr
-        CrabCrit {} -> noPic $ drawCrabCrit w cr
+        CrabCrit{} -> noPic $ drawCrabCrit w cr
         HoverCrit{} -> noPic $ drawHoverCrit cr
         SlinkCrit{} -> noPic $ drawSlinkCrit cr
         SlimeCrit{} -> noPic $ drawSlimeCrit cr
@@ -56,109 +55,125 @@ drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
         _ -> id
 
 drawSlimeCrit :: Creature -> Shape
-drawSlimeCrit cr = colorSH green 
+drawSlimeCrit cr =
-    $ upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) $ polyCirc 6 r
+    colorSH green $
-    & each %~ scaleAlong d s
+        upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) ps
-    & each %~ scaleAlong (vNormal d) (1 / s)
-    & each %~ rotateV (-cr ^. crDir)
-    & each %~ (((r-cr^?!crType.slimeRadWobble)/r) *^)
   where
-    r = cr ^?! crType . slimeRad
+    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
-    p = cr ^?! crType . slimeCompression
+    so = slimeOutline cr
-    d = normalize p
+    ps = fromMaybe so $ do
-    s = norm p / r
+        (x', qs) <- cr ^? crType . slimeSplitTimer . _Just
+        let x = fromIntegral x'
+        guard $ length qs == 12
+        return $ zipWith (+) (fmap (0.1 * (10 - x) *^) so) (fmap (0.1 * x *^) qs)
 
 -- assumes d is a unit vector
 scaleAlong :: Point2 -> Float -> Point2 -> Point2
 scaleAlong d s p = ((s - 1) * dot d p) *^ d + p
 
-
 basicCrPict :: IM.IntMap Item -> Creature -> SPic
 basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
 
-crCamouflage :: Creature -> CamouflageStatus
-crCamouflage _ = FullyVisible
-
 basicCrShape :: Creature -> Shape
-basicCrShape cr
+basicCrShape cr =
-    | crCamouflage cr == Invisible = mempty
+    scaleSH (V3 crsize crsize crsize) $
-    | otherwise =
+        mconcat
-        scaleSH (V3 crsize crsize crsize) $
+            [ colorSH (_skinHead cskin) . overPosSH (translateToES cr OnHead) $ scalp
-            mconcat
+            , colorSH (_skinUpper cskin) $ upperBody cr
-                [ colorSH (_skinHead cskin) . overPosSH (translateToES cr OnHead) $ scalp
+            , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-                , colorSH (_skinUpper cskin) $ upperBody cr
+            ]
-                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-                ]
   where
     cskin = crShape $ _crType cr
     crsize = 0.1 * crRad (cr ^. crType)
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 drawSlinkCrit :: Creature -> Shape
-drawSlinkCrit cr = snd (foldl' f ((V3 0 0 0,Q.qid), mempty) $ cr ^?! crType . slinkSpine)
+drawSlinkCrit cr =
+    snd (foldl' f ((V3 0 0 0, Q.qid), mempty) $ cr ^?! crType . slinkSpine)
         <> shead
-    & each . sfColor .~ cskin ^?! skinUpper
+        & each . sfColor .~ cskin ^?! skinUpper
   where
-    shead = polyCirc 6 15
+    shead =
-        & upperPrismPoly Medium Important 10
+        polyCirc 6 15
-        & each . sfVs . each %~ Q.apply (cr ^?! crType . slinkHeadPos)
+            & upperPrismPoly Medium Important 10
+            & each . sfVs . each %~ Q.apply (cr ^?! crType . slinkHeadPos)
     cskin = crShape $ _crType cr
-    f ((p,q),sh) (p',q') = ((p,q) `Q.comp` (p',q'), sh <> (g p' & each . sfVs . each %~ Q.apply (p,q)))
+    f ((p, q), sh) (p', q') = ((p, q) `Q.comp` (p', q'), sh <> (g p' & each . sfVs . each %~ Q.apply (p, q)))
     g _ = upperPrismPoly Medium Important 2 $ polyCirc 6 15
 
 drawHoverCrit :: Creature -> Shape
-drawHoverCrit cr = colorSH (_skinHead cskin) 
+drawHoverCrit cr =
-    (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
+    colorSH
-    <> colorSH (_skinUpper cskin)
+        (_skinHead cskin)
-    (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0,pi/2,pi,1.5*pi]])
+        (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
+        <> colorSH
+            (_skinUpper cskin)
+            (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0, pi / 2, pi, 1.5 * pi]])
   where
     cskin = crShape $ _crType cr
     f a = tpq `Q.comp` (1 & _xy .~ rotateV a 5, Q.qid)
     tpq = (V3 0 0 0, Q.qid)
 
 drawHive :: SPic
-drawHive =  noPic $ upperPrismPolyHalfMI 25 $ polyCirc 6 20
+drawHive = noPic $ upperPrismPolyHalfMI 25 $ polyCirc 6 20
 
 drawBeeCrit :: Creature -> Shape
-drawBeeCrit cr = colorSH col
+drawBeeCrit cr =
-    (upperPrismPolyHalfMI 3 $ polyCirc 6 r)
+    colorSH
-        <>
+        col
-    colorSH (dark col) (overPosSH (Q.apply (beakpos)) $ upperPrismPolyHalfST 1 $ [V2 0 (-2), V2 4 0,V2 0 2])
+        (f . upperPrismPolyHalfMI 3 $ polyCirc 6 r)
+        <> colorSH (dark col) (overPosSH (Q.apply (beakpos)) $ upperPrismPolyHalfST 1 $ [V2 0 (-2), V2 4 0, V2 0 2])
   where
     r = cr ^. crType . to crRad
-    beakpos = (V3 (r-1) 0 0, Q.qid)
+    beakpos = (V3 (r - 1) 0 0, Q.qid)
-    col | cr ^?! crType . beeAggro > 0 = red
+    col
+        | cr ^?! crType . beeAggro > 0 = red
         | otherwise = yellow
+    f
+        | Mounted{} <- cr ^. crStance . carriage =
+            each . sfVs . each . _xy %~ scaleAlong (V2 0 1) (1 + g (modTo 1 (cr ^?! crType . beeSlime . to ((/ 100) . fromIntegral))))
+        | otherwise = id
+    g x
+        | x > 0.5 = 1 - x
+        | otherwise = x
 
 drawCrabCrit :: World -> Creature -> Shape
-drawCrabCrit w cr = mconcat 
+drawCrabCrit w cr =
-    [ crabUpperBody w cr
+    mconcat
-    , colorSH (_skinLower cskin) $ crabFeet w cr
+        [ crabUpperBody w cr
-    ]
+        , colorSH (_skinLower cskin) $ crabFeet w cr
+        ]
   where
     cskin = crShape $ _crType cr
 
 drawChaseCrit :: World -> Creature -> Shape
-drawChaseCrit w cr = mconcat 
+drawChaseCrit w cr =
-    [ chaseUpperBody w cr
+    mconcat
-    , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+        [ chaseUpperBody w cr
-    ]
+        , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+        ]
   where
     cskin = crShape $ _crType cr
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 crabUpperBody :: World -> Creature -> Shape
-crabUpperBody _ cr =  colorSH (_skinUpper cskin)
+crabUpperBody _ cr =
-    (
+    colorSH
-    overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
+        (_skinUpper cskin)
-        & each . _x *~ 0.6) 
+        ( overPosSH
-    <> overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+            (Q.apply torsoq)
-    <> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
+            ( upperPrismPolyHalfMI 5 $
-    )
+                polyCirc 4 10
-    <> colorSH (_skinHead cskin)
+                    & each . _x *~ 0.6
-        (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
+            )
+            <> overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+            <> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
+        )
+        <> colorSH
+            (_skinHead cskin)
+            (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
   where
-    torsoq = (V3 0 0 10,Q.qid)
+    torsoq = (V3 0 0 10, Q.qid)
     lclawq = torsoq `Q.comp` (V3 2 8 1, Q.slerp latck lrest lcool)
     latck = Q.axisAngle (V3 0 0 1) (-0.5 * pi)
     lrest = Q.axisAngle (V3 1 0 0) 1
@@ -169,105 +184,116 @@ crabUpperBody _ cr =  colorSH (_skinUpper cskin)
     rrest = Q.axisAngle (V3 1 0 0) (-1)
     rcool = 1 - min 10 (fromIntegral . _meleeCooldownR $ _crType cr) / 10
     headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
-    
 
 chaseUpperBody :: World -> Creature -> Shape
-chaseUpperBody w cr =  colorSH (_skinUpper cskin)
+chaseUpperBody w cr =
-    (overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI tz $ polyCirc 3 12 
+    colorSH
-        & each %~ vNormal
+        (_skinUpper cskin)
-        & each . _y *~ 0.6) 
+        ( overPosSH
-    <> overPosSH (Q.apply neckq) (upperPrismPolyHalfMI 3 $ (+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
+            (Q.apply torsoq)
-    )
+            ( upperPrismPolyHalfMI tz $
-    <> colorSH (_skinHead cskin)
+                polyCirc 3 12
-        (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+                    & each %~ vNormal
+                    & each . _y *~ 0.6
+            )
+            <> overPosSH (Q.apply neckq) (upperPrismPolyHalfMI 3 $ (+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
+        )
+        <> colorSH
+            (_skinHead cskin)
+            (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
   where
---    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
+    --    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
     tz = 4
     cskin = crShape $ _crType cr
-    torsoq = (V3 0 0 (10 + tz + tbob),Q.qid)
+    torsoq = (V3 0 0 (10 + tz + tbob), Q.qid)
     mcool = 1 - min 10 (fromIntegral . _meleeCooldown $ _crType cr) / 10
-    neckq = torsoq `Q.comp` (V3 6 0 0, Q.qz aimrot * Q.axisAngle (V3 0 1 0) (-1.8*mcool))
+    neckq = torsoq `Q.comp` (V3 6 0 0, Q.qz aimrot * Q.axisAngle (V3 0 1 0) (-1.8 * mcool))
-    headq = neckq `Q.comp` (V3 16 0 0, Q.axisAngle (V3 0 1 0) (2*mcool+vocaltilt) * Q.qz aimrot )
+    headq = neckq `Q.comp` (V3 16 0 0, Q.axisAngle (V3 0 1 0) (2 * mcool + vocaltilt) * Q.qz aimrot)
     vocaltilt = case cr ^? crVocalization . vcTime of
         Just x | x < 20 -> -pi * 0.05 * (10 - abs (fromIntegral x - 10))
         _ -> 0
     sLen = strideLength cr
     tbob = 5 * (1 - oneSmooth (abs llegpos))
-    llegpos = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    llegpos = case (cr ^? crType . strideAmount, cr ^? crType . footForward) of
         (Just sa, Just LeftForward) -> f sa
         (Just sa, Just RightForward) -> -f sa
         _ -> 0
-    --tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
+    -- tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
-    f i = (sLen - 2*i) / sLen
+    f i = (sLen - 2 * i) / sLen
     cxy = cr ^. crPos . _xy
     aimrot = fromMaybe pi $ do
         i <- cr ^. crIntention . targetCr
         tcxy <- w ^? cWorld . lWorld . creatures . ix i . crPos . _xy
         guard $ hasLOSIndirect cxy tcxy w
-        return . (0.5*) . nearZeroAngle $  argV (tcxy - cxy) - cr ^. crDir
+        return . (0.5 *) . nearZeroAngle $ argV (tcxy - cxy) - cr ^. crDir
 
 oneSmooth :: Float -> Float
 oneSmooth x = sin (pi * x * 0.5)
 
 feet :: Creature -> Shape
 {-# INLINE feet #-}
-feet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+feet cr = case (cr ^? crType . strideAmount, cr ^? crType . footForward) of
-    (Just sa,Just LeftForward) -> sh (f sa)
+    (Just sa, Just LeftForward) -> sh (f sa)
-    (Just sa,Just RightForward) -> sh (-f sa)
+    (Just sa, Just RightForward) -> sh (-f sa)
     _ -> sh 0
   where
-    sh x = translateSHxy x off aFoot <> translateSHxy (- x) (- off) aFoot
+    sh x = translateSHxy x off aFoot <> translateSHxy (-x) (-off) aFoot
     aFoot = upperPrismPolyST 10 $ polyCirc 3 4
     off = 5
     sLen = strideLength cr
---    f i = 8 * (sLen - 2*i) / sLen
+    --    f i = 8 * (sLen - 2*i) / sLen
-    f i = 8 * oneSmooth ((sLen - 2*i) / sLen)
+    f i = 8 * oneSmooth ((sLen - 2 * i) / sLen)
 
 crabFeet :: World -> Creature -> Shape
 {-# INLINE crabFeet #-}
-crabFeet _ cr = 
+crabFeet _ cr =
     uncurryV translateSHxy rpos (afoot & each . sfVs . each %~ Q.rotate r1)
-    <> (afoot 
+        <> ( afoot
-        & each . sfVs . each %~ Q.rotate r2
+                & each . sfVs . each %~ Q.rotate r2
-        & each . sfVs . each +~ V3 0 2 5)
+                & each . sfVs . each +~ V3 0 2 5
-    <> uncurryV translateSHxy rpos' (afoot & each . sfVs . each %~ Q.rotate r1')
+           )
-    <> (afoot 
+        <> uncurryV translateSHxy rpos' (afoot & each . sfVs . each %~ Q.rotate r1')
-        & each . sfVs . each %~ Q.rotate r2'
+        <> ( afoot
-        & each . sfVs . each +~ V3 0 2 5)
+                & each . sfVs . each %~ Q.rotate r2'
-    <> uncurryV translateSHxy lpos (afoot & each . sfVs . each %~ Q.rotate l1)
+                & each . sfVs . each +~ V3 0 2 5
-    <> (afoot 
+           )
-        & each . sfVs . each %~ Q.rotate l2
+        <> uncurryV translateSHxy lpos (afoot & each . sfVs . each %~ Q.rotate l1)
-        & each . sfVs . each +~ V3 0 (-2) 5)
+        <> ( afoot
-    <> uncurryV translateSHxy lpos' (afoot & each . sfVs . each %~ Q.rotate l1')
+                & each . sfVs . each %~ Q.rotate l2
-    <> (afoot 
+                & each . sfVs . each +~ V3 0 (-2) 5
-        & each . sfVs . each %~ Q.rotate l2'
+           )
-        & each . sfVs . each +~ V3 0 (-2) 5)
+        <> uncurryV translateSHxy lpos' (afoot & each . sfVs . each %~ Q.rotate l1')
+        <> ( afoot
+                & each . sfVs . each %~ Q.rotate l2'
+                & each . sfVs . each +~ V3 0 (-2) 5
+           )
   where
     rpos = rot (cr ^?! crType . rFootPos - cxy)
-    rot = rotateV cdir 
+    rot = rotateV cdir
-    lpos = rot ( cr ^?! crType . lFootPos - cxy)
+    lpos = rot (cr ^?! crType . lFootPos - cxy)
     f p q = q + 2 *^ (p - q)
     cdir = -cr ^. crDir
     cxy = cr ^. crPos . _xy
     afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2
-    (r1,r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5)
+    (r1, r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5)
     rpos' = f (V2 0 10) rpos
-    (r1',r2') = spiderJoint (0 & _xy .~ rpos') (V3 0 2 5)
+    (r1', r2') = spiderJoint (0 & _xy .~ rpos') (V3 0 2 5)
-    (l1,l2) = spiderJoint (0 & _xy .~ lpos) (V3 0 (-2) 5)
+    (l1, l2) = spiderJoint (0 & _xy .~ lpos) (V3 0 (-2) 5)
     lpos' = f (V2 0 (-10)) lpos
-    (l1',l2') = spiderJoint (0 & _xy .~ lpos') (V3 0 (-2) 5)
+    (l1', l2') = spiderJoint (0 & _xy .~ lpos') (V3 0 (-2) 5)
 
 spiderJoint :: Point3 -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
-spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
+spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a + b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
---spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
   where
+    -- spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+
     a = angleThreeSides 10 (distance p q) 10
-    b = angleVV3 (q-p) (V3 0 0 (-1))
+    b = angleVV3 (q - p) (V3 0 0 (-1))
-    c = argV $ (p-q) ^. _xy
+    c = argV $ (p - q) ^. _xy
     f x = Q.qz c * x
 
---spiderJoint' :: Point3 -> Float -> Float -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
+-- spiderJoint' :: Point3 -> Float -> Float -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
---spiderJoint' p l1 l2 q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
+-- spiderJoint' p l1 l2 q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
 ----spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
 --  where
 --    a = angleThreeSides 10 (distance p q) 10
@@ -295,48 +321,59 @@ makeCorpse g cr = case cr ^. crType of
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 chaseCorpse :: StdGen -> Creature -> Shape
-chaseCorpse g cr = mconcat
+chaseCorpse g cr =
-            [colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $ polyCirc 3 12 
+    mconcat
+        [ colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $
+            polyCirc 3 12
                 & each %~ vNormal
                 & each . _y *~ 0.6
-            , colorSH (_skinUpper cskin) . overPosSH (Q.apply neckq) $ 
+        , colorSH (_skinUpper cskin) . overPosSH (Q.apply neckq) $
-                upperPrismPolyHalfMI 3 ((+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
+            upperPrismPolyHalfMI 3 ((+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
-    , colorSH (_skinHead cskin)
+        , colorSH
-        (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+            (_skinHead cskin)
-            , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+            (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+        , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
         ]
   where
     neckq = (V3 6 0 0, Q.qz a)
-    (a,g') = randomR (-2,2) g
+    (a, g') = randomR (-2, 2) g
-    b = fst $ randomR (-2,2) g'
+    b = fst $ randomR (-2, 2) g'
     cskin = crShape $ _crType cr -- this should be fixed
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
-    headq = neckq `Q.comp` (V3 16 0 0, Q.qz b )
+    headq = neckq `Q.comp` (V3 16 0 0, Q.qz b)
 
 crabCorpse :: StdGen -> Creature -> Shape
-crabCorpse g cr = mconcat
+crabCorpse g cr =
-    [ colorSH (_skinUpper cskin) $ overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
+    mconcat
-        & each . _x *~ 0.6) 
+        [ colorSH (_skinUpper cskin) $
-    , colorSH (_skinUpper cskin) $ overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+            overPosSH
-    <> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
+                (Q.apply torsoq)
-    , colorSH (cskin ^?! skinLower) $
+                ( upperPrismPolyHalfMI 5 $
-        foldMap (mkfoot 5) (take 2 ps)
+                    polyCirc 4 10
-        <> foldMap (mkfoot (-5)) (take 2 $ drop 2 ps)
+                        & each . _x *~ 0.6
-    , colorSH (_skinHead cskin)
+                )
-        (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
+        , colorSH (_skinUpper cskin) $
+            overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+                <> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
+        , colorSH (cskin ^?! skinLower) $
+            foldMap (mkfoot 5) (take 2 ps)
+                <> foldMap (mkfoot (-5)) (take 2 $ drop 2 ps)
+        , colorSH
+            (_skinHead cskin)
+            (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
         ]
   where
     headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
-    torsoq = (V3 0 0 0,Q.qid)
+    torsoq = (V3 0 0 0, Q.qid)
     lclawq = torsoq `Q.comp` (V3 2 8 1, Q.axisAngle (V3 1 0 0) (-0.1) * Q.qz la)
-    (la,g') =  randomR (-2,2) g
+    (la, g') = randomR (-2, 2) g
-    ra = fst $ randomR (-2,2) g'
+    ra = fst $ randomR (-2, 2) g'
     ps = evalState (replicateM 4 (randInCirc 9)) g
-    mkfoot y p = 
+    mkfoot y p =
-        let p' = 0 & _xy .~ p + V2 0 (3*y)
+        let p' = 0 & _xy .~ p + V2 0 (3 * y)
-            (q1,q2) = spiderJoint (V3 0 y 0) p'
+            (q1, q2) = spiderJoint (V3 0 y 0) p'
-        in (afoot & each . sfVs . each %~ Q.apply (V3 0 y 0, q1))
+         in (afoot & each . sfVs . each %~ Q.apply (V3 0 y 0, q1))
-            <> (afoot & each . sfVs . each %~ Q.apply (p',q2))
+                <> (afoot & each . sfVs . each %~ Q.apply (p', q2))
     afoot = upperPrismPolyST 10 $ polyCirc 3 2
     rclawq = torsoq `Q.comp` (V3 2 (-8) 1, Q.axisAngle (V3 1 0 0) 0.1 * Q.qz ra)
     cskin = crShape $ _crType cr -- this should be fixed
@@ -355,8 +392,8 @@ arms cr =
     aHand = noPic $ translateSHz (-2) . upperPrismPolyHalfST 2 $ polyCirc 3 4
 
 deadScalp :: Creature -> Shape
---deadScalp cr = deadRot cr . translateSHz 5 . scalp $ cr
+-- deadScalp cr = deadRot cr . translateSHz 5 . scalp $ cr
---deadScalp cr = deadRot cr . translateSHz (-5) . scalp $ cr
+-- deadScalp cr = deadRot cr . translateSHz (-5) . scalp $ cr
 deadScalp _ = translateSH (V3 (-13) 0 0) scalp
 
 deadRot :: Creature -> Shape -> Shape
@@ -370,7 +407,8 @@ deadRot cr = overPosSH (Q.rotateToZ d)
 
 scalp :: Shape
 {-# INLINE scalp #-}
-scalp = (colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5)
+scalp =
+    (colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5)
         & each . sfShadowImportance .~ Unimportant
 
 torso :: Creature -> Shape
@@ -385,7 +423,7 @@ deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
---baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
+-- baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 baseShoulder = scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 
 upperBody :: Creature -> Shape
@@ -405,4 +443,3 @@ lampCrSPic :: Float -> SPic
 lampCrSPic h =
     colorSH blue (upperBox Small Undesired h $ rectWH 5 5)
         ST.:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-

src/Dodge/Creature/Radius.hs

@@ -11,11 +11,11 @@ crRad = \case
     ChaseCrit {} -> 10
     CrabCrit {} -> 10
     HoverCrit {} -> 8
-    BeeCrit {_beeSlime = x} -> sqrt $ 2^(2::Int) + x
+    BeeCrit {_beeSlime = x} -> sqrt $ 4 + (fromIntegral x / 100)
     SwarmCrit -> 2
     AutoCrit -> 10
     BarrelCrit{} -> 10
     LampCrit {} -> 3
     SlinkCrit {} -> 10
     HiveCrit {} -> 20
-    SlimeCrit {_slimeRad = r,_slimeRadWobble = x} -> r - x
+    SlimeCrit {_slimeSlime = r,_slimeSlimeChange = x} -> slimeToRad (r - x)

src/Dodge/Creature/ReaderUpdate.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Creature.ReaderUpdate (
-    doStrategyActions,
     targetYouWhenCognizant,
     overrideMeleeCloseTarget,
     watchUpdateStrat,
@@ -25,7 +24,7 @@ import Dodge.Base
 import Dodge.Creature.Perception
 import Dodge.Creature.Radius
 import Dodge.Creature.Vocalization
-import Dodge.Data.CreatureEffect
+--import Dodge.Data.CreatureEffect
 import Dodge.Data.World
 import Dodge.Zoning.Creature
 import FoldableHelp
@@ -45,7 +44,7 @@ tryMeleeAttack cr tcr
     | _meleeCooldown (_crType cr) == 0
         && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
         && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
-        && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 =
+        && abs (_crDir cr - argV (tpos - cpos)) < pi / 4 =
         cr & crActionPlan . apAction
                 .~ DoImpulses [Melee $ _crID tcr] `DoActionThen`
                         DoReplicate 10 NoAction
@@ -141,7 +140,7 @@ crabActionUpdate cid w = case _apStrategy (_crActionPlan cr) of
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
                 w & tocr . crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                w & tocr . crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                w -- & tocr . crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
                     & tocr . crActionPlan . apStrategy .~ Search
                     & tocr . crIntention . mvToPoint .~ Nothing
         _ -> w & tocr %~ viewTarget w
@@ -215,8 +214,8 @@ chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
                 cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-                    & crActionPlan . apStrategy .~ WatchAndWait
+                    & crActionPlan . apStrategy .~ Search
                     & crIntention . mvToPoint .~ Nothing
         _ -> viewTarget w cr
   where
@@ -235,8 +234,8 @@ hoverCritMv w cr = case _apStrategy (_crActionPlan cr) of
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
                 cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-                    & crActionPlan . apStrategy .~ WatchAndWait
+                    & crActionPlan . apStrategy .~ Search
                     & crIntention . mvToPoint .~ Nothing
         _ -> viewTarget w cr
   where
@@ -269,15 +268,6 @@ viewTarget w cr = case cr ^? crIntention . viewPoint . _Just of
 --replaceNullWith x [] = [x]
 --replaceNullWith _ xs = xs
 
-doStrategyActions :: Creature -> Creature
-doStrategyActions cr = case cr ^? crActionPlan . apStrategy of
-    Just (StrategyActions strat acs) ->
-        cr
---            & crActionPlan . apAction .~ acs
-            & crActionPlan . apAction .~ head acs
-            & crActionPlan . apStrategy .~ strat
-    _ -> cr
-
 overrideInternal :: (Creature -> Bool) -> (Creature -> Creature) -> Creature -> Creature
 overrideInternal test update cr
     | test cr = update cr
@@ -316,16 +306,11 @@ searchIfDamaged cr
     | _crPain cr > 0
         && _apStrategy (_crActionPlan cr) == WatchAndWait =
         cr & crPerception . cpVigilance .~ Vigilant
-            & crActionPlan . apStrategy
+            & crActionPlan . apStrategy .~ LookAround
-                .~ StrategyActions
-                    LookAround
-                    [ TurnToPoint (cr ^. crPos . _xy -.- unitVectorAtAngle (_crDir cr))
-                        `DoActionThen` 40 `WaitThen` bfsThenReturn 500
-                    ]
     | otherwise = cr
 
-bfsThenReturn :: Int -> Action
+--bfsThenReturn :: Int -> Action
-bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
+--bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
 
 --    theaction
 --  where

src/Dodge/Creature/Slime.hs

@@ -0,0 +1,16 @@
+module Dodge.Creature.Slime (slimeOutline) where
+
+import Control.Lens
+import Dodge.Data.Creature
+import Geometry.Data
+import Linear
+import Shape
+
+slimeOutline :: Creature -> [Point2]
+slimeOutline cr =
+    polyCirc 6 r
+        & each . _x *~ a
+        & each . _y %~ (/ a)
+  where
+    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
+    a = cr ^?! crType . slimeCompression

src/Dodge/Creature/State.hs

@@ -4,6 +4,7 @@ module Dodge.Creature.State (
     invItemEffs,
 ) where
 
+import Dodge.Creature.Radius
 import qualified Data.IntMap.Strict as IM
 import Linear
 import NewInt
@@ -43,16 +44,38 @@ import qualified SDL
 doDamage :: Int -> World -> World
 doDamage cid w = fromMaybe w $ do
     cr <- w ^? cWorld . lWorld . creatures . ix cid
-    return $ applyPastDamages cr $ applyCreatureDamage (cr ^. crDamage) cr w
+    return $ crPainEffect cr $ applyCreatureDamage cid cr w
 
 -- TODO generalise shake to arbitrary damage amounts
-applyPastDamages :: Creature -> World -> World
+crPainEffect :: Creature -> World -> World
-applyPastDamages cr w
+crPainEffect cr = case cr ^. crType of
-    | HoverCrit {} <- cr ^. crType 
+    HoverCrit {} -> hoverPainEffect cr
-    , _crPain cr > 50 = w
+    HiveCrit{} -> hivePainEffect cr
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50
+    _ -> jitterPain cr
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1
+
-    | HoverCrit {} <- cr ^. crType  = w
+
+hoverPainEffect :: Creature -> World -> World
+hoverPainEffect cr
+    | _crPain cr > 50 =
+                (cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50)
+                . (cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1)
+    | otherwise = id
+
+
+hivePainEffect :: Creature -> World -> World
+hivePainEffect cr w
+    | _crPain cr > 0 = w & cWorld . lWorld . creatures . ix (cr ^. crID) . crPain %~ (max 0 . subtract 5)
+        & cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos & _xy +~ p & _z .~ 20) v 200
+        & randGen .~ g
+    | otherwise = w
+  where
+    (a,g') = randomR (0,2*pi) $ w ^. randGen
+    (b,g) = runState randOnUnitSphere $ g'
+    p = (crRad (cr ^. crType) + 5) *^ unitVectorAtAngle a
+    v = 3 *^ b
+
+jitterPain :: Creature -> World -> World
+jitterPain cr w
     | _crPain cr > 200 = dojitter 3 100
     | _crPain cr > 20 = dojitter 2 10
     | _crPain cr > 0 = dojitter 1 1
@@ -225,6 +248,7 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
                     , _lpPos = pos
 --                    , _lpColor = col
                     , _lpType = TargetingLaser (_itID itm)
+                    , _lpOrigin = CrWeaponO $ cr ^. crID
                     }
   where
     o = locOrient loc cr

src/Dodge/Creature/State/WalkCycle.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 
 module Dodge.Creature.State.WalkCycle (updateCarriage
-    ,compressionScale) where
+    ,compressionScale
+    , flyInertia
+    ) where
 
 import qualified Quaternion as Q
 import Dodge.Creature.Radius
@@ -55,8 +57,7 @@ updateCarriage' cid cr w = \case
         mcr <- w ^? cWorld . lWorld . creatures . ix mid
         mp <- mcr ^? crPos
         d <- mcr ^? crType . slimeCompression
-        r <- mcr ^? crType . slimeRad
+        return $ w & tocr . crPos .~ mp + (p & _x *~ d & _y %~ (/d))
-        return $ w & tocr . crPos .~ mp + (p & _xy %~ compressionScale ((1/r) *^ d))
   where
     tocr = cWorld . lWorld . creatures . ix cid
     oop = cr ^. crOldOldPos
@@ -85,7 +86,7 @@ walkCliffPush :: Creature -> [(Point2,Point2)] -> Point2
 walkCliffPush cr xs = pushAgainst (cr ^. crOldPos . _xy - cr ^. crOldOldPos . _xy) (-h xs)
   where
     cxy = cr ^. crPos . _xy
-    h = circSegsInside cxy (cr ^. crType . to crRad)
+    h = circSegsInside cxy (min 10 (cr ^. crType . to crRad))
 
 groundCliffPush :: Creature -> [(Point2,Point2)] -> Point2
 groundCliffPush cr xs = x *^ circSegsInside cxy r xs
@@ -136,9 +137,14 @@ chasmTestCliffPush f' cr w
   where
     cxy = cr ^. crPos . _xy
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
-    g = uncurry $ crOnSeg cr
+    --g = uncurry $ crOnSeg cr
+    g = uncurry $ crOnSeg' cr
     f = pointInPoly cxy
 
+crOnSeg' :: Creature -> Point2 -> Point2 -> Bool
+{-# INLINE crOnSeg' #-}
+crOnSeg' cr = circOnSeg (cr ^. crPos . _xy) (min 10 (cr ^. crType . to crRad))
+
 chasmRotate :: Creature -> Point2 -> World -> World
 chasmRotate cr v w
     | t = rotateTo8 (argV v) w

src/Dodge/Creature/Strategy.hs

@@ -1,27 +0,0 @@
-module Dodge.Creature.Strategy (
-    goToPostStrat,
-) where
-
-import Data.List
-import Dodge.Creature.Test
-import Dodge.Creature.Volition
-import Dodge.Data.Creature
-
-goToPostStrat :: Creature -> Strategy
-goToPostStrat cr = case find sentinelGoal $ _apGoal $ _crActionPlan cr of
-    Just (SentinelAt p _) ->
-        StrategyActions
-            (GetTo p)
-            [ DoActionThen (WaitThen 150 holsterIfAiming) $
-                DoActionThen
-                    (PathTo p NoAction)
-                    NoAction
-                    --     $ DoImpulses [ChangeStrategy WatchAndWait]
-            ]
-    _ -> WatchAndWait
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
-    holsterIfAiming
-        | crIsAiming cr = holsterWeapon
-        | otherwise = NoAction

src/Dodge/Creature/Test.hs

@@ -29,7 +29,6 @@ import Dodge.Creature.Radius
 import Dodge.Data.Equipment.Misc
 import Dodge.Data.AimStance
 import Control.Lens
-import Data.List (find)
 import Data.Maybe
 import Dodge.Base.Collide
 import Dodge.Data.World
@@ -81,12 +80,9 @@ crStratConMatches strat cr = strat == _apStrategy (_crActionPlan cr)
 -- this equality check might be slow...
 
 crAwayFromPost :: Creature -> Bool
-crAwayFromPost cr = case find sentinelGoal . _apGoal $ _crActionPlan cr of
+crAwayFromPost cr = case _apGoal $ _crActionPlan cr of
-    Just (SentinelAt p _) -> dist p (cr ^. crPos . _xy) > 15
+    SentinelAt p _ -> dist p (cr ^. crPos . _xy) > 15
     _ -> False
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
 
 crInAimStance :: AimStance -> Creature -> Bool
 crInAimStance as cr = cr ^? crStance . posture == Just Aiming
@@ -133,12 +129,19 @@ isAnimate :: Creature -> Bool
 {-# INLINE isAnimate #-}
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
-    SlimeIntelligence -> False
+    SlimeIntelligence -> True
     ActionPlan{} -> True
 
 hasAutoDoorBody :: Creature -> Bool
-hasAutoDoorBody cr = case cr ^. crHP of
+hasAutoDoorBody cr = crittype && notdestroyed
-    HP {} -> True
+  where
-    CrIsCorpse {} -> True
+    notdestroyed = case cr ^. crHP of
-    CrDestroyed {} -> False
+        HP {} -> True
+        CrIsCorpse {} -> True
+        AvatarDestroyed {} -> False
+    crittype = case cr ^. crType of
+        SlimeCrit {} -> False
+        BeeCrit {} -> False
+        HiveCrit {} -> False
+        _ -> True
     

src/Dodge/Creature/Update.hs

@@ -2,10 +2,11 @@
 
 module Dodge.Creature.Update (updateCreature) where
 
---import Dodge.WorldEvent.ThingsHit
+import Dodge.Creature.Slime
+import Dodge.Creature.Radius
+import Dodge.Creature.MoveType
 import Dodge.Base.Collide
 import Data.List (sortOn)
-import Dodge.Creature.Radius
 import Dodge.Zoning.Creature
 import Dodge.Creature.ChaseCrit
 import Dodge.Creature.Damage
@@ -15,7 +16,6 @@ import qualified IntMapHelp as IM
 import Data.Maybe
 import Dodge.Barreloid
 import Dodge.Base.You
--- import Dodge.Base.NewID
 import Dodge.Creature.Action
 import Dodge.Creature.Picture
 import Dodge.Creature.State
@@ -45,17 +45,14 @@ import qualified Data.IntSet as IS
 -- allow for knockbacks etc to be determined as well as intended movements
 updateCreature :: Creature -> World -> World
 updateCreature cr
-    | cr ^. crPos . _z < negate 300 = (tocr . crHP .~ CrDestroyed Pitted) . destroyAllInvItems cr
+    | cr ^. crPos . _z < negate 300 = (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature) 
+        . destroyAllInvItems cr
     | otherwise = case cr ^. crHP of
-        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . damageCorpse (_crID cr) cr
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . applyCreatureDamage (_crID cr) cr
-        CrDestroyed{} -> id
+        AvatarDestroyed{} -> id
         HP{} -> cleardamage . updateLivingCreature cr
   where
-    cleardamage = tocr . crDamage .~ mempty
+    cleardamage = cWorld . lWorld . creatures . ix (cr^.crID) . crDamage .~ mempty
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
-
-damageCorpse :: Int -> Creature -> World -> World
-damageCorpse _ cr w = w & applyCreatureDamage (cr ^. crDamage) cr
 
 updateLivingCreature :: Creature -> World -> World
 updateLivingCreature cr = case cr ^. crType of
@@ -65,16 +62,12 @@ updateLivingCreature cr = case cr ^. crType of
             . yourControl
     LampCrit{} -> updateLampoid cr
     BarrelCrit bt -> updateBarreloid bt cr
-    ChaseCrit{} -> \w ->
+    ChaseCrit{} -> crUpdate cid . performActions cid . updateChaseCrit cid
-        crUpdate cid . performActions cid $
+    CrabCrit{} -> crUpdate cid . performActions cid . crabCritInternal cid
-            over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
-    CrabCrit{} ->
-        crUpdate cid . performActions cid . crabCritInternal cid
     AutoCrit{} -> crUpdate cid
     SwarmCrit{} -> crUpdate cid
-    HoverCrit{} -> \w ->
+    HoverCrit{} -> crUpdate cid . performActions cid . hoverCritHoverSound cr .
-        crUpdate cid . performActions cid . hoverCritHoverSound cr $
+            updateHoverCrit cid
-            over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
     SlinkCrit{} -> slinkCritUpdate cid
     SlimeCrit{} -> slimeCritUpdate cid
     BeeCrit{} -> crUpdate cid . performActions cid . updateBeeFromPheremones cr cid . updateBeeCrit cr cid
@@ -87,16 +80,20 @@ updateHiveCrit cr cid w
     | Just x <- cr ^? crType . hiveChildren . to IS.size
     , x < nbees
     , Just y <- cr ^? crType . hiveGestation
-    , y == 0 = w 
+    , y == 0 
+    , Just z <- cr ^? crType . hiveSlime
+    , z >= 400
+        = w 
         & tocr . crType . hiveChildren %~ IS.insert nid
         & tocr . crType . hiveGestation .~ 50
         & cWorld . lWorld . creatures . at nid ?~ ncr
+        & tocr . crType . hiveSlime -~ 400
     | Just x <- cr ^? crType . hiveChildren . to IS.size
     , x < nbees = w
         & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
     | otherwise = w
   where
-    nbees = 10
+    nbees = 15
     tocr = cWorld . lWorld . creatures . ix cid
     nid = IM.newKey $ w ^. cWorld . lWorld . creatures
     ncr = beeCrit & crPos .~ (cr ^. crPos + (0 & _xy +~ 25))
@@ -105,78 +102,136 @@ updateHiveCrit cr cid w
 
 updateBeeFromPheremones :: Creature -> Int -> World -> World
 updateBeeFromPheremones cr cid w
-    | any f (w ^. cWorld . lWorld . beePheremones) = w & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
+    | any f (w ^. cWorld . lWorld . beePheremones) = w 
+        & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
     | otherwise = w
   where
-    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos) < 20
+    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos . _xy) < 20
 
 updateBeeCrit :: Creature -> Int -> World -> World
-updateBeeCrit cr
+updateBeeCrit cr cid
-    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr cid
-    | otherwise = updateCalmBee cr
+    | otherwise = beeLifespanCheck cr cid . updateCalmBee cr cid
+
+beeLifespanCheck :: Creature -> Int -> World -> World
+beeLifespanCheck cr cid
+    | Just ls <- cr ^? crType . beeLifespan
+    , Just x <- cr ^? crType . beeSlime
+    , ls < 1
+    , x < 5
+        = cWorld . lWorld . creatures . ix cid . crHP . _HP -~ 1
+    | otherwise = id
 
 updateAggroBee :: Creature -> Int -> World -> World
 updateAggroBee cr cid w
-    | Just tcr <- listToMaybe . sortOn (distance cxy . (^. crPos . _xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
+    | Mounted{} <- cr ^. crStance . carriage = w & tocr . crStance . carriage .~ Flying 0 
+    | Just tcr <- atarget
+    , distance (tcr ^. crPos . _xy) (cr ^. crPos . _xy) < crRad (cr ^. crType) + crRad (tcr ^. crType) + 1
+    , nearZeroAngle (argV (tcr ^. crPos . _xy - cr ^. crPos . _xy) - cr ^. crDir) < pi / 2
+    , 0 <- cr ^?! crType . meleeCooldown
+        = w & tocr . crPos .~ (cr ^. crOldPos & _xy -~ 5 *^ unitVectorAtAngle (cr ^. crDir))
+            & tocr . crType . startStopMv .~ (cr ^?! to crMvType . mvPulseTime)
+            & cWorld . lWorld . creatures . ix (tcr ^. crID) . crDamage 
+                .:~ Blunt 50 (cxy + crRad (cr ^. crType) *^ vdir) vdir (CrMeleeO (cr ^. crID))
+            & tocr . crType . meleeCooldown .~ 20
+    | Just tcr <- atarget = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
         & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w & tocr . crType . beeAggro -~ 1
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
     | otherwise = w & tocr . crType . beeAggro -~ 1
-        & tocr . crActionPlan . apStrategy .~ Search
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+        & randGen .~ g 
   where
+    (p,g) = runState (randOnCirc 150) (w ^. randGen)
+    atarget = listToMaybe . sortOn (distance cxy . (^.crPos._xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w
+    vdir = unitVectorAtAngle (cr ^. crDir)
     cxy = cr ^. crPos . _xy
     tocr = cWorld . lWorld . creatures . ix cid
-    istarget tcr = tcr ^. crID == 0
+    istarget tcr = t (tcr ^. crType)
+        && isJust (tcr ^? crHP . _HP)
         && hasLOS cxy (tcr ^. crPos . _xy) w
+    t = \case
+        Avatar{} -> True
+        ChaseCrit{} -> True
+        CrabCrit{} -> True
+        _ -> False
 
 -- do bees need to be able to see slime targets?
 -- if no path can be made, reset harvest action
+-- this should all be simplified
+-- should count how many are mounted on an individual slime, try for a different
+-- slime if too many
 updateCalmBee :: Creature -> Int -> World -> World
 updateCalmBee cr cid w 
     | Just hcr <- gethive
     , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
     , Just x <- cr ^? crType . beeSlime 
-    , x >= 0.5
+    , x >= 50 = w 
-        = w & tocr . crType . beeSlime -~ 0.5
+        & tocr . crType . beeSlime -~ 50
-    | Just hcr <- gethive
+        & cWorld . lWorld . creatures . ix (hcr ^. crID) . crType . hiveSlime +~ 50
-    , Just _ <- cr ^? crStance . carriage . mountID
+    | Just x <- cr ^? crType . beeSlime 
-    , Just x <- cr ^? crType . beeSlime 
+    , x < 50
-    , x >= 15
+    , Just hcr <- gethive
-        = w & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
-            & tocr . crStance . carriage .~ Flying 0
+    , Just ReturnToHive <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just ReturnToHive <- cr ^? crActionPlan . apStrategy = w 
+    | Just x <- cr ^? crType . beeSlime 
+    , x >= 1500 = starthivereturn
+        & randGen .~ gsa
+        & tocr . crType . beeLifespan %~ max 0 . subtract sa
     | Just mid <- cr ^? crStance . carriage . mountID
-    , mountshakeoff mid = w & tocr . crActionPlan . apStrategy .~ Search
+    , mountshakeoff mid = startsearch
-            & tocr . crStance . carriage .~ Flying 0
-    | Just hcr <- gethive
-    , Just x <- cr ^? crType . beeSlime 
-    , x >= 15
-        = w & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
     | Nothing <- cr ^? crActionPlan . apStrategy . harvestTarget 
-    ,  Just tcr <- listToMaybe . sortOn (distance cxy . (^. crPos . _xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w =
+    ,  xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g') <- runState (takeOne xs) (w ^. randGen) =
          w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+            & randGen .~ g'
     | Just tid <- cr ^? crStance . carriage . mountID
     , Just SlimeCrit{} <- w ^? cWorld . lWorld . creatures . ix tid . crType = w
         & tocr . crType . beeSlime +~ sspeed
-        & cWorld . lWorld . creatures . ix tid . crType . slimeRad %~ (sqrt . subtract sspeed . (^(2::Int)))
+        & cWorld . lWorld . creatures . ix tid . crType . slimeSlime -~ sspeed
     | Just (tcr,ti) <- gettarg
-    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.9*crRad (tcr ^. crType) 
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.8*crRad (tcr ^. crType) 
-    , Just r <- tcr ^? crType . slimeRad
     , Just d <- tcr ^? crType . slimeCompression
         = w
-        & tocr . crStance . carriage .~ Mounted ti (cr ^. crPos - tcr ^. crPos & _xy %~ compressionScale (vNormal ((1/r) *^d)))
+        & tocr . crStance . carriage .~ Mounted ti (cr ^. crPos - tcr ^. crPos & _x %~ (/d) & _y *~ d)
         & tocr . crActionPlan . apAction .~ NoAction
     | Just (tcr,_) <- gettarg = w
             & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
-    | otherwise = w & tocr . crActionPlan . apStrategy .~ Search
+    | Just (HarvestFrom{}) <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just (SearchTimed 0) <- cr ^? crActionPlan . apStrategy = starthivereturn
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w
+        & tocr . crActionPlan . apStrategy . searchTimer %~ (max 0 . subtract 1)
+    | otherwise = startsearch
   where
+    (sa,gsa) = runState (takeOne [0,1]) (w ^. randGen)
+    starthivereturn = fromMaybe w $ do
+        hcr <- gethive
+        return $ w
+            & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+            & tocr . crActionPlan . apStrategy .~ ReturnToHive
+            & tocr . crStance . carriage %~ dounmount
+    dounmount x = case x of
+        Flying{} -> x
+        _ -> Flying 0
+    startsearch = w
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crStance . carriage %~ dounmount
+        & randGen .~ g
+        & tocr . crActionPlan . apStrategy .~ SearchTimed 200
+    (p,g) = runState (randOnCirc 200) (w ^. randGen)
     cxy = cr ^. crPos . _xy
     mountshakeoff mid = fromMaybe True $ do
         mcr <- w ^? cWorld . lWorld . creatures . ix mid
         SlimeCrit {_slimeSplitTimer = x} <- mcr ^? crType
-        return $ x > 0
+        return $ isJust x
-    sspeed = 0.05
+    sspeed = 5
     gettarg = do
         i <- cr ^? crActionPlan . apStrategy . harvestTarget 
         tcr <-  w ^? cWorld . lWorld . creatures . ix i
-        x <- tcr ^? crType . slimeRad
+        x <- tcr ^? crType . slimeSlime . to slimeToRad
         guard $ x > 12
         return (tcr,i)
     gethive = do
@@ -184,42 +239,41 @@ updateCalmBee cr cid w
         w ^? cWorld . lWorld . creatures . ix i
     tocr = cWorld . lWorld . creatures . ix cid
     istarget tcr = fromMaybe False $ do
-        r <- tcr ^? crType . slimeRad
+        r <- tcr ^? crType . slimeSlime . to slimeToRad
         return $ r > 12
 
 slimeCritUpdate :: Int -> World -> World
 slimeCritUpdate cid w 
-    | r < 5 = w & cWorld . lWorld . creatures . ix cid . crHP .~ CrDestroyed Gibbed
+    | r < 5 = w & cWorld . lWorld . creatures . at cid .~ Nothing
     | Just hitp <- w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmPos
         , Just hitv <-  w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmVector
---        , Just (cr1,cr2) <- splitSlimeCrit hitp hitv cr
---            = 
---        let cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
---        in w & cWorld . lWorld . creatures . ix cid .~ cr1
---            & cWorld . lWorld . creatures . at cid' ?~ (cr2 & crID .~ cid')
         , Just w' <- splitSlimeCrit' hitp hitv cid cr w = w'
-    | (cr ^?! crType . slimeIsCompressing) && r > norm p
+    | (cr ^?! crType . slimeIsCompressing) && 1 > p
         = let (w',g) = runState (setSlimeDir cid (cr & crDamage .~ []) w) (w ^. randGen)
             in w' & randGen .~ g
     | otherwise = updateCarriage cid $ w
         & cWorld . lWorld . creatures . ix cid .~ mvslime
         & cWorld . lWorld . creatures . ix cid . crDamage .~ []
         & tocr %~ doSlimeRadChange
-        & tocr . crType . slimeSplitTimer %~ (max 0 . subtract 1)
+        & tocr . crType . slimeSplitTimer %~ fsst
         & tocr . crType . slimeEngulfProgress %~ (max 0 . subtract 0.5)
   where
+    fsst Nothing = Nothing
+    fsst (Just (x,ps))
+        | x > 0 = Just (x-1,ps)
+        | otherwise = Nothing
     tocr = cWorld . lWorld . creatures . ix cid
     cr = w ^?! cWorld . lWorld . creatures . ix cid
-    v = 0.1 *^ normalize p 
+    v = 0.1 *^ unitVectorAtAngle (cr ^. crDir)
-    mvslime = cr & crType . slimeCompression +~ f v
+    mvslime = cr & crType . slimeCompression +~ f (0.1/r)
         & crPos . _xy +~ v
         & crType . slimeIsCompressing %~ f'
     f | t = negate
       | otherwise = id
-    f'  | norm p > 3*r/2 = const True
+    f'  | p > 1.5 = const True
         | otherwise = id
     t = cr ^?! crType . slimeIsCompressing
-    r = cr ^?! crType . slimeRad
+    r = cr ^?! crType . slimeSlime . to slimeToRad
     p = cr ^?! crType . slimeCompression
 
 setSlimeDir :: Int -> Creature -> World -> State StdGen World
@@ -230,24 +284,18 @@ setSlimeDir cid cr w = do
         then do
             x <- randInCirc 1
             return $ fromMaybe w $ splitSlimeCrit' (x + cxy) (unitVectorAtAngle d) cid cr w
---            let (cr1,cr2) = splitSlimeCrit (x + cxy) (unitVectorAtAngle d) cr ^?! _Just
+        else return $ w & tocr . crDir .~ d
---                cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
---            return $ w & tocr .~ cr1
---                & tocr' cid' ?~ (cr2 & crID .~ cid')
-        else return $ w & tocr . crType . slimeCompression .~ r *^ unitVectorAtAngle d
                 & tocr . crType . slimeIsCompressing .~ False
   where
     tocr = cWorld . lWorld . creatures . ix cid
---    tocr' i = cWorld . lWorld . creatures . at i
     cxy = cr ^. crPos . _xy
-    r = cr ^?! crType . slimeRad
+    r = cr ^?! crType . slimeSlime . to slimeToRad
-    
 
 doSlimeRadChange :: Creature -> Creature
-doSlimeRadChange = crType . slimeRadWobble %~ f
+doSlimeRadChange = crType . slimeSlimeChange %~ f
   where
-    f x | x > 1 = x - 1
+    f x | x > 1000 = x - 1000
-        | x < -1 = x + 1
+        | x < -1000 = x + 1000
         | otherwise = 0
 
 splitSlimeCrit' :: Point2 -> Point2 -> Int -> Creature -> World -> Maybe World
@@ -272,24 +320,32 @@ splitSlimeCrit p v cr = do
         mvdir 
             | isLHS p (p+v) cxy = normalize (vNormal v)
             | otherwise = - normalize (vNormal v)
-    return (cr' & crPos . _xy .~ mp + (r1 + 0.51) *^ mvdir
+        (ps',qs') 
-                & crType . slimeRad .~ r1
+            | isLHS p (p+v) cxy = (ps,qs)
-                & crType . slimeCompression .~ rotateV (argV mvdir) (V2 r1 0)
+            | otherwise = (qs,ps)
+        c1 = cr' & crPos . _xy .~ mp + r1 *^ mvdir
+                & crType . slimeSlime .~ round (r1 ^ (2 :: Int) * 100)
                 & crDir .~ argV mvdir
-        ,cr' & crPos . _xy .~ mp - (r2 + 0.51) *^ mvdir
+        c2 = cr' & crPos . _xy .~ mp - r2 *^ mvdir
-                & crType . slimeRad .~ r2
+                & crType . slimeSlime .~ round (r2^(2::Int) * 100)
-                & crType . slimeCompression .~ rotateV (argV (-mvdir)) (V2 r2 0)
                 & crDir .~ argV (-mvdir)
-                & crType . slimeEngulfProgress .~ 0
+        c1ps = qs' & each +~ cxy - (mp + r1 *^ mvdir) & each %~ rotateV (- c1 ^. crDir)
+        c2ps = ps' & each +~ cxy - (mp - r2 *^ mvdir) & each %~ rotateV (- c2 ^. crDir)
+    return (c1 & crType . slimeSplitTimer . _Just . _2 .~ f c1ps c1
+        ,c2 & crType . slimeSplitTimer . _Just . _2 .~ f c2ps c2
         )
   where
+    f xs@(_:_) c = polyInPoly (centroid xs) xs (slimeOutline c)
+    f _ _ = mempty
     cxy = cr ^. crPos . _xy
-    r = cr ^?! crType . slimeRad
+    r = cr ^?! crType . slimeSlime . to slimeToRad
     cr' = cr & crDamage .~ []
-        & crType . slimeRadWobble .~ 0
+        & crType . slimeSlimeChange .~ 0
-        & crType . slimeSplitTimer .~ 10
+        & crType . slimeSplitTimer .~ Just (10, mempty)
         & crType . slimeIsCompressing .~ False
-
+        & crType . slimeCompression .~ 1 -- rotateV (argV mvdir) (V2 r1 0)
+    (ps,qs) = cutPoly (p-cxy) (p+v-cxy) $ slimeOutline cr & each %~ rotateV (cr ^. crDir)
+    
 -- h is the height of the segment, ie r - distance to center
 segmentArea :: Float -> Float -> Float
 segmentArea r h = r*r*acos(1-h/r) - (r-h)*sqrt(h*(2*r-h))
@@ -307,9 +363,6 @@ slinkCritUpdate cid w =
         . _2
         *~ Q.axisAngle (V3 0 1 0) (pi / 1000)
 
--- spineWalk :: [Point3Q]
--- spineWalk = replicate 15 (V3
-
 hoverCritHoverSound :: Creature -> World -> World
 hoverCritHoverSound cr w = fromMaybe w $ do
     guard $ d < 100
@@ -346,9 +399,7 @@ checkDeath cid w = maybe id checkDeath' (w ^? cWorld . lWorld . creatures . ix c
 checkDeath' :: Creature -> World -> World
 checkDeath' cr w = case cr ^. crHP of
     HP x | x > 0 -> w
-    HP x
+    HP x | x > -200 && null (cr ^. crDeathTimer) -> w & tocr %~ startDeathTimer
-        | x > -200 && null (cr ^. crDeathTimer) ->
-            w & tocr %~ startDeathTimer
     HP x
         | x > -200
         , Just y <- cr ^. crDeathTimer
@@ -371,11 +422,15 @@ crDeathEffects cr w = case cr ^. crType of
         return $ w & cWorld . lWorld . creatures . ix hid . crType . hiveChildren %~ IS.delete (cr ^. crID)
     _ -> w
   where
-    beepheremone = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos . _xy) 200
+    beepheremone 
+        | Just x <- cr ^? crType . beeLifespan
+        ,   x < 1 = id
+        | otherwise = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos) (cr ^. crPos - cr ^. crOldPos) 200
 
 startDeathTimer :: Creature -> Creature
 startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
             HoverCrit{} -> 0
+            BeeCrit{} -> 0
             _ -> 5
 
 toDeathCarriage :: Carriage -> Carriage
@@ -397,7 +452,7 @@ corpseOrGib cr w =
         Just PhysicalDamage
             | _crPain cr > 300 ->
                 makeCrGibs cr
-                    . sethp (CrDestroyed Gibbed)
+                    . (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature)
                     . dodeathsound GibsDeath
         _ ->
             sethp (CrIsCorpse thecorpse)
@@ -426,11 +481,6 @@ poisonSPic = _1 %~ overColSH (mixColors 0.5 0.5 green . normalizeColor)
 dropAll :: Creature -> World -> World
 dropAll cr w = foldl' (flip (dropItem cr)) w . reverse . IM.keys . _unNIntMap $ _crInv cr
 
--- startFalling :: Creature -> Creature
--- startFalling cr = case cr ^. crStance . carriage of
---    Walking -> cr & crStance . carriage .~ Falling
---    _ -> cr & crStance . carriage .~ Falling
-
 updatePulse :: Pulse -> Pulse
 updatePulse p
     | p ^. pulseProgress >= p ^. pulseRate = p & pulseProgress .~ 0

src/Dodge/CreatureEffect.hs

@@ -36,18 +36,9 @@ doCrBl cb = case cb of
     CrIsAnimate -> isAnimate
     CrOpenAutoDoor -> \cr -> isAnimate cr && hasAutoDoorBody cr
 
-doCrAc :: CrAc -> Creature -> Action
+--doCrWdAc :: CrWdAc -> Creature -> World -> Action
-doCrAc ca = case ca of
+--doCrWdAc cw = case cw of
-    CrTurnAround -> \cr -> TurnToPoint 
+--    CrWdBFSThenReturn _ -> const $ const NoAction
-        (cr ^. crPos . _xy -.- 10 *.* unitVectorAtAngle (_crDir cr))
---    CrFleeFromTarget -> fleeFromTarget
-
---fleeFromTarget :: Creature -> Action
---fleeFromTarget cr = fleeFrom cr (_targetCr (_crIntention cr))
-
-doCrWdAc :: CrWdAc -> Creature -> World -> Action
-doCrWdAc cw = case cw of
-    CrWdBFSThenReturn _ -> const $ const NoAction
 --    CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
 --        n <- walkableNodeNear w (cr ^. crPos . _xy)
 --        let as = take 20 $ map PathTo $ bfsNodePoints n w
@@ -56,7 +47,7 @@ doCrWdAc cw = case cw of
 --            DoReplicate t $
 --                foldr DoActionThen NoAction as
 --    ChooseMovementSpreadGun -> chooseMovementSpreadGun
-    ChooseMovementLtAuto -> chooseMovementLtAuto
+--    ChooseMovementLtAuto -> chooseMovementLtAuto
 
 --chooseMovementSpreadGun :: Creature -> World -> Action
 --chooseMovementSpreadGun cr w

src/Dodge/Data/ActionPlan.hs

@@ -17,8 +17,8 @@ data ActionPlan
     | ActionPlan
         { -- _apImpulse :: [Impulse] -- done per frame
          _apAction :: Action -- updated per frame, likely persist across frames
-        , _apStrategy :: Strategy -- current strategy
+        , _apStrategy :: Strategy
-        , _apGoal :: [Goal] -- particular ordered goals
+        , _apGoal :: Goal
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     deriving (Eq, Ord, Show) --Generic, Flat)
@@ -45,10 +45,11 @@ data Impulse
     | ChangePosture Posture
     | MakeSound SoundID
     | ChangeStrategy Strategy
-    | AddGoal Goal
+--    | AddGoal Goal
     | ImpulseUseTarget { _impulseUseTarget :: CrImp }
     | ImpulseNothing
     | UpdateRandGen
+    | SetBeeRandomMovement
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data RandImpulse
@@ -120,9 +121,9 @@ data Action
         }
     | LeadTarget { _leadTargetBy :: Point2 }
     | NoAction
-    | StartSentinelPost
+--    | StartSentinelPost
-    | UseSelf { _useSelf :: CrAc }
+--    | UseSelf { _useSelf :: CrAc }
-    | ArbitraryAction {_arbitraryAction :: CrWdAc}
+--    | ArbitraryAction {_arbitraryAction :: CrWdAc}
 -- | Repeatedly perform impulses alongside a main action until the main action terminates
     | DoImpulsesAlongside
         { _sideImpulses :: [Impulse]
@@ -144,13 +145,13 @@ data Strategy
     | LookAround
     | Wander
     | CloseToMelee {_meleeTarget :: Int}
-    | StrategyActions Strategy [Action]
     | GetTo Point2
---    | Reload
     | Flee
---    | MeleeStrike
     | Search
+    | SearchTimed {_searchTimer :: Int}
+    | ReturnToHive
     | HarvestFrom {_harvestTarget :: Int}
+    | StrategyInt {_strategyInt :: Int}
     deriving (Eq, Ord, Show) --Generic, Flat)
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Bullet.hs

@@ -20,6 +20,7 @@ data Bullet = Bullet
     , _buDrag :: Float
     , _buPos :: Point2
     , _buOldPos :: Point2
+    , _buOrigin :: DamageOrigin
     }
     deriving (Show, Eq, Ord, Read) --Generic, Flat)
 

src/Dodge/Data/CamouflageStatus.hs

@@ -1,10 +0,0 @@
-{-# LANGUAGE StrictData #-}
-
-module Dodge.Data.CamouflageStatus where
-
-data CamouflageStatus
-    = FullyVisible
-    | Invisible
-    deriving (Eq, Ord, Enum, Show, Bounded, Read) --Generic, Flat)
-
---deriveJSON defaultOptions ''CamouflageStatus

src/Dodge/Data/Cloud.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Cloud where
 
+import Dodge.Data.Damage
 import Dodge.Data.Material
 import Control.Lens
 import Data.Aeson
@@ -36,6 +37,7 @@ data Gas = Gas
     , _gsVel :: Point3
     , _gsTimer :: Int
     , _gsType :: GasType
+    , _gsOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
@@ -43,7 +45,8 @@ data GasType = PoisonGas
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BeePheremone = BPheremone
-    { _bpPos :: Point2
+    { _bpPos :: Point3
+    , _bpVel :: Point3
     , _bpTimer :: Int
     }
 

src/Dodge/Data/Config.hs

@@ -108,6 +108,8 @@ data DebugBool
     | Show_writable_values
     | Show_mouse_click_pos
     | Muzzle_positions
+    | Show_cr_hitboxes
+    | Clipboard_cr
     deriving (Eq, Ord, Bounded, Enum, Show)
 
 data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes

src/Dodge/Data/Creature.hs

@@ -63,7 +63,14 @@ data Creature = Creature
 data CrHP
     = HP Int
     | CrIsCorpse SPic
-    | CrDestroyed CrDestructionType
+    | AvatarDestroyed
+--    | CrDestroyed CrDestructionType
+
+destroyCreature :: Maybe Creature -> Maybe Creature
+destroyCreature mcr
+    | Just cr <- mcr
+    , _crID cr == 0 = Just cr{_crHP = AvatarDestroyed}
+    | otherwise = Nothing
 
 data CrDestructionType = Gibbed | Pitted | Swallowed
 

src/Dodge/Data/Creature/Misc.hs

@@ -1,17 +1,13 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Dodge.Data.Creature.Misc (
+module Dodge.Data.Creature.Misc (module Dodge.Data.Creature.Misc) where
-    module Dodge.Data.Creature.Misc,
-    module Dodge.Data.CamouflageStatus,
-) where
 
 import Dodge.Data.Creature.Stance
 import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import Dodge.Data.CamouflageStatus
 import Dodge.Data.FloatFunction
 import Dodge.Data.Material
 import Geometry.Data
@@ -36,6 +32,11 @@ data CrMvType
         , _mvTurnSpeed :: Float
         , _mvPulseTime :: Int
         }
+    | BeeMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Pulse = PulseStatus
@@ -73,28 +74,37 @@ data CreatureType
         , _slinkHeadPos :: Point3Q
         }
     | SlimeCrit
-        { _slimeRad :: Float
+        { _slimeSlime :: Int -- note multiplied by 100
-        , _slimeRadWobble :: Float
+        , _slimeSlimeChange :: Int
-        , _slimeSplitTimer :: Int
+--        , _slimeRadWobble :: Float
-        , _slimeCompression :: Point2
+        --, _slimeSplitTimer :: Int
+        , _slimeSplitTimer :: Maybe (Int, [Point2])
+        , _slimeCompression :: Float
         , _slimeIsCompressing :: Bool
         , _slimeEngulfProgress :: Float
         } 
     | BeeCrit
-        { _beeSlime :: Float
+        { _beeSlime :: Int
         , _beeHive :: Maybe Int
         , _startStopMv :: Int
         , _beeAggro :: Int
+        , _meleeCooldown :: Int
+        , _beeRandomMovement :: Maybe FootForward
+        , _beeLifespan :: Int
         }
     | HiveCrit
         { _hiveChildren :: IS.IntSet
         , _hiveGestation :: Int
+        , _hiveSlime :: Int
         }
     | SwarmCrit
     | AutoCrit
     | BarrelCrit {_barrelType :: BarrelType}
     | LampCrit {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int}
 
+slimeToRad :: Int -> Float
+slimeToRad x = sqrt $ fromIntegral x * 0.01
+
 data AvatarPosture = AvPosture
 
 data CreatureShape

src/Dodge/Data/CreatureEffect.hs

@@ -24,14 +24,14 @@ data CrBl = CrCanShoot | CrIsAiming | CrIsAnimate
 data CrAc = CrTurnAround
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
-data CrWdAc
+--data CrWdAc
-    = CrWdBFSThenReturn Int
+--    = CrWdBFSThenReturn Int
---    | ChooseMovementSpreadGun
+----    | ChooseMovementSpreadGun
-    | ChooseMovementLtAuto
+----    | ChooseMovementLtAuto
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+--    deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 deriveJSON defaultOptions ''CrImp
 deriveJSON defaultOptions ''CrBl
 deriveJSON defaultOptions ''WdCrBl
 deriveJSON defaultOptions ''CrAc
-deriveJSON defaultOptions ''CrWdAc
+--deriveJSON defaultOptions ''CrWdAc

src/Dodge/Data/Damage.hs

@@ -13,20 +13,32 @@ import Data.Aeson.TH
 import Geometry.Data
 
 data Damage
-    = Piercing {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2}
+    = Piercing {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
-    | Blunt {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2}
+    | Blunt {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
-    | Sparking {_dmAmount :: Int}
+    | Sparking {_dmAmount :: Int, _dmOrigin :: DamageOrigin}
-    | Crushing {_dmAmount :: Int, _dmVector :: Point2}
+    | Crushing {_dmAmount :: Int, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
-    | Shattering {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2}
+    | Shattering {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
-    | Flaming {_dmAmount :: Int}
+    | Flaming {_dmAmount :: Int, _dmOrigin :: DamageOrigin}
-    | Lasering {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2}
+    | Lasering {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
-    | Flashing {_dmAmount :: Int, _dmPos :: Point2}
+    | Flashing {_dmAmount :: Int, _dmPos :: Point2, _dmOrigin :: DamageOrigin}
-    | Electrical {_dmAmount :: Int}
+    | Electrical {_dmAmount :: Int, _dmOrigin :: DamageOrigin}
-    | Explosive {_dmAmount :: Int, _dmCenter :: Point2}
+    | Explosive {_dmAmount :: Int, _dmOrigin :: DamageOrigin, _dmCenter :: Point2}
-    | Poison {_dmAmount :: Int}
+    | Poison {_dmAmount :: Int, _dmOrigin :: DamageOrigin}
-    | Enterrement {_dmAmount :: Int}
+    | Enterrement {_dmAmount :: Int, _dmOrigin :: DamageOrigin}
-    | Inertial {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2}
+    | Inertial {_dmAmount :: Int, _dmPos :: Point2, _dmVector :: Point2, _dmOrigin :: DamageOrigin}
+    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+
+data DamageOrigin 
+    = CrMeleeO { _doCID :: Int}
+    | CrWeaponO { _doCID :: Int}
+    | CrIndirectO {_doCID :: Int}
+    | McMeleeO { _doMID :: Int}
+    | McWeaponO { _doMID :: Int}
+    | McIndirectO {_doMID :: Int}
+    | UnassignedO
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''Damage
+makeLenses ''DamageOrigin
+deriveJSON defaultOptions ''DamageOrigin
 deriveJSON defaultOptions ''Damage

src/Dodge/Data/EnergyBall.hs

@@ -6,6 +6,7 @@ module Dodge.Data.EnergyBall (
     module Dodge.Data.EnergyBall.Type,
 ) where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -17,6 +18,7 @@ data EnergyBall = EnergyBall
     , _ebPos :: Point3
     , _ebTimer :: Int
     , _ebType :: EnergyBallType
+    , _ebOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/EnergyBall/Type.hs

@@ -8,11 +8,11 @@ import Data.Aeson
 import Data.Aeson.TH
 
 data EnergyBallType
-    = IncendiaryBall
+    = IncendiaryBall{}
     | FlameletBall {_fbSize :: Float}
     | ElectricalBall {_ebID :: Int}
-    | ExplosiveBall
+    | ExplosiveBall{}
-    | FlashBall
+    | FlashBall{}
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''EnergyBallType

src/Dodge/Data/Flame.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Flame where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -12,6 +13,7 @@ data Flame = Flame
     { _flTimer :: Int
     , _flPos :: Point2
     , _flVel :: Point2
+    , _flOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Laser.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Laser where
 
+import Dodge.Data.Damage
 import NewInt
 import Dodge.Data.Item.Location
 --import Color
@@ -21,6 +22,7 @@ data Laser = Laser
     , _lpPos :: Point2
     , _lpDir :: Float
     , _lpType :: LaserType
+    , _lpOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/PlasmaBall.hs

@@ -1,10 +1,9 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Dodge.Data.PlasmaBall (
+module Dodge.Data.PlasmaBall (module Dodge.Data.PlasmaBall) where
-    module Dodge.Data.PlasmaBall
-) where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -14,6 +13,7 @@ data PlasmaBall = PBall
     { _pbType :: PlasmaBallType
     , _pbVel :: Point2
     , _pbPos :: Point2
+    , _pbOrigin :: DamageOrigin
     }
     deriving (Show, Eq, Ord, Read) --Generic, Flat)
 

src/Dodge/Data/Projectile.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Projectile where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -24,6 +25,7 @@ data Projectile = Shell
     , _pjType :: ProjectileType
     , _pjDetonatorID :: Maybe (NewInt ItmInt)
     , _pjScreenID :: Maybe (NewInt ItmInt)
+    , _pjOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/PulseLaser.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.PulseLaser where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -14,6 +15,7 @@ data PulseLaser = PulseLaser
     , _pzDir :: Float
     , _pzDamage :: Int
     , _pzTimer :: Int
+    , _pzOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
@@ -22,6 +24,7 @@ data PulseBall = PulseBall
     , _pzbPos :: Point2
     , _pzbTimer :: Int
     , _pzbID :: Int
+    , _pzbOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Shockwave.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Shockwave where
 
+import Dodge.Data.Damage
 import Color
 import Control.Lens
 import Data.Aeson
@@ -22,6 +23,7 @@ data Shockwave = Shockwave
     , _swPush :: Float
     , _swMaxTime :: Int
     , _swTimer :: Int
+    , _swOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/TeslaArc.hs

@@ -6,6 +6,7 @@ module Dodge.Data.TeslaArc (
     module Dodge.Data.ArcStep,
 ) where
 
+import Dodge.Data.Damage
 import Color
 import Control.Lens
 import Data.Aeson
@@ -16,6 +17,7 @@ data TeslaArc = TeslaArc
     { _taTimer :: Int
     , _taArcSteps :: [ArcStep]
     , _taColor :: Color
+    , _taOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Debug.hs

@@ -2,6 +2,9 @@
 
 module Dodge.Debug (debugEvents, drawDebug) where
 
+import Dodge.Base.Coordinate
+import Dodge.Zoning.Creature
+import Dodge.Creature.Radius
 import Geometry.Data
 import Dodge.Render.Label
 import Dodge.HeldUse
@@ -24,6 +27,7 @@ import Picture.Base
 import qualified SDL
 import System.Hclip
 import Text.Read
+import Data.List (sortOn)
 
 debugEvents :: Universe -> Universe
 debugEvents u = case dbools ^. at Display_debug of
@@ -81,6 +85,15 @@ debugEvent' = \case
     Debug_get -> id
     Debug_put -> id
     Muzzle_positions -> id
+    Show_cr_hitboxes -> id
+    Clipboard_cr -> clipboardCr
+
+clipboardCr :: Universe -> Universe
+clipboardCr u = fromMaybe u $ do
+    guard (u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0)
+    return $ u & uvIOEffects %~ (\m u' -> setClipboard s >> m u')
+  where
+    s = unlines . prettyShort $ closestCrToMouse $ u ^. uvWorld
 
 debugItem :: DebugBool -> Universe -> Maybe [DebugItem]
 debugItem = \case
@@ -117,6 +130,8 @@ debugItem = \case
     Debug_get -> doDebugGet
     Debug_put -> debugPutItems
     Muzzle_positions -> mempty
+    Show_cr_hitboxes -> mempty
+    Clipboard_cr -> mempty
 
 debugGet :: Universe -> [String]
 debugGet u = foldMap getPretty $ u ^. uvWorld . cWorld . lWorld . shockwaves
@@ -287,7 +302,20 @@ drawDebug u = \case
     Show_writable_values -> mempty
     Show_mouse_click_pos -> mempty
     Muzzle_positions -> showMuzzlePositions u
+    Show_cr_hitboxes -> foldMap drawCreatureRad (u ^. uvWorld . cWorld . lWorld . creatures)
+    Clipboard_cr -> foldMap drawCreatureRad (closestCrToMouse $ u^.uvWorld)
 
+closestCrToMouse :: World -> Maybe Creature
+closestCrToMouse w = listToMaybe . sortOn (distance mwp . (^. crPos . _xy))
+        $ crsNearPoint mwp w
+  where
+    mwp = mouseWorldPos (w^.input) (w^.wCam)
+
+drawCreatureRad :: Creature -> Picture
+drawCreatureRad cr = setLayer DebugLayer
+    . translate3 (cr ^. crPos)
+    . color orange
+    $ circle (crRad (cr ^. crType))
 
 showMuzzlePositions :: Universe -> Picture
 showMuzzlePositions  u = fold $ do

src/Dodge/Default/Creature.hs

@@ -43,7 +43,7 @@ defaultCreature =
                 , _posture = AtEase
                 }
         , _crVocalization = VocReady
-        , _crActionPlan = ActionPlan NoAction (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper]
+        , _crActionPlan = ActionPlan NoAction WatchAndWait LiveLongAndProsper
         , _crPerception = defaultPerceptionState
         , _crMemory = defaultCreatureMemory
         , _crFaction = NoFaction

src/Dodge/EnergyBall.hs

@@ -18,33 +18,34 @@ import Linear.V3
 import Picture
 import RandomHelp
 
-makeFlamelet :: Point3 -> Point3 -> Float -> Int -> World -> World
+makeFlamelet :: DamageOrigin -> Point3 -> Point3 -> Float -> Int -> World -> World
-makeFlamelet p v s t =
+makeFlamelet o p v s t =
     cWorld . lWorld . energyBalls
         .:~ EnergyBall
             { _ebVel = v
             , _ebPos = p
             , _ebTimer = t
             , _ebType = FlameletBall s
+            , _ebOrigin = o
             }
 
 updateEnergyBall :: World -> EnergyBall -> (World, Maybe EnergyBall)
 updateEnergyBall w eb
     | _ebTimer eb <= 0 = (w, Nothing)
     | otherwise =
-        ( ebEffect eb . ebFlicker eb $ ebDamage (eb ^. ebPos) (_ebType eb) w
+        ( ebEffect eb . ebFlicker eb $ ebDamage eb w
         , Just $ eb & ebTimer -~ 1 & ebPos . _xy .~ bp & ebVel . _xy .~ drag * bv
         )
   where
     drag = case eb ^. ebType of
-        ExplosiveBall -> 0.9
+        ExplosiveBall{} -> 0.9
         _ -> 0.85
     p = (eb ^. ebPos + eb ^. ebVel) ^. _xy
     (bp, bv) = fromMaybe (p, eb ^. ebVel . _xy) $ bouncePoint (const True) 0 (eb ^. ebPos . _xy) p w
 
 ebEffect :: EnergyBall -> World -> World
 ebEffect eb = case _ebType eb of
-    ElectricalBall i ->
+    ElectricalBall {_ebID = i} ->
         soundContinue (EBSound i) (eb ^. ebPos . _xy) elecCrackleS (Just 2)
             . randSparkExtraVel
                 (eb ^. ebVel . _xy)
@@ -57,14 +58,15 @@ ebEffect eb = case _ebType eb of
             soundStart (EBSound (-1)) (eb ^. ebPos . _xy) fireFadeS Nothing
     _ -> id
 
-makeMovingEB :: Point2 -> EnergyBallType -> Point2 -> World -> World
+makeMovingEB :: Point2 -> EnergyBallType -> DamageOrigin -> Point2 -> World -> World
-makeMovingEB v ebt p =
+makeMovingEB v ebt o p =
     cWorld . lWorld . energyBalls
         .:~ EnergyBall
             { _ebVel = v `v2z` 0
             , _ebPos = p `v2z` 20
             , _ebTimer = 20
             , _ebType = ebt
+            , _ebOrigin = o
             }
 
 ebFlicker :: EnergyBall -> World -> World
@@ -79,21 +81,24 @@ ebColor eb = case eb ^. ebType of
     IncendiaryBall{} -> red
     FlameletBall{} -> red
     ElectricalBall{} -> cyan
-    ExplosiveBall -> white
+    ExplosiveBall{} -> white
-    FlashBall -> white
+    FlashBall{} -> white
 
-ebDamage :: Point3 -> EnergyBallType -> World -> World
+ebDamage :: EnergyBall -> World -> World
-ebDamage sp dt
+ebDamage eb
-    | z > 0 && z < 25 = damageInCircle (const $ ebtToDamage (sp ^. _xy) dt) (sp ^. _xy) r
+    | z > 0 && z < 25 = damageInCircle (const $ ebtToDamage (sp ^. _xy) o dt) (sp ^. _xy) r
     | otherwise = id
   where
+    sp = eb ^. ebPos
+    dt = eb ^. ebType
+    o = eb ^. ebOrigin
     z = sp ^. _z
     r = fromMaybe 5 $ dt ^? fbSize
 
-ebtToDamage :: Point2 -> EnergyBallType -> Damage
+ebtToDamage :: Point2 -> DamageOrigin -> EnergyBallType -> Damage
-ebtToDamage p = \case
+ebtToDamage p o = \case
-    FlameletBall{} -> Flaming 1
+    FlameletBall{} -> Flaming 1 o
-    IncendiaryBall{} -> Flaming 10
+    IncendiaryBall{} -> Flaming 10 o
-    ElectricalBall{} -> Electrical 10
+    ElectricalBall{} -> Electrical 10 o
-    ExplosiveBall -> Explosive 10 p
+    ExplosiveBall{} -> Explosive 10 o p
-    FlashBall -> Flashing 10 p
+    FlashBall{} -> Flashing 10 p o

src/Dodge/EnergyBall/Draw.hs

@@ -6,11 +6,11 @@ import Picture
 
 drawEnergyBall :: EnergyBall -> Picture
 drawEnergyBall eb = case _ebType eb of
-    FlameletBall x -> drawFlamelet x eb
+    FlameletBall {_fbSize=x} -> drawFlamelet x eb
-    IncendiaryBall -> drawFlamelet 5 eb
+    IncendiaryBall{} -> drawFlamelet 5 eb
     ElectricalBall{} -> drawStaticBall eb
-    ExplosiveBall -> drawExplosiveBall eb
+    ExplosiveBall{} -> drawExplosiveBall eb
-    FlashBall -> mempty
+    FlashBall{} -> mempty
 
 drawExplosiveBall :: EnergyBall -> Picture
 drawExplosiveBall eb =

src/Dodge/Flame.hs

@@ -29,7 +29,7 @@ updateFlame w pt
     reflame wl = pt & flTimer -~ 1 & flVel %~ reflVelWallDamp 0.9 wl
     doupdate =
         soundContinue FlameSound sp fireLoudS (Just 2) $
-            damageInCircle (const $ Flaming 1) ep r w
+            damageInCircle (const $ Flaming 1 (pt ^. flOrigin)) ep r w
     thit = List.safeHead $ thingsHit sp ep w
     sp = _flPos pt
     ep = sp + _flVel pt
@@ -43,10 +43,10 @@ flFlicker pt
             .:~ LSParam (addZ 10 $ _flPos pt) 70 (0.5 *.*.* xyzV4 red)
     | otherwise = id
 
-makeFlame :: Point2 -> Point2 -> World -> World
+makeFlame :: Point2 -> Point2 -> DamageOrigin -> World -> World
-makeFlame pos vel w =
+makeFlame pos vel d w =
     w
-        & cWorld . lWorld . flames .:~ Flame t pos vel
+        & cWorld . lWorld . flames .:~ Flame t pos vel d
         & randGen .~ g
   where
     (t, g) = randomR (99, 102) (_randGen w)

src/Dodge/Gas.hs

@@ -14,11 +14,11 @@ createGas gc = case gc of
 
 aGasCloud :: Float -> Point2 -> Float -> Creature -> World -> World
 aGasCloud pressure pos dir cr =
-    makeGasCloud pos $
+    makeGasCloud (CrWeaponO (cr ^. crID)) pos $
         (cr ^. crPos . _xy - cr ^. crOldPos . _xy) + pressure *^ unitVectorAtAngle dir
 
 aFlame :: Float -> Point2 -> Float -> Creature -> World -> World
-aFlame pressure pos dir cr = makeFlame pos vel
+aFlame pressure pos dir cr = makeFlame pos vel (CrWeaponO (cr ^. crID))
   where
     --w & instantParticles .:~ aFlameParticle t pos vel Nothing -- (Just $ _crID cr)
 

src/Dodge/HeldUse.hs

@@ -743,11 +743,11 @@ useLoadedAmmo
 useLoadedAmmo loc cr mz m w =
     makeMuzzleFlare pq loc (mz ^. mzFlareType) $ case _mzEffect mz of
         MuzzleShootBullet -> shootBullets loc cr (mz, x, magtree) w
-        MuzzleLaser -> creatureShootLaser pq' loc (w & randGen .~ g)
+        MuzzleLaser -> creatureShootLaser (CrWeaponO (cr ^. crID)) pq' loc (w & randGen .~ g)
         MuzzlePulseLaser -> creatureShootPulseLaser pq' cr (w & randGen .~ g)
-        MuzzlePulseBall -> shootPulseBall pq' (w & randGen .~ g)
+        MuzzlePulseBall -> shootPulseBall o pq' (w & randGen .~ g)
-        MuzzlePlasmaBall -> shootPlasmaBall pq' (w & randGen .~ g)
+        MuzzlePlasmaBall -> shootPlasmaBall o pq' (w & randGen .~ g)
-        MuzzleTesla -> shootTeslaArc pq' loc (w & randGen .~ g)
+        MuzzleTesla -> shootTeslaArc o pq' loc (w & randGen .~ g)
         MuzzleTractor -> shootTractorBeam cr w
         MuzzleRLauncher -> createProjectileR pq loc magtree cr w
         MuzzleGLauncher ->
@@ -776,6 +776,7 @@ useLoadedAmmo loc cr mz m w =
         MuzzleStopper -> useStopWatch itm cr w
         MuzzleScroller -> useTimeScrollGun itm cr w
   where
+    o = CrWeaponO $ cr ^. crID
     pq = muzzlePos loc cr mz
     (pq', g) = muzzleRandPos loc cr mz `runState` (w ^. randGen)
     itmtree = loc ^. locDT
@@ -856,9 +857,10 @@ tractorBeamAt pos outpos dir power =
         , _tbTime = 10
         }
 
-creatureShootLaser :: Point3Q -> LocationDT OItem -> World -> World
+creatureShootLaser :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
-creatureShootLaser (p, q) loc =
+creatureShootLaser o (p, q) loc =
     shootLaser
+        o
         (ItemSound (loc ^. locDT . dtValue . _1 . itID . unNInt) 0)
         (getLaserDamage loc)
         (getLaserPhaseV loc)
@@ -866,6 +868,7 @@ creatureShootLaser (p, q) loc =
         (Q.qToAng q)
 
 shootLaser ::
+    DamageOrigin ->
     SoundOrigin ->
     LaserType ->
     Float ->
@@ -873,13 +876,14 @@ shootLaser ::
     Float ->
     World ->
     World
-shootLaser so lt pv p dir =
+shootLaser o so lt pv p dir =
     ( cWorld . lWorld . lasers
         .:~ Laser
             { _lpType = lt
             , _lpPhaseV = pv
             , _lpPos = p
             , _lpDir = dir
+            , _lpOrigin = o
             }
     )
         . soundContinue so p tone440sawtoothquietS (Just 2)
@@ -887,12 +891,13 @@ shootLaser so lt pv p dir =
 creatureShootPulseLaser :: Point3Q -> Creature -> World -> World
 creatureShootPulseLaser (p, q) cr =
     shootPulseLaser
+        (CrWeaponO $ cr ^. crID)
         (CrWeaponSound (_crID cr) 0)
         (p ^. _xy)
         (Q.qToAng q)
 
-shootPulseLaser :: SoundOrigin -> Point2 -> Float -> World -> World
+shootPulseLaser :: DamageOrigin -> SoundOrigin -> Point2 -> Float -> World -> World
-shootPulseLaser so p dir w =
+shootPulseLaser o so p dir w =
     w
         & cWorld . lWorld . pulseLasers
             .:~ PulseLaser
@@ -901,23 +906,25 @@ shootPulseLaser so p dir w =
                 , _pzDir = dir
                 , _pzDamage = 101
                 , _pzTimer = 5
+                , _pzOrigin = o
                 }
         & soundStart so p lasPulseS Nothing
 
-shootPlasmaBall :: Point3Q -> World -> World
+shootPlasmaBall :: DamageOrigin -> Point3Q -> World -> World
-shootPlasmaBall (p, q) w =
+shootPlasmaBall o (p, q) w =
     w
         & cWorld . lWorld . plasmaBalls .:~
             PBall
                 { _pbPos = p ^. _xy
                 , _pbVel = 6 * unitVectorAtAngle (Q.qToAng q)
                 , _pbType = DefaultPlasma
+                , _pbOrigin = o
                 }
 --        & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
 
 
-shootPulseBall :: Point3Q -> World -> World
+shootPulseBall :: DamageOrigin -> Point3Q -> World -> World
-shootPulseBall (p, q) w =
+shootPulseBall o (p, q) w =
     w
         & cWorld . lWorld . pulseBalls . at i
             ?~ PulseBall
@@ -925,6 +932,7 @@ shootPulseBall (p, q) w =
                 , _pzbVel = 3.5 * unitVectorAtAngle (Q.qToAng q)
                 , _pzbTimer = 200
                 , _pzbID = i
+                , _pzbOrigin = o
                 }
         & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
   where
@@ -990,7 +998,8 @@ shootBullets
     :: LocationDT OItem -> Creature -> (Muzzle, Int, DTree OItem) -> World -> World
 shootBullets loc cr (mz, x, magtree) w = fromMaybe w $ do
     thebullet <- getBulletType magtree
-    return $ foldl' (&) w (replicate x (shootBullet thebullet loc cr mz))
+    let bu = thebullet & buOrigin .~ CrWeaponO (cr ^. crID)
+    return $ foldl' (&) w (replicate x (shootBullet bu loc cr mz))
 
 shootBullet :: Bullet -> LocationDT OItem -> Creature -> Muzzle -> World -> World
 shootBullet bu loc cr mz w = makeBullet bu itm pq . (randGen .~ g) $ w
@@ -1180,7 +1189,7 @@ doGenFloat (UniRandFloat x y) g = randomR (x, y) g
 
 mcShootLaser :: Item -> Machine -> World -> World
 mcShootLaser _ mc =
-    shootLaser (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir
+    shootLaser (McWeaponO (mc ^. mcID)) (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir
   where
     pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
     dir = (mc ^?! mcType . mctTurret . tuDir)
@@ -1203,14 +1212,14 @@ mcShootAuto itm mc w
 --    dir = mc ^?! mcType . _McTurret . tuDir
 
 -- | assumes that the item is held
-shootTeslaArc :: Point3Q -> LocationDT OItem -> World -> World
+shootTeslaArc :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
-shootTeslaArc (p, q) loc w =
+shootTeslaArc o (p, q) loc w =
     w' & cWorld . lWorld . items . ix itid . itParams .~ ip
         & soundContinue (ItemSound itid 0) pos elecCrackleS (Just 2)
   where
     itm = loc ^. locDT . dtValue . _1
     itid = itm ^. itID . unNInt
-    (w', ip) = makeTeslaArc (itm ^. itParams) pos (Q.qToAng q) w
+    (w', ip) = makeTeslaArc o (itm ^. itParams) pos (Q.qToAng q) w
     pos = p ^. _xy
 
 determineProjectileTracking :: DTree OItem -> DTree OItem -> RocketHoming

src/Dodge/Humanoid.hs

@@ -1,64 +1,54 @@
 module Dodge.Humanoid (
-    chaseCritInternal,
+    updateChaseCrit,
     crabCritInternal,
-    hoverCritInternal,
+    updateHoverCrit,
 ) where
 
-import Data.Foldable
 import Dodge.Creature
 import Dodge.Data.World
 import LensHelp
 
-chaseCritInternal :: World -> Creature -> Creature
+updateChaseCrit :: Int -> World -> World
-chaseCritInternal w cr =
+updateChaseCrit cid w = w
-    foldl'
+    & tocr %~ overrideMeleeCloseTarget w
-        (\c f -> f w c)
+    & tocr %~ setViewPos w
-        cr
+    & tocr %~ setMvPosToTargetCr w
-        [ const doStrategyActions
+    & tocr %~ chaseCritMv w
-        , overrideMeleeCloseTarget
+    & tocr %~ perceptionUpdate [0] w
-        , setViewPos
+    & tocr %~ targetYouWhenCognizant w
-        , setMvPosToTargetCr
+    & tocr %~ searchIfDamaged
-        , chaseCritMv
+    & tocr . crType . meleeCooldown %~ max 0 . subtract 1
-        , perceptionUpdate [0]
+    & tocr . crVocalization %~ updateVocTimer
-        , targetYouWhenCognizant
-        , const searchIfDamaged
-        , const (crType . meleeCooldown %~ max 0 . subtract 1)
-        , const (crVocalization %~ updateVocTimer)
-        ]
-
-crabCritInternal :: Int -> World -> World
-crabCritInternal cid w =
---    (crVocalization %~ updateVocTimer)
-        (tocr %~ (crType . meleeCooldownL %~ max 0 . subtract 1))
-        . (tocr %~ (crType . meleeCooldownR %~ max 0 . subtract 1))
-        . (tocr %~ (crType . dodgeCooldown %~ max 0 . subtract 1))
-        . (tocr %~ searchIfDamaged)
-        . (tocr %~ targetYouWhenCognizant w)
-        . (tocr %~ perceptionUpdate [0] w)
-        . crabActionUpdate cid
-        . (tocr %~ setMvPosToTargetCr w)
-        . (tocr %~ setViewPos w)
---        . overrideMeleeCloseTarget w
-        $ (tocr %~ doStrategyActions) w
   where
     tocr = cWorld . lWorld . creatures . ix cid
 
-hoverCritInternal :: World -> Creature -> Creature
+crabCritInternal :: Int -> World -> World
-hoverCritInternal w cr =
+crabCritInternal cid w = w
-    foldl'
+    & tocr %~ setViewPos w
-        (\c f -> f w c)
+    & tocr %~ setMvPosToTargetCr w
-        cr
+    & crabActionUpdate cid
-        [ const doStrategyActions
+    & tocr %~ perceptionUpdate [0] w
-        , overrideMeleeCloseTarget
+    & tocr %~ targetYouWhenCognizant w
-        , setViewPos
+    & tocr %~ searchIfDamaged
-        , setMvPosToTargetCr
+    & tocr . crType . dodgeCooldown %~ max 0 . subtract 1
-        , hoverCritMv
+    & tocr . crType . meleeCooldownR %~ max 0 . subtract 1
-        , perceptionUpdate [0]
+    & tocr . crType . meleeCooldownL %~ max 0 . subtract 1
-        , targetYouWhenCognizant
+  where
-        , const searchIfDamaged
+    tocr = cWorld . lWorld . creatures . ix cid
-        , const (crType . meleeCooldown %~ max 0 . subtract 1)
+
-        , const (crVocalization %~ updateVocTimer)
+updateHoverCrit :: Int -> World -> World
-        ]
+updateHoverCrit cid w = w
+        & tocr %~ overrideMeleeCloseTarget w
+        & tocr %~ setViewPos w
+        & tocr %~ setMvPosToTargetCr w
+        & tocr %~ hoverCritMv w
+        & tocr %~ perceptionUpdate [0] w
+        & tocr %~ targetYouWhenCognizant w
+        & tocr %~ searchIfDamaged
+        & tocr . crType . meleeCooldown %~ max 0 . subtract 1
+        & tocr . crVocalization %~ updateVocTimer
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
 
 updateVocTimer :: Vocalization -> Vocalization
 updateVocTimer VocTimer{_vcTime = x, _vcMaxTime = y} | x < y = VocTimer (x + 1) y

src/Dodge/Item/Weapon/Bullet.hs

@@ -16,6 +16,7 @@ defaultBullet =
         , _buDrag = 1
         , _buPos = 0
         , _buOldPos = 0
+        , _buOrigin = UnassignedO
         }
 
 --basicBulDams :: [Damage]

src/Dodge/Laser/Update.hs

@@ -14,7 +14,7 @@ updateLaser w pt =
     ( case _lpType pt of
         DamageLaser dam ->
             damThingHitWith
-                (\p2 -> Lasering dam p2 (xp - sp))
+                (\p2 -> Lasering dam p2 (xp - sp) (pt ^. lpOrigin))
                 thHit
                 w
         TargetingLaser itid -> w & pointerToItemID itid . itTargeting . itTgPos ?~ last ps

src/Dodge/Machine/Destroy.hs

@@ -16,7 +16,7 @@ destroyMachine mc =
     (cWorld . lWorld . machines %~ IM.delete (_mcID mc))
         . deleteWallIDs (IM.keysSet $ _mcFootPrint mc)
         . makeMachineDebris mc
-        . makeSmallExplosionAt (20 & _xy .~ _mcPos mc) 0
+        . makeSmallExplosionAt (McIndirectO (mc ^. mcID)) (20 & _xy .~ _mcPos mc) 0
         . mcKillTerm mc
         . mcKillBut mc
         . destroyMcType (mc ^. mcType) mc

src/Dodge/Material/Damage.hs

@@ -40,14 +40,14 @@ laserSpark = makeSpark FireSpark
 
 damageStone :: Damage -> ECW -> World -> (Int,World)
 damageStone dm ecw w = case dm of
-        Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)
+        Lasering _ p t _ -> f 0 $ laserSpark (outTo p t) (rdir p t)
-        Piercing _ p t -> 
+        Piercing _ p t _ -> 
             f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
                 . makeDustAt Stone 200 (addZ 20 (outTo p t))
 --                . randsound p [slapS, slap1S,slap2S,slap3S,slap4S,slap5S,slap6S,slap7S]
                 . randsound p [slapS, slap1S, slap2S]
-        Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Blunt _ p t _ -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
-        Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Shattering _ p t _ -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
         Crushing{} -> f dmam  id
         Explosive{} -> f dmam  id
         Sparking{} -> f 0  id
@@ -91,14 +91,14 @@ damagePiezoelectric = damageStone
 
 damagePhotovoltaic :: Damage -> ECW -> World -> (Int,World)
 damagePhotovoltaic dm ecw w = case dm of
-        Lasering _ p t -> f (10*dmam) $ laserSpark (outTo p t) (rdir p t)
+        Lasering _ p t _ -> f (10*dmam) $ laserSpark (outTo p t) (rdir p t)
-        Piercing _ p t -> 
+        Piercing _ p t _ -> 
             f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
                 . makeDustAt Stone 200 (addZ 20 (outTo p t))
 --                . randsound p [slapS, slap1S,slap2S,slap3S,slap4S,slap5S,slap6S,slap7S]
                 . randsound p [slapS, slap1S, slap2S]
-        Blunt _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Blunt _ p t _ -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
-        Shattering _ p t -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Shattering _ p t _ -> f dmam $ makeDustAt Stone 200 (addZ 20 (outTo p t))
         Crushing{} -> f dmam  id
         Explosive{} -> f dmam  id
         Sparking{} -> f 0  id
@@ -124,11 +124,11 @@ damagePhotovoltaic dm ecw w = case dm of
 
 damageMetal :: Damage -> ECW -> World -> (Int,World)
 damageMetal dm ecw w = case dm of
-        Lasering _ p t -> f 0 $ laserSpark (outTo p t) (rdir p t)
+        Lasering _ p t _ -> f 0 $ laserSpark (outTo p t) (rdir p t)
-        Piercing _ p t -> f dmam $
+        Piercing _ p t _ -> f dmam $
             makeSpark NormalSpark (outTo p t) (rdir p t)
                 . randsound p [tingS, ting1S, ting2S, ting3S, ting4S, ting5S]
-        Blunt _ p t -> f dmam $
+        Blunt _ p t _ -> f dmam $
             makeSpark NormalSpark (outTo p t) (rdir p t)
                 . randsound p [clangS,clang1S,clang2S]
         Shattering {} -> f dmam  id
@@ -158,7 +158,7 @@ damageMetal dm ecw w = case dm of
 damageFlesh :: Damage -> ECW -> World -> (Int,World)
 damageFlesh dm _ w = (dm ^. dmAmount,) $ w & case dm of
     Lasering {} -> id
-    Piercing _ p t ->
+    Piercing _ p t _ ->
         randsound
             p
             [ bloodShort1S
@@ -171,7 +171,7 @@ damageFlesh dm _ w = (dm ^. dmAmount,) $ w & case dm of
             , bloodShort8S
             ]
                 . makeDustAt Flesh 50 (addZ 20 (outTo p t))
-    Blunt _ p _ -> randsound p [hitS]
+    Blunt _ p _ _ -> randsound p [hitS]
     Shattering {} -> id
     Crushing{} -> id
     Explosive{} -> id
@@ -192,14 +192,14 @@ damageFlesh dm _ w = (dm ^. dmAmount,) $ w & case dm of
 damageDirt :: Damage -> ECW -> World -> (Int,World)
 damageDirt dm _ w =
     (dm^. dmAmount,) $ w & case dm of
-        Lasering _ p t -> --  makeSpark FireSpark (outTo p t) (rdir p t)
+        Lasering _ p t _ -> --  makeSpark FireSpark (outTo p t) (rdir p t)
             makeDustAt Dirt 200 (addZ 20 (outTo p t))
-        Piercing _ p t ->
+        Piercing _ p t _ ->
             makeDustAt Dirt 200 (addZ 20 (outTo p t))
                 -- . randsound p [slapS, slap1S]
                 . randsound p [slapS, slap1S,slap2S,slap3S,slap4S,slap5S,slap6S,slap7S]
-        Blunt _ p t -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
+        Blunt _ p t _ -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
-        Shattering _ p t -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
+        Shattering _ p t _ -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id
@@ -219,16 +219,16 @@ damageDirt dm _ w =
 damageGlass :: Damage -> ECW -> World -> (Int,World)
 damageGlass dm ecw w = case dm of
         Lasering {} -> f 0  id
-        Piercing _ p t -> 
+        Piercing _ p t _ -> 
             f dmam $ makeSpark NormalSpark (outTo p t) (rdir p t)
 --                . makeDustAt Stone 200 (addZ 20 (outTo p t))
                  . randsound p [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S]
-        Blunt _ p _ -> f dmam $ -- makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Blunt _ p _ _ -> f dmam $ -- makeDustAt Stone 200 (addZ 20 (outTo p t))
                  randsound p [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S]
-        Shattering _ p t -> f dmam $ makeDustAt Glass 200 (addZ 20 (outTo p t))
+        Shattering _ p t _ -> f dmam $ makeDustAt Glass 200 (addZ 20 (outTo p t))
                 . randsound p [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S]
         Crushing{} -> f dmam  id
-        Explosive _ p -> f dmam  -- the sound comes from the explosion center, which is not correct...
+        Explosive _ _ p -> f dmam  -- the sound comes from the explosion center, which is not correct...
             $ randsound p [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S]
         Sparking{} -> f 0  id
         Flaming{} -> f 0  id
@@ -286,14 +286,14 @@ damageGlass dm ecw w = case dm of
 damageCrystal :: Damage -> ECW -> World -> (Int,World)
 damageCrystal dm ecw w = case dm of
         Lasering {} -> f  id
-        Piercing _ p t -> 
+        Piercing _ p t _ -> 
             f $ makeSpark NormalSpark (outTo p t) (rdir p t)
                  . randsound p [marimbaC5S,marimbaE5S,marimbaG5S,marimbaB6S]
-        Blunt _ p _ -> f $ -- makeDustAt Stone 200 (addZ 20 (outTo p t))
+        Blunt _ p _ _ -> f $ -- makeDustAt Stone 200 (addZ 20 (outTo p t))
                  randsound p [marimbaC5S,marimbaE5S,marimbaG5S,marimbaB6S]
-        Shattering _ p _ -> f $ randsound p [marimbaC5S,marimbaE5S,marimbaG5S,marimbaB6S]
+        Shattering _ p _ _ -> f $ randsound p [marimbaC5S,marimbaE5S,marimbaG5S,marimbaB6S]
         Crushing{} -> f  id
-        Explosive _ p -> f  -- the sound comes from the explosion center, which is not correct...
+        Explosive _ _ p -> f  -- the sound comes from the explosion center, which is not correct...
             $ randsound p [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S]
         Sparking{} -> f   id
         Flaming{} -> f   id

src/Dodge/Payload.hs

@@ -15,19 +15,20 @@ import Geometry.Data
 import LensHelp
 import Linear.V3
 
-usePayload :: Payload -> Point3 -> Point3 -> World -> World
+usePayload :: Payload -> DamageOrigin -> Point3 -> Point3 -> World -> World
 usePayload = \case
     ExplosionPayload -> makeExplosionAt
     ShrapnelBomb -> makeShrapnelAt
-    DudPayload -> const (const id)
+    DudPayload -> const (const (const id))
 
-makeShrapnelAt :: Point3 -> Point3 -> World -> World
+-- potential turn the origin indirect?
-makeShrapnelAt p' vel' w =
+makeShrapnelAt :: DamageOrigin -> Point3 -> Point3 -> World -> World
+makeShrapnelAt o p' vel' w =
     w
         & soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing
         & cWorld . lWorld . worldEvents
             .:~ MakeTempLight (LSParam p' 150 (V3 0.8 0.8 0.8)) 20
-        & makeShockwaveAt [] p' 50 5 0 white
+        & makeShockwaveAt [] p' 50 5 0 white o
         & cWorld . lWorld . bullets .++~ buls
   where
     p = p' ^. _xy
@@ -43,3 +44,4 @@ makeShrapnelAt p' vel' w =
         & buDrag .~ drag
         & buPos .~ (p - v)
         & buOldPos .~ (p - v)
+        & buOrigin .~ o

src/Dodge/Projectile/Create.hs

@@ -45,6 +45,7 @@ createShell (p, q) mdetonator mscreen stab pjtype payload cr w =
                 , _pjType = pjtype
                 , _pjDetonatorID = mdetonator
                 , _pjScreenID = mscreen
+                , _pjOrigin = CrWeaponO $ cr ^. crID
                 }
   where
     dir = Q.qToAng q

src/Dodge/Projectile/Update.hs

@@ -143,6 +143,7 @@ doThrust pj smoke w =
         %~ (\v -> accel + frict *^ v)
         & soundContinue (ShellSound i) (ep ^. _xy) missileLaunchS (Just 1)
         & makeFlamelet
+            (pj ^. pjOrigin)
             (sp - 0.5 *^ vel)
             (vel + rotateV (pi + sparkD) accel `v2z` 0)
             3
@@ -283,7 +284,7 @@ explodeShell pj w =
         & pjlens
         . pjTimer
         .~ 30
-        & usePayload (_pjPayload pj) (pj ^. pjPos) (pj ^. pjVel)
+        & usePayload (_pjPayload pj) (pj ^. pjOrigin) (pj ^. pjPos) (pj ^. pjVel)
         & stopSoundFrom (ShellSound pjid)
         & updatedetonator
   where

src/Dodge/Render.hs

@@ -411,8 +411,8 @@ doDrawing' win pdata u = do
             glDrawArrays GL_TRIANGLES 0 6
     glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
     -- draw the overlay
-    glDepthFunc GL_LEQUAL
+    --glDepthFunc GL_LEQUAL
-    --glDepthFunc GL_ALWAYS
+    glDepthFunc GL_ALWAYS
     glDepthMask GL_FALSE
     glEnable GL_BLEND
     --glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA

src/Dodge/Room/Tutorial.hs

@@ -56,10 +56,16 @@ tutAnoTree :: State LayoutVars MTRS
 tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
+--        , corDoor
+--        , chasmSpitTerminal
+--        , tToBTree "" . return . cleatOnward <$> slowDoorRoom
         , corDoor
         --, tToBTree "" . return . cleatOnward <$> (xChasm 200 200
         , tToBTree "" . return . cleatOnward <$> ((putSingleLight =<< roomRectAutoLights 300 300)
-            <&> rmPmnts <>~ [sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 150 100
+            <&> rmPmnts <>~ 
+            [sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 150 100
+            ,sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 50 50
+            ,sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 50 150
             , sps0 (PutCrit hiveCrit) & plSpot . psPos .~ V2 250 50
             , sps0 (PutCrit chaseCrit) & plSpot . psPos .~ V2 250 100
             ]
@@ -370,11 +376,13 @@ chasmSpitTerminal = do
                    , [sps0 $ putShape $ gird (V2 0 20) (V2 300 20), sps0 $ putShape $ gird (V2 0 280) (V2 300 280)]
                    ]
     let y' = y & rmPmnts <>~ ls <> dec
-        cr = PutCrit chaseCrit
+        cr = PutCrit hoverCrit
     return $
         tToBTree "chasmTerm" $
             Node
-                (addDoorToggleTerminal' i1 (PS 150 0) y')
+                (addDoorToggleTerminal' i1 (PS 150 0) y'
+--                    & rmPmnts .:~ (sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 150 100)
+                )
                 [ treePost [triggerDoorRoom i1, deadEndPSType cr]
                 , treePost [triggerDoorRoom i1, deadEndPSType cr]
                 , return $ cleatOnward $ triggerDoorRoom i1

src/Dodge/Shockwave/Update.hs

@@ -25,7 +25,7 @@ moveShockwave w sw
     doDams 
         | (p ^. _z >= 0) && (p ^. _z < 25)
             && t > 5
-            = damageInCircle (Explosive dam) (p ^. _xy) rad
+            = damageInCircle (Explosive dam (sw ^. swOrigin)) (p ^. _xy) rad
         | otherwise = id
 
 moveInverseShockwave ::

src/Dodge/Spark.hs

@@ -39,9 +39,9 @@ sparkDam = damageCrWl . sparkToDamage
 
 sparkToDamage :: Spark -> [Damage]
 sparkToDamage sp = case _skType sp of
-    ElectricSpark -> [Electrical 10]
+    ElectricSpark -> [Electrical 10 UnassignedO]
-    FireSpark -> [Flaming 1]
+    FireSpark -> [Flaming 1 UnassignedO]
-    NormalSpark -> [Sparking 10]
+    NormalSpark -> [Sparking 10 UnassignedO]
 
 makeSpark :: SparkType -> Point2 -> Float -> World -> World
 makeSpark st p d =

src/Dodge/Tesla.hs

@@ -25,14 +25,15 @@ import Picture
 import RandomHelp
 --import Shape
 
-makeTeslaArc :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams)
+makeTeslaArc :: DamageOrigin -> ItemParams -> Point2 -> Float -> World -> (World, ItemParams)
-makeTeslaArc ip pos dir w =
+makeTeslaArc o ip pos dir w =
     ( w & randGen .~ g
         & cWorld . lWorld . teslaArcs
             .:~ TeslaArc
                 { _taArcSteps = newarc
                 , _taTimer = 2
                 , _taColor = brightX 100 1.5 col
+                , _taOrigin = o
                 }
     , ip & currentArc .~ newarc
     )

src/Dodge/TestString.hs

@@ -35,17 +35,32 @@ import NewInt
 import RandomHelp
 import qualified SDL
 import ShortShow
+import qualified Data.IntSet as IS
 
 tocrs :: (IM.IntMap Creature
           -> Const (Endo [String]) (IM.IntMap Creature))
          -> Universe -> Const (Endo [String]) Universe
 tocrs = uvWorld . cWorld . lWorld . creatures
 
+isBee :: Creature -> Bool
+isBee cr = case cr ^. crType of
+    BeeCrit{} -> True
+    _ -> False
+
+crslime :: Creature -> Int
+crslime cr = case cr ^. crType of
+    SlimeCrit {_slimeSlime=r} | HP{} <- cr ^. crHP -> r -- r ^ (2::Int)
+    HiveCrit {_hiveSlime=x} -> x
+    BeeCrit {_beeSlime=x} -> 400 + x
+    _ -> 0
+
+crs :: Universe -> [Creature]
+crs u = u ^.. uvWorld . cWorld . lWorld . creatures . each
+
 testStringInit :: Universe -> [String]
-testStringInit u = u ^.. tocrs . ix 2 . crType . hiveChildren . to show
+testStringInit _ = mempty
-    <> u ^.. tocrs . ix 3 . crStance . carriage . to show
+    --[show . getSum $ foldMap (Sum . crslime) (crs u)]
-    <> u ^.. tocrs . ix 3 . crDir . to show
+--     u ^.. tocrs . each . crType . slimeSplitTimer . to show
-    <> u ^.. tocrs . ix 3 . crActionPlan . apAction . to show
 --    u ^.. tocrs . ix 1 . crPos . _xy . to show
 --    <> u ^.. tocrs . ix 1 . crType . slimeCompression . to show
 --    <> u ^.. tocrs . ix 1 . crType . slimeCompression . to norm . to show

src/Dodge/Update.hs

@@ -283,7 +283,7 @@ functionalUpdate =
         . over uvWorld updateDistortions
         . over uvWorld updateCreatureSoundPositions
         . over uvWorld updateCreatureStrides
-        . over uvWorld pushYouOutFromWalls
+        . pushYouOutFromWalls
         . colCrsWalls
         . over uvWorld simpleCrSprings
         . over uvWorld updateDoors
@@ -316,8 +316,8 @@ functionalUpdate =
             (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave)
         . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
         . over uvWorld updateClouds
-        . over uvWorld updateBeePheremones
+        . over uvWorld (updateObjMapMaybe beePheremones updateBeePheremone)
-        . over uvWorld updateGasses
+        . over uvWorld (updateObjCatMaybes gasses updateGas)
         . over uvWorld updateDusts
         . over uvWorld updateGusts
         . over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) updateTerminal)
@@ -342,8 +342,10 @@ functionalUpdate =
         . updateAimPos
         . over uvWorld updatePastWorlds -- it might be possible to do this without storing stuff such as the temporary lights/flares etc
 
-pushYouOutFromWalls :: World -> World
+pushYouOutFromWalls :: Universe -> Universe
-pushYouOutFromWalls w = w & cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck w
+pushYouOutFromWalls u
+    | debugOn Noclip (u ^. uvConfig) = u
+    | otherwise = u & uvWorld . cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck (u ^. uvWorld)
 
 -- rotate creature as well? behaviour on ledges?
 muzzleWallCheck :: World -> Creature -> Creature
@@ -540,7 +542,7 @@ updatePlasmaBall w pb
     dodam = \case
         Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam
         Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam
-    thedam = Lasering 100 ep (pb ^. pbVel)
+    thedam = Lasering 100 ep (pb ^. pbVel) (pb ^. pbOrigin)
     sp = pb ^. pbPos
     ep = sp + pb ^. pbVel
     thit = thingHit sp ep w
@@ -560,7 +562,7 @@ updatePulseBall pb w
     dodam = \case
         Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam
         Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam
-    thedam = Lasering 100 ep (pb ^. pzbVel)
+    thedam = Lasering 100 ep (pb ^. pzbVel) (pb ^. pzbOrigin)
     sp = pb ^. pzbPos
     ep = sp + pb ^. pzbVel
     thit = listToMaybe $ thingsHitZ 20 sp ep w
@@ -609,13 +611,14 @@ setOldPos cr = cr & crOldPos .~ _crPos cr
 
 zoneCreatures :: World -> World
 zoneCreatures w =
-    w & crZoning .~ foldl' zoneCreature mempty (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures)
+--    w & crZoning .~ foldl' zoneCreature mempty (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures)
+    w & crZoning .~ foldl' zoneCreature mempty (w ^. cWorld . lWorld . creatures)
 
-zonableCreature :: Creature -> Bool
+--zonableCreature :: Creature -> Bool
-zonableCreature cr = case cr ^. crHP of
+--zonableCreature cr = case cr ^. crHP of
-    HP{} -> True
+--    HP{} -> True
-    CrIsCorpse{} -> True
+--    CrIsCorpse{} -> True
-    CrDestroyed{} -> False
+--    AvatarDestroyed{} -> False
 
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w =
@@ -718,7 +721,7 @@ updateTeslaArc w pt
             , randWallReflect ld' wl
             )
         | ArcStep lp' ld' _ <- last thearc = (lp', rp ld')
-    damthings (ArcStep _ _ crwl) = damageCrWlID [Electrical 50] crwl
+    damthings (ArcStep _ _ crwl) = damageCrWlID [Electrical 50 (pt ^. taOrigin)] crwl
 
 updatePulseLaser :: PulseLaser -> (Endo World, [PulseLaser])
 updatePulseLaser pz = case pz ^. pzTimer of
@@ -734,14 +737,14 @@ updatePulseLaser pz = case pz ^. pzTimer of
     dodam thit = case thit of
         ((p, OCreature cr) : _) ->
             cWorld . lWorld . creatures . ix (_crID cr) . crDamage
-                .:~ Lasering (pz ^. pzDamage) p (xp - sp)
+                .:~ Lasering (pz ^. pzDamage) p (xp - sp) (pz ^. pzOrigin)
         ((p, OWall wl) : _) ->
             cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty
-                .:~ Lasering (pz ^. pzDamage) p (xp - sp)
+                .:~ Lasering (pz ^. pzDamage) p (xp - sp) (pz ^. pzOrigin)
         ((_, OPulseBall pb) : xs) ->
             dodam xs
                 . (cWorld . lWorld . pulseBalls . ix (_pzbID pb) . pzbTimer .~ 0)
-                . makeExplosionAt (_pzbPos pb `v2z` 20) 0
+                . makeExplosionAt (pb ^. pzbOrigin) (_pzbPos pb `v2z` 20) 0
         _ -> id
     phasev = _pzPhaseV pz
     sp = _pzPos pz
@@ -780,17 +783,13 @@ updateSparks = updateObjCatMaybes sparks updateSpark
 updateClouds :: World -> World
 updateClouds w = updateObjMapMaybe clouds (updateCloud w) w
 
-updateBeePheremones :: World -> World
-updateBeePheremones w = updateObjMapMaybe beePheremones updateBeePheremone w
-
 updateBeePheremone :: BeePheremone -> Maybe BeePheremone
 updateBeePheremone bp 
     | x <- bp ^. bpTimer
     , x <= 0 = Nothing
     | otherwise = Just $ bp & bpTimer -~ 1
-
+        & bpVel *~ 0.90
-updateGasses :: World -> World
+        & bpPos +~ (bp ^. bpVel)
-updateGasses = updateObjCatMaybes gasses updateGas
 
 updateDusts :: World -> World
 updateDusts w = updateObjMapMaybe dusts (updateDust w) w
@@ -1007,7 +1006,7 @@ canSpring cr =
     cr ^. crPos . _z >= 0 && case cr ^. crHP of
         HP{} -> True
         CrIsCorpse{} -> True
-        CrDestroyed{} -> False
+        AvatarDestroyed{} -> False
 
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2
@@ -1015,6 +1014,10 @@ crCrSpring c1 c2
     | vec == V2 0 0 = id
     | diff >= comRad = id
     | diffheight = id
+    | Rooted <- c2 ^. crStance . carriage = id
+    | Rooted <- c1 ^. crStance . carriage 
+        = cWorld . lWorld . creatures . ix id2 . crPos . _xy +~ 
+            (diff - comRad) *^ signorm vec
     | SlimeCrit{} <- c1 ^. crType
     , SlimeCrit{} <- c2 ^. crType
     , id2 > id1 
@@ -1023,9 +1026,8 @@ crCrSpring c1 c2
     , slimeFood c2
     , distance xy1 xy2 < r1 - (r2 + 5)
         = feedSlime c1 c2
-    | Just t <- c1 ^? crType . slimeSplitTimer 
+    | Just Nothing <- c1 ^? crType . slimeSplitTimer 
-        , slimeFood c2
+        , slimeFood c2 = slimeSuck c1 c2
-        , t <= 0 = slimeSuck c1 c2
     | SlimeCrit{} <- c1 ^. crType = id
     | SlimeCrit{} <- c2 ^. crType = id
     | otherwise = cWorld . lWorld . creatures %~ ( olap c1 c2 . olap' c2 c1)
@@ -1074,6 +1076,7 @@ slimeFood cr = case cr ^. crType of
     Avatar{} -> True
     ChaseCrit{} -> True
     CrabCrit {} -> True
+    BeeCrit{} | CrIsCorpse{} <- cr ^. crHP -> True
     _ -> False
 
 feedSlime :: Creature -> Creature -> World -> World
@@ -1084,35 +1087,31 @@ feedSlime s c w = fromMaybe w $ do
                 & slimeSuck s c
         else
              w
-            & cWorld . lWorld . creatures . ix (c ^. crID) . crHP .~ CrDestroyed Swallowed
+            & cWorld . lWorld . creatures . at (c ^. crID) %~ destroyCreature
             & cWorld . lWorld . creatures . ix (s ^. crID) %~ f
             & slimeEatSound (s ^. crID) (s ^. crPos . _xy)
   where
-    f cr = cr & crType . slimeRad .~ r
+    f cr = cr
-            & crType . slimeRadWobble +~ r - r1
+            & crType . slimeSlime +~ round (r2^(2::Int) * 100)
-            & crType . slimeCompression %~ ((r/r1) *^)
+            & crType . slimeSlimeChange +~ round (r2^(2::Int) * 100)
-    r1 = s ^?! crType . slimeRad
+    r1 = s ^?! crType . slimeSlime . to slimeToRad
     r2 = c ^. crType . to crRad
-    r = sqrt (r1*r1 + r2*r2)
 
 fuseSlimes :: Creature -> Creature -> World -> World
 fuseSlimes c1 c2 = (cWorld . lWorld . creatures . ix mini .~ c)
     . (cWorld . lWorld . creatures . at maxi .~ Nothing)
-    . slimeEatSound i1 (c ^. crPos . _xy)
+    . slimeEatSound mini (c ^. crPos . _xy)
   where
-    c' | c1 ^?! crType . slimeRad > c2 ^?! crType . slimeRad = c1
+    c' | c1 ^?! crType . slimeSlime > c2 ^?! crType . slimeSlime = c1
        | otherwise = c2
     mini = min i1 i2
     maxi = max i1 i2
     i1 = c1 ^. crID
     i2 = c2 ^. crID
-    c = c' & crType . slimeRad .~ r
+    c = c' & crType . slimeSlime +~ eslime
-            & crType . slimeRadWobble +~ r - max r1 r2
+            & crType . slimeSlimeChange +~ eslime
-            & crType . slimeCompression %~ ((r/max r1 r2) *^)
             & crID .~ mini
-    r1 = c1 ^?! crType . slimeRad
+    eslime = min (c1 ^?! crType . slimeSlime) (c2 ^?! crType . slimeSlime)
-    r2 = c2 ^?! crType . slimeRad
-    r = sqrt (r1*r1 + r2*r2)
 
 slimeEatSound :: Int -> Point2 -> World -> World
 slimeEatSound i p w = w & soundStart (CrSound i) p s Nothing

src/Dodge/Update/Cloud.hs

@@ -14,7 +14,7 @@ cloudPoisonDamage :: Gas -> World -> World
 cloudPoisonDamage c w = foldl' (flip doDam) w (filter f $ crsNearPoint clpos w)
   where
     doDam cr =
-        cWorld . lWorld . creatures . ix (_crID cr) . crDamage .:~ Poison 1
+        cWorld . lWorld . creatures . ix (_crID cr) . crDamage .:~ Poison 1 (c ^. gsOrigin)
     f cr = dist3 (_crPos cr & _z +~ 20) (_gsPos c) < crRad (cr ^. crType) + 20
         && isJust (cr ^? crHP . _HP)
     clpos = stripZ $ _gsPos c

src/Dodge/Wall/Damage.hs

@@ -50,7 +50,7 @@ damageMachine dam x mcid w = case w ^? cWorld . lWorld . machines . ix mcid of
         , sensorTypeDamages (se ^. sensType) dam
         -> (mempty,mcDamSensorUpdate' (_dmAmount dam) se mc w)
     Just mc | McTurret{} <- mc ^. mcType
-        , Electrical edam <- dam
+        , Electrical {_dmAmount=edam} <- dam
             -> (mempty, w & cWorld . lWorld . machines . ix mcid . mcType . mctTurretStun %~ (min 100 . (+ edam)))
     Just mc | _mcHP mc < x -> destroyMachine' mc w
     _ -> (mempty, w & cWorld . lWorld . machines . ix mcid . mcHP -~ x)

src/Dodge/WallCreatureCollisions.hs

@@ -30,7 +30,8 @@ colCrWall w c = cornpush . wallpush $ pushthrough c
     cornpush = crPos . _xy %~ pushOutFromCorners r ls'
     wallpush = pushCr (w ^. cWorld . lWorld) wls
     pushthrough = crPos . _xy %~ fst . flip (collidePoint p1) wls -- check push throughs
-    r = crRad (c ^. crType) + wallBuffer
+    r   | SlimeCrit {} <- c ^. crType = min 10 . crRad $ c ^. crType
+        | otherwise = crRad $ c ^. crType
     p1 = c ^. crOldPos . _xy
     p2 = c ^. crPos . _xy
     ls = _wlLine <$> IM.elems wls
@@ -45,7 +46,7 @@ pushCr w wls cr
 --        || wlsCrush' w (cr ^. crPos . _xy) twls =
     | wlsCrush' w (cr ^. crPos . _xy) twls =
         ecr
-            & crDamage <>~ [Crushing 1000 0]
+            & crDamage <>~ [Crushing 1000 0 UnassignedO]
             & crPos . _xy .~ ap
 --    | Just s <- wlsCrush w (cr ^. crPos . _xy) twls =
 --        ecr
@@ -60,7 +61,8 @@ pushCr w wls cr
     ap = cr ^. crOldPos . _xy
 --    sp = cr ^. crPos . _xy
     ecr = foldl' f (cr & crWallTouch .~ mempty) wls
-    r = crRad (cr ^. crType)
+    r   | SlimeCrit {} <- cr ^. crType = min 10 . crRad $ cr ^. crType
+        | otherwise = crRad $ cr ^. crType
     f acr wl = case pushOutFromWall' r (acr ^. crPos . _xy) (wl ^. wlLine) of
         Just (p,hitp) -> acr & crPos . _xy .~ p & crWallTouch . at (wl ^. wlID) ?~ hitp
         Nothing -> acr
@@ -95,10 +97,6 @@ wlWlCrush' w p w1 w2 = (t w1 w2 || t w2 w1) -- test either wall is moving toward
         (wallMovement w p x - wallMovement w p y) > 0
     f = normalizeV . uncurry (-) . (^. wlLine)
 
--- the amount to push creatures out from walls, extra to their radius
-wallBuffer :: Float
-wallBuffer = 0
-
 ---- assumes that the wall is orientated
 ---- assumes wall points are different
 --pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2

src/Dodge/WorldEvent/Explosion.hs

@@ -22,14 +22,10 @@ import Linear
 import Picture
 import RandomHelp
 
-makePoisonExplosionAt ::
+makePoisonExplosionAt :: DamageOrigin -> Point2 -> World -> World
-    -- | Position
+makePoisonExplosionAt o p w =
-    Point2 ->
-    World ->
-    World
-makePoisonExplosionAt p w =
     soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing $
-        foldl' (flip $ makeGasCloud p) w $
+        foldl' (flip $ makeGasCloud o p) w $
             replicateM 25 (randInCirc 2) & evalState $ _randGen w
 
 -- just change the number after replicateM to get more or less clouds
@@ -53,47 +49,44 @@ makeTeslaExplosionAt = undefined
 --            (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i))))
 --            [1 .. 29]
 
-makeFlameExplosionAt ::
+makeFlameExplosionAt :: DamageOrigin -> Point2 -> World -> World
-    Point2 ->
+makeFlameExplosionAt o p w =
-    World ->
-    World
-makeFlameExplosionAt p w =
     soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing w
         & cWorld . lWorld . flames .++~ newFlames
   where
     newFlames = zipWith makeFlameWithVelAndTime velocities timers
-    makeFlameWithVelAndTime vel time = Flame time vel p
+    makeFlameWithVelAndTime vel time = Flame time vel p o
     velocities = replicateM 15 (randInCirc 1) & evalState $ _randGen w
     timers = randomRs (80, 100) $ _randGen w
 
-makeExplosionAt :: Point3 -> Point3 -> World -> World
+makeExplosionAt :: DamageOrigin -> Point3 -> Point3 -> World -> World
-makeExplosionAt p vel w =
+makeExplosionAt o p vel w =
     w
         & soundStart (Explosion (w ^. cWorld . lWorld . lClock)) (p ^. _xy) bangS Nothing
         & addFlames
         & cWorld . lWorld . worldEvents .:~ MakeTempLight (LSParam p 150 (V3 1 0.5 0)) 20
-        & makeShockwaveAt [] p 50 100 1 white
+        & makeShockwaveAt [] p 50 100 1 white o
   where
     fVs = fmap (`v2z` 0) $ replicateM 100 (randInCirc 8) & evalState $ _randGen w
     fdamps = replicateM 100 (state $ randomR (0, 1)) & evalState $ _randGen w
     sizes = randomRs (2, 9) $ _randGen w
     times = randomRs (15, 20) $ _randGen w
-    mF v damp = makeFlamelet p (v + damp *^ vel)
+    mF v damp = makeFlamelet o p (v + damp *^ vel)
     newFs = zipWith4 mF fVs fdamps sizes times
     addFlames w' = foldl' (&) w' newFs
 
-makeSmallExplosionAt :: Point3 -> Point3 -> World -> World
+makeSmallExplosionAt :: DamageOrigin -> Point3 -> Point3 -> World -> World
-makeSmallExplosionAt p vel w =
+makeSmallExplosionAt o p vel w =
     w
         & soundStart (Explosion (w ^. cWorld . lWorld . lClock)) (p ^. _xy) bangS Nothing
         & addFlames
         & cWorld . lWorld . worldEvents .:~ MakeTempLight (LSParam p 150 (V3 1 0.5 0)) 20
-        & makeShockwaveAt [] p 40 100 1 white
+        & makeShockwaveAt [] p 40 100 1 white o
   where
     fVs = fmap (`v2z` 0) $ replicateM 5 (randInCirc 2) & evalState $ _randGen w
     fdamps = replicateM 100 (state $ randomR (0, 1)) & evalState $ _randGen w
     sizes = randomRs (2, 9) $ _randGen w
     times = randomRs (15, 20) $ _randGen w
-    mF v damp = makeFlamelet p (v + damp *^ vel)
+    mF v damp = makeFlamelet o p (v + damp *^ vel)
     newFs = zipWith4 mF fVs fdamps sizes times
     addFlames w' = foldl' (&) w' newFs

src/Dodge/WorldEvent/Shockwave.hs

@@ -22,9 +22,10 @@ makeShockwaveAt ::
     -- | Color of shockwave.
     Color ->
     -- | Start world.
+    DamageOrigin ->
     World ->
     World
-makeShockwaveAt is p rad dam push col =
+makeShockwaveAt is p rad dam push col d =
     cWorld . lWorld . shockwaves
         .:~ Shockwave
             { _swInvulnerableCrs = is
@@ -36,6 +37,7 @@ makeShockwaveAt is p rad dam push col =
             , _swPush = push
             , _swMaxTime = 10
             , _swTimer = 10
+            , _swOrigin = d
             }
 
 {- Create a shockwave going from an outside circle into a center point.  -}
@@ -44,9 +46,10 @@ inverseShockwaveAt ::
     Float -> -- Radius
     Int -> -- Damage
     Float -> -- Push amount
+    DamageOrigin ->
     World ->
     World
-inverseShockwaveAt p rad dam push =
+inverseShockwaveAt p rad dam push d =
     cWorld . lWorld . shockwaves
         .:~ Shockwave
             { _swDirection = InwardShockwave
@@ -58,4 +61,5 @@ inverseShockwaveAt p rad dam push =
             , _swPush = push
             , _swMaxTime = 10
             , _swTimer = 10
+            , _swOrigin = d
             }

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -9,17 +9,19 @@ import LensHelp
 
 -- | At writing the radius is half the size of the effect area
 makeGasCloud ::
+    DamageOrigin ->
     -- | Position
     Point2 ->
     -- | Velocity
     Point2 ->
     World ->
     World
-makeGasCloud pos vel = cWorld . lWorld . gasses .:~ Gas
+makeGasCloud o pos vel = cWorld . lWorld . gasses .:~ Gas
             { _gsPos = addZ 20 pos
             , _gsVel = addZ 0 vel
             , _gsTimer = 400
             , _gsType = PoisonGas
+            , _gsOrigin = o
             }
 
 {- Attach poison cloud damage to creatures near cloud.  -}

src/Geometry/Intersect.hs

@@ -4,6 +4,7 @@
 {- Testing for and finding intersection points.  -}
 module Geometry.Intersect where
 
+import Data.Monoid
 import Data.List (sortOn)
 import Control.Applicative
 import Control.Lens
@@ -272,6 +273,12 @@ intersectLinePoly a b (p:ps) = sortOn (dotV (b - a))
     $ zipWith (\x y -> intersectSegLine x y a b) (p:ps) (ps ++[p])
 intersectLinePoly _ _ [] = error "intersectLinePoly empty polygon"
 
+intersectRayPoly :: Point2 -> Point2 -> [Point2] -> Maybe Point2
+intersectRayPoly a b (p:ps) = getFirst . mconcat $ zipWith f (p:ps) (ps++[p])
+  where
+    f x y = First $ intersectSegRay x y a b
+intersectRayPoly _ _ _ = error "intersectRayPoly: polygon too small"
+
 
 {- | Given a line and a point return the point on the line closest to the
  point.

src/Geometry/Polygon.hs

@@ -188,7 +188,7 @@ grahamEliminate (x : y : z : xs)
     | not $ isLHS x y z = grahamEliminate (x : z : xs)
 grahamEliminate xs = xs
 
--- this isn't the centroid of the polygon...
+-- not sure what definition of centroid is applicable here
 centroid :: (Num (f a),Functor f, Fractional a,Foldable t) => t (f a) -> f a
 centroid = L.fold $ (^/) <$> L.Fold (+) 0 id <*> L.genericLength
 
@@ -234,9 +234,15 @@ cutPolyR a b [] e x ls rs = case intersectSegLine x e a b of
     Nothing -> (reverse ls,reverse rs)
     Just p -> (reverse (p\:ls), reverse (p\:rs))
 
+polyInPoly :: Point2 -> [Point2] -> [Point2] -> [Point2]
+polyInPoly p ps = mapMaybe f
+  where
+    f q = intersectRayPoly p q ps
+
 infixr 5 \:
 (\:) :: Eq a => a -> [a] -> [a]
 (\:) x (y:ys) 
     | x /= y = x:y:ys
     | otherwise = y:ys 
 (\:) x [] = [x]
+

src/Shader/Poke/Cloud.hs

@@ -24,7 +24,7 @@ pokeBeePheremone :: Ptr Float -> Int -> BeePheremone -> IO Int
 pokeBeePheremone vptr nv = pokeCloudLike vptr nv . mkBeePheremoneCloudLike
 
 mkBeePheremoneCloudLike :: BeePheremone -> (Point3, Point4)
-mkBeePheremoneCloudLike x = (20 & _xy .~ (x ^. bpPos), V4 1 1 0 a)
+mkBeePheremoneCloudLike x = (x ^. bpPos, V4 1 1 0 a)
   where
     a = 0.8 * min 1 (fromIntegral (_bpTimer x) / 100)