Work on bee aggression

appDodge/Main.hs

@@ -110,6 +110,7 @@ updateRenderSplit win u = do
 playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound)
 playSoundUnlessRewinding u = case w ^. timeFlow of
     NormalTimeFlow -> playSoundAndUpdate (_soundData $ _preloadData u) (_playingSounds w) (newSoundsToPlay u)
+    RespawnDelay{} -> playSoundAndUpdate (_soundData $ _preloadData u) (_playingSounds w) (newSoundsToPlay u)
     _ -> stopAllSounds >> return M.empty
   where
     w = _uvWorld u

src/Dodge/Barreloid.hs

@@ -26,7 +26,6 @@ updateExpBarrel ps cr w = case cr ^. crHP of
             & cWorld . lWorld . creatures . ix (_crID cr) %~ damsToExpBarrel damages
             & cWorld . lWorld . creatures . ix (_crID cr) . crHP . _HP
                 -~ length (_piercedPoints . _barrelType $ _crType cr)
-            & cWorld . lWorld . creatures . ix (_crID cr) . crDamage .~ mempty
             & flip (foldl' f) ps
     HP _ ->
         w

src/Dodge/Base/CardinalPoint.hs

@@ -21,6 +21,14 @@ cardVec = \case
     East -> V2 1 0
     West -> V2 (-1) 0
 
+vecCard :: Point2 -> CardinalPoint
+vecCard 0 = error "vecCard null"
+vecCard (V2 x y)
+    | x > abs y = East
+    | -x > abs y = West
+    | y > 0 = North
+    | otherwise = South
+
 card8Vec :: Cardinal8 -> Point2
 card8Vec cp = case cp of
     North8 -> V2 0 1

src/Dodge/Base/Collide.hs

@@ -18,6 +18,7 @@ module Dodge.Base.Collide (
     collideCircWalls,
     overlapSegWalls,
     overlapSegCrs,
+    overlapSegCrs',
     bouncePoint,
     circOnSomeWall,
     circOnAnyCr,
@@ -35,6 +36,7 @@ module Dodge.Base.Collide (
     crHeight,
 ) where
 
+import Control.Applicative
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
@@ -66,6 +68,15 @@ overlapSegCrs sp ep = mapMaybe f
         (,cr)
             <$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
 
+overlapSegCrs' :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
+{-# INLINE overlapSegCrs' #-}
+overlapSegCrs' sp ep = mapMaybe f
+  where
+    f cr =
+        (,cr)
+            <$> g (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
+    g (a,b) = a <|> b
+
 doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
 {-# INLINE doBounce #-}
 doBounce x sp ep (p, mwl) = fmap f mwl
@@ -180,6 +191,10 @@ crHeight cr = case cr ^. crHP of
         ChaseCrit {} -> 25
         Avatar {} -> 25
         CrabCrit {} -> 25
+        SlinkCrit {} -> 25
+        SlimeCrit {_slimeRad = r} -> min 15 r
+        BeeCrit {} -> 10
+        HiveCrit {} -> 25
         _ -> error "Need to define crHeight for this crType"
     CrIsCorpse{} -> Just 5
     CrDestroyed{} -> Nothing

src/Dodge/Bullet.hs

@@ -168,7 +168,7 @@ hitEffFromBul w bu = case _buEffect bu of
     DestroyBullet -> expireAndDamage bu hitstream w
   where
     sp = _buPos bu
-    hitstream = thingsHitZ 20 sp (sp + _buVel bu) w
+    hitstream = thingsHitZ' 20 sp (sp + _buVel bu) w
 
 getBulHitDams :: Bullet -> Point2 -> [Damage]
 getBulHitDams bu p = case _buPayload bu of

src/Dodge/Corpse/Make.hs

@@ -1,47 +0,0 @@
-module Dodge.Corpse.Make (makeCorpse) where
-
-import qualified Quaternion as Q
-import Linear
-import Control.Lens
-import Dodge.Creature.Picture
-import Dodge.Creature.Radius
-import Dodge.Creature.Shape
---import Dodge.Data.Corpse
-import Dodge.Data.Creature
-import Geometry
-import Shape
-import ShapePicture
-
-makeCorpse :: Creature -> SPic
-makeCorpse cr = case cr ^. crType of
-    HoverCrit{} -> noPic $ drawHoverCrit cr
-    ChaseCrit{} -> noPic $ chaseCorpse cr
-    _ ->
-        noPic
-            . scaleSH (V3 crsize crsize crsize)
-            $ mconcat
-                [ colorSH (_skinHead cskin) $ deadScalp cr
-                , colorSH (_skinUpper cskin) $ deadUpperBody cr
-                , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
-                ]
-  where
-    cskin = crShape $ _crType cr -- this should be fixed
-    crsize = 0.1 * crRad (cr ^. crType)
-    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
-
-chaseCorpse :: Creature -> Shape
-chaseCorpse cr = mconcat
-            [colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $ polyCirc 3 12 
-                & each %~ vNormal
-                & each . _y *~ 0.6
-            , colorSH (_skinUpper cskin) . 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]))
-            , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
-        ]
-  where
-    neckq = (V3 6 0 0, Q.qid)
-    cskin = crShape $ _crType cr -- this should be fixed
-    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
-    headq = neckq `Q.comp` (V3 16 0 0, Q.qid )

src/Dodge/Creature.hs

@@ -3,8 +3,6 @@ module Dodge.Creature (
     module Dodge.Creature.ChaseCrit,
     module Dodge.Creature.Inanimate,
     launcherCrit,
---    pistolCrit,
-    ltAutoCrit,
     spreadGunCrit,
     autoCrit,
     armourChaseCrit,
@@ -13,7 +11,6 @@ module Dodge.Creature (
     module Dodge.Creature.Impulse,
     module Dodge.Creature.Perception,
     module Dodge.Creature.ReaderUpdate,
-    module Dodge.Creature.SentinelAI,
     module Dodge.Creature.State,
     module Dodge.Creature.Strategy,
     module Dodge.Creature.Test,
@@ -34,10 +31,8 @@ import Dodge.Creature.ChaseCrit
 import Dodge.Creature.Impulse
 import Dodge.Creature.Inanimate
 import Dodge.Creature.LauncherCrit
-import Dodge.Creature.LtAutoCrit
 import Dodge.Creature.Perception
 import Dodge.Creature.ReaderUpdate
-import Dodge.Creature.SentinelAI
 import Dodge.Creature.SpreadGunCrit
 import Dodge.Creature.State
 import Dodge.Creature.Strategy
@@ -98,7 +93,6 @@ startCr =
         & crHP .~ HP 10000
         & crInv .~ mempty
         & crFaction .~ PlayerFaction
---        & crMvType .~ MvWalking yourDefaultSpeed
         & crType .~ Avatar (PulseStatus 55 0) Flesh 50 50 50 AvPosture LeftForward 0
 
 -- | Items you start with.

src/Dodge/Creature/Action.hs

@@ -106,7 +106,7 @@ tryEvadeSideways :: Creature -> World -> ActionUpdate
 tryEvadeSideways _ w = jumpleft -- (mv,mempty)
   where
     jumpleft = (mv,DoReplicate 5 (DoImpulses mv))
-    mv = [Walk (V2 0 d)]
+    mv = [Walk (V2 0 d),UpdateRandGen]
     d = evalState (takeOne [3,-3]) (w ^. randGen)
 
 performAimAt :: Creature -> World -> Int -> Point2 -> ActionUpdate
@@ -115,9 +115,12 @@ performAimAt cr w tcid p = ([TurnToward tpos aimSp], AimAt tcid tpos)
     cdir = _crDir cr
     cpos = cr ^. crPos . _xy
     canSee' = canSee (_crID cr) tcid w
-    aimSp = case crMvType cr ^? mvAimSpeed of
+    aimSp = case crMvType cr ^? mvTurnRad of
         Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
         Nothing -> error "creature without aiming type"
+--    aimSp = case crMvType cr ^? mvAimSpeed of
+--        Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
+--        Nothing -> error "creature without aiming type"
     tpos
         | canSee' = w ^?! cWorld . lWorld . creatures . ix tcid . crPos . _xy
         | otherwise = p
@@ -135,9 +138,15 @@ performPathTo a cr w p
         Just q -> gotowards q
         _ -> ([], a)
   where
-    gotowards q = ( [MvTurnToward q, MvForward, RandomTurn jit] , PathTo p a)
+    gotowards q = ( crMoveImpulses cr q , PathTo p a)
     cpos = cr ^. crPos . _xy
-    jit = _mvTurnJit $ crMvType cr
+
+crMoveImpulses :: Creature -> Point2 -> [Impulse]
+crMoveImpulses cr p = case crMvType cr of
+    NoMvType -> [MvTurnToward p, MvForward]
+    MvWalking {} -> [MvTurnToward p, MvForward]
+    JitMvType {_mvTurnJit = x} -> [MvTurnToward p, MvForward, RandomTurn x]
+    StartStopMvType {} -> [MvTurnToward p, MvForward]
 
 performTurnToA :: Creature -> Point2 -> ActionUpdate
 performTurnToA cr p

src/Dodge/Creature/ChaseCrit.hs

@@ -4,9 +4,14 @@ module Dodge.Creature.ChaseCrit (
     crabCrit,
     chaseCrit,
     hoverCrit,
+    slinkCrit,
+    slimeCrit,
+    beeCrit,
+    hiveCrit,
 ) where
 
---import Dodge.Data.Equipment.Misc
+import qualified Quaternion as Q
+import Linear
 import Dodge.Data.FloatFunction
 import Control.Lens
 import Dodge.Data.Creature
@@ -41,13 +46,37 @@ crabCrit = defaultCreature
         & crType .~ CrabCrit
             { _meleeCooldownL = 0
             , _meleeCooldownR = 0
-            , _footForward = LeftForward
-            , _strideAmount = 0
             , _dodgeCooldown = 0
+            , _lFootPos = 0
+            , _rFootPos = 0
             }
         & crFaction .~ ColorFaction red
         & crPerception . cpVision . viFOV .~ FloatFOV pi
 
+slinkCrit :: Creature
+slinkCrit = defaultCreature
+        & crName .~ "slinkCrit"
+        & crHP .~ HP 1000
+        & crType .~ SlinkCrit
+            { _meleeCooldown = 0
+            , _slinkSpine = replicate 15 (V3 0 0 2, Q.axisAngle (V3 0 1 0) (pi/15))
+            , _slinkHeadPos = (V3 20 0 15, Q.axisAngle (V3 0 1 0) (pi/2))
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slimeCrit :: Creature
+slimeCrit = defaultCreature
+        & crName .~ "slimeCrit"
+        & crHP .~ HP 1000
+        & crType .~ SlimeCrit r 0 0 (V2 r 0) False 0
+        & crFaction .~ ColorFaction (light green)
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+        & crActionPlan .~ SlimeIntelligence
+        & crStance . carriage .~ Crawling
+  where
+    r = 50
+
 hoverCrit :: Creature
 hoverCrit =
     defaultCreature
@@ -55,4 +84,22 @@ hoverCrit =
         & crHP .~ HP 150
         & crType .~ HoverCrit 0
         & crFaction .~ ColorFaction blue
-        & crStance . carriage .~ Flying 15 0.975
+        & crStance . carriage .~ Flying 15
+
+beeCrit :: Creature
+beeCrit =
+    defaultCreature
+        & crName .~ "beeCrit"
+        & crHP .~ HP 100
+        & crType .~ BeeCrit 0 Nothing 0 0
+        & crFaction .~ ColorFaction yellow
+        & crStance . carriage .~ Flying 15
+
+hiveCrit :: Creature
+hiveCrit =
+    defaultCreature
+        & crName .~ "hiveCrit"
+        & crHP .~ HP 100000
+        & crType .~ HiveCrit mempty 0
+        & crStance . carriage .~ Rooted
+        & crFaction .~ ColorFaction yellow

src/Dodge/Creature/Impulse.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Creature.Impulse (followImpulse) where
 
+import Control.Applicative
 import Control.Monad.Trans.State.Lazy
 --import Control.Monad.State -- moving from mtl to transformers
 import Data.Maybe
@@ -23,6 +24,7 @@ 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)))
     ImpulseNothing -> w
     RandomImpulse rimp ->
         let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w)
@@ -45,6 +47,19 @@ followImpulse cid w = \case
             crup
                 ( crMvAbsolute (w ^. cWorld . lWorld) (10 *.* normalizeV (posFromID cid' -.- cpos)) . (crType . meleeCooldown .~ 20)
                 )
+    MeleeL cid' ->
+        hitCrd (-pi/2) cid' $
+            crup
+               -- ( crMvAbsolute (w ^. cWorld . lWorld) (vNormal $ 10 *.* normalizeV (posFromID cid' -.- cpos)) 
+               -- . 
+                (crType . meleeCooldownL .~ 20)
+               -- )
+    MeleeR cid' ->
+        hitCrd (pi/2) cid' $
+            crup
+                --( crMvAbsolute (w ^. cWorld . lWorld) (vNormal $ (-10) *.* normalizeV (posFromID cid' -.- cpos)) . 
+                (crType . meleeCooldownR .~ 20)
+                --)
     RandomTurn a ->
         let (aa, g) = rr a
          in (randGen .~ g) (crup (crDir +~ aa))
@@ -56,7 +71,7 @@ followImpulse cid w = \case
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
         return $ followImpulse cid w (doCrImp f tcr)
-    MvForward -> crup $ crMvForward speed (w ^. cWorld . lWorld)
+    MvForward -> crup $ crMvForward' (w ^. cWorld . lWorld)
     MvTurnToward p ->
         crup $
             creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir))
@@ -65,8 +80,11 @@ followImpulse cid w = \case
     cr = w ^?! cWorld . lWorld . creatures . ix cid
     crup f = over clens f w
     mvType = crMvType cr
-    speed = _mvSpeed mvType
+--    speed = _mvSpeed mvType
-    turnRad = doFloatFloat $ _mvTurnRad mvType
+    turnRad = fromMaybe (const 0.1) $
+        mvType ^? mvTurnRad . to doFloatFloat
+        <|> mvType ^? mvTurnSpeed . to const
+--        | Just x <-  = doFloatFloat $ _mvTurnRad mvType
     cpos = cr ^. crPos . _xy
     cdir = _crDir cr
     posFromID cid' = w ^?! cWorld . lWorld . creatures . ix cid' . crPos . _xy
@@ -74,3 +92,8 @@ followImpulse cid w = \case
     hitCr i =
         cWorld . lWorld . creatures . ix i . crDamage
             .:~ Blunt 100 (posFromID i) (posFromID i - cpos)
+    hitCrd a i =
+        cWorld . lWorld . creatures . ix i . crDamage
+            <>~ [Blunt 100 (posFromID i) (posFromID i - cpos)
+                , Inertial 0 (posFromID i) (50 * unitVectorAtAngle (cr ^. crDir + a))
+                ]

src/Dodge/Creature/Impulse/Movement.hs

@@ -6,9 +6,11 @@ module Dodge.Creature.Impulse.Movement (
     crWalk,
     crMvByNoStride,
     crMvForward,
+    crMvForward',
     creatureTurnTo,
 ) where
 
+import Dodge.Creature.MoveType
 import Linear
 import Control.Lens
 import Dodge.Base
@@ -19,13 +21,9 @@ import Geometry
 {- | Creature attempts to moves under its own steam.
 The idea is that this may or may not work, depending on the status of the creature.
 For now, though, this cannot fail.
+p is the movement translation vector, will be made relative to creature direction
 -}
-crMvBy ::
+crMvBy :: Point2 -> LWorld -> Creature -> Creature
-    -- | Movement translation vector, will be made relative to creature direction
-    Point2 ->
-    LWorld ->
-    Creature ->
-    Creature
 crMvBy p lw cr = crMvAbsolute lw (rotateV (_crDir cr) p) cr
 
 crWalk ::
@@ -72,6 +70,18 @@ strengthFactor i
     | i < 1 = 0
     | otherwise = 0.02 * fromIntegral i
 
+crMvForward' :: LWorld -> Creature -> Creature
+crMvForward' lw cr = case crMvType cr of
+    JitMvType s _ _ -> crMvBy (V2 s 0) lw cr
+    StartStopMvType s _ n ->
+        let speed | cr ^?! crType . startStopMv > n = 0
+                | otherwise = s
+        in crMvBy (V2 speed 0) lw cr
+            & crType . startStopMv %~ ((`mod` (n*2)) . (+1))
+    NoMvType -> cr
+    MvWalking s -> crMvBy (V2 s 0) lw cr
+    
+
 crMvForward :: Float -> LWorld -> Creature -> Creature
 crMvForward speed = crMvBy (V2 speed 0)
 

src/Dodge/Creature/LtAutoCrit.hs

@@ -1,20 +0,0 @@
-module Dodge.Creature.LtAutoCrit (
-    ltAutoCrit,
-) where
-
---import Control.Lens
-import Dodge.Data.Creature
-import Dodge.Default
---import Dodge.Item.Held.Stick
---import qualified IntMapHelp as IM
---import Picture
-
-ltAutoCrit :: Creature
-ltAutoCrit =
-    defaultCreature
-        { --_crInv = IM.fromList [(0, autoPistol)]
-         _crHP = HP 500
-        }
---        & crType .~ LtAutoCrit
---        & crType . humanoidAI .~ LtAutoAI
---        & crType . skinUpper .~ lightx4 red

src/Dodge/Creature/Mass.hs

@@ -11,4 +11,8 @@ crMass = \case
     SwarmCrit -> 2
     AutoCrit -> 10
     BarrelCrit{} -> 10
+    SlinkCrit{} -> 100
     LampCrit {} -> 3
+    SlimeCrit {_slimeRad = r} -> r * r / 10
+    BeeCrit {_beeSlime = x} -> 3 + x
+    HiveCrit {} -> 100

src/Dodge/Creature/Material.hs

@@ -13,5 +13,9 @@ crMaterial = \case
     HoverCrit {} -> Metal
     SwarmCrit -> Flesh
     AutoCrit -> Flesh
+    SlinkCrit{} -> Flesh
     BarrelCrit{} -> Metal
     LampCrit{} -> Glass
+    SlimeCrit{} -> Flesh
+    BeeCrit{} -> Flesh
+    HiveCrit{} -> Flesh

src/Dodge/Creature/MaxHP.hs

@@ -13,4 +13,7 @@ crMaxHP = \case
     AutoCrit -> 100
     BarrelCrit{} -> 100
     LampCrit {} -> 50
-
+    SlinkCrit {} -> 1000
+    SlimeCrit {} -> 1000
+    BeeCrit {} -> 100
+    HiveCrit {} -> 10000

src/Dodge/Creature/MoveType.hs

@@ -7,29 +7,34 @@ import Control.Lens
 crMvType :: Creature -> CrMvType
 crMvType cr = case _crType cr of
     Avatar {} -> MvWalking 1.5
+    SlinkCrit {} -> NoMvType
     ChaseCrit {} -> defaultChaseMvType & mvSpeed .~ 1.8
     CrabCrit {} -> defaultChaseMvType & mvSpeed .~ 0.5
+        & mvTurnJit .~ 0.01
     HoverCrit {} -> defaultChaseMvType & mvSpeed .~ 0.16
     SwarmCrit -> defaultChaseMvType
     AutoCrit -> defaultAimMvType
     BarrelCrit {} -> defaultAimMvType
     LampCrit {} -> defaultAimMvType
+    SlimeCrit {} -> NoMvType
+    BeeCrit {} -> StartStopMvType 0.2 0.1 25
+    HiveCrit{} -> NoMvType
 
 defaultAimMvType :: CrMvType
 defaultAimMvType =
-    CrMvType
+    JitMvType
         { _mvSpeed = 3
         , _mvTurnRad = FloatConst 0.2
         , _mvTurnJit = 0.05
-        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
+--        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
         }
 
 defaultChaseMvType :: CrMvType
 defaultChaseMvType =
-    CrMvType
+    JitMvType
         { _mvSpeed = 2
         , _mvTurnRad = FloatAbsCheckGreaterLess (pi / 4) 0.2 0.05
         --, _mvTurnJit = 0.3
         , _mvTurnJit = 0.05
-        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
+--        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
         }

src/Dodge/Creature/Picture.hs

@@ -3,15 +3,13 @@ Drawing of creatures.
 Takes into account damage etc.
 -}
 module Dodge.Creature.Picture (
-    basicCrPict,
+    makeCorpse,
-    deadScalp,
+    drawCreature,
-    deadUpperBody,
-    deadFeet,
-    drawChaseCrit,
-    drawHoverCrit,
-    drawCrabCrit,
 ) where
 
+import Data.Foldable
+import qualified Data.Strict.Tuple as ST
+import RandomHelp
 import Dodge.Base.Collide
 import Control.Monad
 import Data.Maybe
@@ -35,6 +33,46 @@ import Shape
 --import Shape
 import ShapePicture
 
+drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
+drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
+    case cr ^. crType of
+        _ | CrIsCorpse sp <- cr ^. crHP -> sp
+        _ | null (cr ^? crHP . _HP) -> mempty
+        BarrelCrit{} -> barrelShape
+        LampCrit{_lampHeight = h} -> lampCrSPic h
+        ChaseCrit {} -> noPic $ drawChaseCrit w cr
+        Avatar {} -> basicCrPict m cr
+        SwarmCrit -> basicCrPict m cr
+        AutoCrit -> basicCrPict m cr
+        CrabCrit {} -> noPic $ drawCrabCrit w cr
+        HoverCrit{} -> noPic $ drawHoverCrit cr
+        SlinkCrit{} -> noPic $ drawSlinkCrit cr
+        SlimeCrit{} -> noPic $ drawSlimeCrit cr
+        BeeCrit{} -> noPic $ drawBeeCrit cr
+        HiveCrit{} -> drawHive
+  where
+    fallrot = case cr ^? crStance . carriage . carDir of
+        Just q -> _1 . each . sfVs . each %~ Q.rotate q
+        _ -> id
+
+drawSlimeCrit :: Creature -> Shape
+drawSlimeCrit cr = colorSH green 
+    $ upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) $ polyCirc 6 r
+    & each %~ scaleAlong d s
+    & each %~ scaleAlong (vNormal d) (1 / s)
+    & each %~ rotateV (-cr ^. crDir)
+    & each %~ (((r-cr^?!crType.slimeRadWobble)/r) *^)
+  where
+    r = cr ^?! crType . slimeRad
+    p = cr ^?! crType . slimeCompression
+    d = normalize p
+    s = norm p / r
+
+-- 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)
 
@@ -56,6 +94,18 @@ basicCrShape 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)
+        <> shead
+    & each . sfColor .~ cskin ^?! skinUpper
+  where
+    shead = polyCirc 6 15
+        & 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)))
+    g _ = upperPrismPoly Medium Important 2 $ polyCirc 6 15
+
 drawHoverCrit :: Creature -> Shape
 drawHoverCrit cr = colorSH (_skinHead cskin) 
     (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
@@ -66,10 +116,24 @@ drawHoverCrit cr = colorSH (_skinHead cskin)
     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
+
+drawBeeCrit :: Creature -> Shape
+drawBeeCrit cr = colorSH col
+    (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)
+    col | cr ^?! crType . beeAggro > 0 = red
+        | otherwise = yellow
+
 drawCrabCrit :: World -> Creature -> Shape
 drawCrabCrit w cr = mconcat 
     [ crabUpperBody w cr
-    , colorSH (_skinLower cskin) $ crabFeet cr
+    , colorSH (_skinLower cskin) $ crabFeet w cr
     ]
   where
     cskin = crShape $ _crType cr
@@ -85,12 +149,26 @@ drawChaseCrit w cr = mconcat
 
 crabUpperBody :: World -> Creature -> Shape
 crabUpperBody _ cr =  colorSH (_skinUpper cskin)
-    (overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 12 
+    (
+    overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
         & each . _x *~ 0.6) 
+    <> 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)
+    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
     cskin = crShape $ _crType cr
+    lcool = 1 - min 10 (fromIntegral . _meleeCooldownL $ _crType cr) / 10
+    rclawq = torsoq `Q.comp` (V3 2 (-8) 1, Q.slerp ratck rrest rcool)
+    ratck = Q.axisAngle (V3 0 0 1) (0.5 * pi)
+    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
@@ -145,19 +223,123 @@ feet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
 --    f i = 8 * (sLen - 2*i) / sLen
     f i = 8 * oneSmooth ((sLen - 2*i) / sLen)
 
-crabFeet :: Creature -> Shape
+crabFeet :: World -> Creature -> Shape
 {-# INLINE crabFeet #-}
-crabFeet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+crabFeet _ cr = 
-    (Just sa,Just LeftForward) -> sh (f sa)
+    uncurryV translateSHxy rpos (afoot & each . sfVs . each %~ Q.rotate r1)
-    (Just sa,Just RightForward) -> sh (-f sa)
+    <> (afoot 
-    _ -> sh 0
+        & each . sfVs . each %~ Q.rotate r2
+        & each . sfVs . each +~ V3 0 2 5)
+    <> uncurryV translateSHxy rpos' (afoot & each . sfVs . each %~ Q.rotate r1')
+    <> (afoot 
+        & each . sfVs . each %~ Q.rotate r2'
+        & 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)
+    <> 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
-    sh x = translateSHxy x off aFoot <> translateSHxy (- x) (- off) aFoot
+    rpos = rot (cr ^?! crType . rFootPos - cxy)
-    aFoot = upperPrismPolyST 10 $ polyCirc 3 2
+    rot = rotateV cdir 
-    off = 10
+    lpos = rot ( cr ^?! crType . lFootPos - cxy)
-    sLen = strideLength cr
+    f p q = q + 2 *^ (p - q)
---    f i = 8 * (sLen - 2*i) / sLen
+    cdir = -cr ^. crDir
-    f i = 8 * oneSmooth ((sLen - 2*i) / sLen)
+    cxy = cr ^. crPos . _xy
+    afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2
+    (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)
+    (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)
+
+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 = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+  where
+    a = angleThreeSides 10 (distance p q) 10
+    b = angleVV3 (q-p) (V3 0 0 (-1))
+    c = argV $ (p-q) ^. _xy
+    f x = Q.qz c * x
+
+--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 q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+--  where
+--    a = angleThreeSides 10 (distance p q) 10
+--    b = angleVV3 (q-p) (V3 0 0 (-1))
+--    c = argV $ (p-q) ^. _xy
+--    f x = Q.qz c * x
+
+makeCorpse :: StdGen -> Creature -> SPic
+makeCorpse g cr = case cr ^. crType of
+    HoverCrit{} -> noPic $ drawHoverCrit cr
+    ChaseCrit{} -> noPic $ chaseCorpse g cr
+    CrabCrit{} -> noPic $ crabCorpse g cr
+    BeeCrit{} -> noPic $ drawBeeCrit cr
+    _ ->
+        noPic
+            . scaleSH (V3 crsize crsize crsize)
+            $ mconcat
+                [ colorSH (_skinHead cskin) $ deadScalp cr
+                , colorSH (_skinUpper cskin) $ deadUpperBody cr
+                , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+                ]
+  where
+    cskin = crShape $ _crType cr -- this should be fixed
+    crsize = 0.1 * crRad (cr ^. crType)
+    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
+
+chaseCorpse :: StdGen -> Creature -> Shape
+chaseCorpse g cr = mconcat
+            [colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $ polyCirc 3 12 
+                & each %~ vNormal
+                & each . _y *~ 0.6
+            , colorSH (_skinUpper cskin) . 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]))
+            , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+        ]
+  where
+    neckq = (V3 6 0 0, Q.qz a)
+    (a,g') = 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 )
+
+crabCorpse :: StdGen -> Creature -> Shape
+crabCorpse g cr = mconcat
+    [ colorSH (_skinUpper cskin) $ overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
+        & each . _x *~ 0.6) 
+    , 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)
+    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
+    ra = fst $ randomR (-2,2) g'
+    ps = evalState (replicateM 4 (randInCirc 9)) g
+    mkfoot y p = 
+        let p' = 0 & _xy .~ p + V2 0 (3*y)
+            (q1,q2) = spiderJoint (V3 0 y 0) p'
+        in (afoot & each . sfVs . each %~ Q.apply (V3 0 y 0, q1))
+            <> (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
 
 deadFeet :: Creature -> Shape
 {-# INLINE deadFeet #-}
@@ -213,3 +395,14 @@ upperBody cr = arms cr <> torso cr
 drawEquipment :: IM.IntMap Item -> Creature -> SPic
 {-# INLINE drawEquipment #-}
 drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
+
+barrelShape :: SPic
+barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
+  where
+    ps = polyCirc 3 10
+
+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,7 +11,11 @@ crRad = \case
     ChaseCrit {} -> 10
     CrabCrit {} -> 10
     HoverCrit {} -> 8
+    BeeCrit {_beeSlime = x} -> sqrt $ 2^(2::Int) + x
     SwarmCrit -> 2
     AutoCrit -> 10
     BarrelCrit{} -> 10
     LampCrit {} -> 3
+    SlinkCrit {} -> 10
+    HiveCrit {} -> 20
+    SlimeCrit {_slimeRad = r,_slimeRadWobble = x} -> r - x

src/Dodge/Creature/ReaderUpdate.hs

@@ -9,7 +9,7 @@ module Dodge.Creature.ReaderUpdate (
 --    goToTarget,
     flockACC,
     chaseCritMv,
-    crabCritMv,
+    crabActionUpdate,
     setMvPosToTargetCr,
     setViewPos,
     hoverCritMv,
@@ -121,29 +121,34 @@ flockACC w cr = fromMaybe cr $ do
                             else negate r *.* horDir
                  in cr & crIntention . mvToPoint ?~ tpos +.+ horShift
 
-crabCritMv :: World -> Creature -> Creature
+crabActionUpdate :: Int -> World -> World
-crabCritMv w cr = case _apStrategy (_crActionPlan cr) of
+crabActionUpdate cid w = case _apStrategy (_crActionPlan cr) of
-    _ | Just tid <- melee -> cr & crActionPlan . apAction 
+    _ | Just tid <- meleel -> w & tocr . crActionPlan . apAction 
-                .~ DoImpulses [Melee tid] `DoActionThen`
+                .~ DoImpulses [MeleeL tid] `DoActionThen`
                         DoReplicate 10 NoAction
-        & crType . meleeCooldownL .~ 20
+    _ | Just tid <- meleer -> w & tocr . crActionPlan . apAction 
-    WarningCry -> cr
+                .~ DoImpulses [MeleeR tid] `DoActionThen`
-    CloseToMelee tid | aimi tid -> cr & crActionPlan . apAction .~ EvadeAim
+                        DoReplicate 10 NoAction
-        & crType . dodgeCooldown .~ dc
+    WarningCry -> w
-    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
+    CloseToMelee tid | aimi tid -> w & tocr . crActionPlan . apAction .~ EvadeAim
+        & tocr . crType . dodgeCooldown .~ dc
+        & randGen .~ g
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> w
     Wander | Just tid <- cr ^? crIntention . targetCr . _Just
-        , canSee tid (cr ^. crID) w -> cr & crActionPlan . apStrategy .~ CloseToMelee tid
+        , canSee tid (cr ^. crID) w -> w & tocr . crActionPlan . apStrategy .~ CloseToMelee tid
     _ -> case cr ^? crIntention . mvToPoint . _Just of
         Just p
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
-                cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
+                w & tocr . crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                w & tocr . crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-                    & crActionPlan . apStrategy .~ Search
+                    & tocr . crActionPlan . apStrategy .~ Search
-                    & crIntention . mvToPoint .~ Nothing
+                    & tocr . crIntention . mvToPoint .~ Nothing
-        _ -> viewTarget w cr
+        _ -> w & tocr %~ viewTarget w
   where
-    melee = do
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    tocr = cWorld . lWorld . creatures . ix cid
+    meleel = do
         tid <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix tid
         let cpos = cr ^. crPos . _xy
@@ -151,9 +156,23 @@ crabCritMv w cr = case _apStrategy (_crActionPlan cr) of
         guard $ _meleeCooldownL (_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
+            && (_crDir cr - argV (tpos -.- cpos)) > (-pi / 4)
+            && (_crDir cr - argV (tpos -.- cpos)) <= 0
+            && cr ^?! crType . meleeCooldownR < 15
         return tid
-    dc = fst $ randomR (15,25) (w ^. randGen)
+    meleer = do
+        tid <- cr ^? crIntention . targetCr . _Just
+        tcr <- w ^? cWorld . lWorld . creatures . ix tid
+        let cpos = cr ^. crPos . _xy
+            tpos = tcr ^. crPos . _xy
+        guard $ _meleeCooldownR (_crType cr) == 0
+            && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
+            && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
+            && (_crDir cr - argV (tpos -.- cpos)) < pi / 4
+            && (_crDir cr - argV (tpos -.- cpos)) >= 0
+            && cr ^?! crType . meleeCooldownL < 15
+        return tid
+    (dc,g) = randomR (15,50) (w ^. randGen)
     notpath = \case
         Just NoAction -> False
         Just PathTo {} -> False
@@ -161,6 +180,7 @@ crabCritMv w cr = case _apStrategy (_crActionPlan cr) of
         _ -> True
     aimi tid = fromMaybe False $ do
         tcr <- w ^? cWorld . lWorld . creatures . ix tid
+        hp <- cr ^? crHP . _HP
         Aiming <- tcr ^? crStance . posture
         let txy = tcr ^. crPos . _xy
             cxy = cr ^. crPos . _xy
@@ -169,6 +189,7 @@ crabCritMv w cr = case _apStrategy (_crActionPlan cr) of
             && abs (nearZeroAngle (tcr^.crDir - argV (cxy - txy))) < 0.3
             && isWalkable txy cxy w  
             && diffAngles (cr ^. crDir) (argV (txy - cxy)) < 0.1
+            && hp > 0
 
 chaseCritMv :: World -> Creature -> Creature
 chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of

src/Dodge/Creature/SentinelAI.hs

@@ -1,135 +0,0 @@
-module Dodge.Creature.SentinelAI (
-    sentinelAI,
-    sentinelFireType,
-    sentinelExtraWatchUpdate,
-) where
-
---import Control.Lens
-import Data.Maybe
---import Dodge.Creature.Action
---import Dodge.Creature.ChainUpdates
---import Dodge.Creature.Perception
---import Dodge.Creature.ReaderUpdate
---import Dodge.Creature.Strategy
-import Dodge.Creature.Test
-import Dodge.Creature.Volition
-import Dodge.Data.CreatureEffect
-import Dodge.Data.World
-import Geometry.Data
-
-sentinelAI :: World -> Creature -> Creature
---sentinelAI w =
-sentinelAI =
-    sentinelExtraWatchUpdate
-            [
-                ( crHasTargetLOS
-                , \_ cr ->
-                    StrategyActions
-                        (ShootAt (fromJust $ tcid cr))
-                        [ DoActionIf
-                            (WdCrNegate $ WdCrBlfromCrBl CrIsAiming)
-                            (drawWeapon `DoActionThen` (50 `WaitThen` NoAction))
-                            `DoActionThen` lostest
-                            `DoActionWhile` advanceShoot
-                            `DoActionThen` 75
-                            `DoReplicate` advanceShoot
-                            `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-                        , AimAt{_targetID = fromJust $ tcid cr, _targetSeenAt = V2 0 0}
-                        ]
-                )
-            ]
-  where
-    advanceShoot = DoImpulses [UseItem, MoveForward 3]
-    tcid cr = _targetCr (_crIntention cr)
-    lostest = WdCrLOSTarget -- w' cr = maybe False (\cid -> canSee (_crID cr) cid w') (tcid cr)
-
---chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature
---chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls
-
-sentinelFireType :: (Int -> Action) -> World -> Creature -> Creature
-sentinelFireType _ = undefined
---sentinelFireType f =
---    chainCreatureUpdates
---        [ watchUpdateStrat
---            [
---                ( crHasTargetLOS
---                , \_ _ ->
---                    StrategyActions
---                        (ShootAt 0)
---                        [ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
---                        , aiming
---                        ]
---                )
---            , (const crAwayFromPost, const goToPostStrat)
---            ]
---        , perceptionUpdate [0]
---        , --    , Left $ perceptionUp 0
---          const doStrategyActions
---        , targetYouWhenCognizant
---        , const $
---            overrideInternal
---                (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
---                (crActionPlan . apStrategy .~ WatchAndWait)
---        ]
---  where
---    drawwp = DoActionIfElse NoAction (WdCrBlfromCrBl CrIsAiming) (DoActionThen drawWeapon (WaitThen 50 NoAction))
---    aiming =
---        AimAt
---            { _targetID = 0
---            , _targetSeenAt = V2 0 0 -- hack
---            }
-
-sentinelExtraWatchUpdate ::
-    [(World -> Creature -> Bool, World -> Creature -> Strategy)] ->
-    World ->
-    Creature ->
-    Creature
-sentinelExtraWatchUpdate _ = undefined
---sentinelExtraWatchUpdate xs =
---    chainCreatureUpdates
---        [ watchUpdateStrat
---            (xs ++ [(const crAwayFromPost, const goToPostStrat)])
---        , perceptionUpdate [0]
---        , const doStrategyActions
---        , targetYouWhenCognizant
---        , const $
---            overrideInternal
---                (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
---                (crActionPlan . apStrategy .~ WatchAndWait)
---        ]
-
---shootAtAdvance :: Int -> [Action]
---shootAtAdvance tcid =
---    [ DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))
---      `DoActionThen`
---        lostest `DoActionWhile`
---        advanceShoot `DoActionThen`
---        75 `DoReplicate`
---        advanceShoot `DoActionThen`
---        DoImpulses [ChangeStrategy WatchAndWait]
---    , AimAt
---        { _targetID = tcid
---        , _targetSeenAt = V2 0 0 -- hack
---        }
---    ]
---  where
---    lostest (w,cr') = canSee (_crID cr') tcid w
---    advanceShoot = ImpulsesList [[UseItem, MoveForward 3]]
---
---shootAtWhileContinueTime :: Int -> World -> Creature -> Strategy
---shootAtWhileContinueTime tcid _ _ = StrategyActions (ShootAt tcid)
---    [ DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))
---      `DoActionThen`
---        lostest `DoActionWhile`
---        advanceShoot `DoActionThen`
---        75 `DoReplicate`
---        advanceShoot `DoActionThen`
---        DoImpulses [ChangeStrategy WatchAndWait]
---    , AimAt
---        { _targetID = tcid
---        , _targetSeenAt = V2 0 0 -- hack
---        }
---    ]
---  where
---    lostest (w,cr') = canSee (_crID cr') tcid w
---    advanceShoot = ImpulsesList [[UseItem, MoveForward 3]]

src/Dodge/Creature/Shape.hs

@@ -13,5 +13,9 @@ crShape = \case
     HoverCrit {} -> Humanoid (greyN 0.9) (light blue) (greyN 0.3)
     SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3)
     AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
+    SlinkCrit{} -> Humanoid (greyN 0.9) (dark . dark . dark $ orange) (greyN 0.3)
     BarrelCrit {} -> Barreloid
-    LampCrit {} -> NonDrawnCreature
+    LampCrit {} -> NoCreatureShape
+    SlimeCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
+    BeeCrit {} -> NoCreatureShape
+    HiveCrit {} -> NoCreatureShape

src/Dodge/Creature/State/WalkCycle.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Creature.State.WalkCycle (updateCarriage) where
+module Dodge.Creature.State.WalkCycle (updateCarriage
+    ,compressionScale) where
 
+import qualified Quaternion as Q
 import Dodge.Creature.Radius
 import Geometry
 import Dodge.Update.Camera.Rotate
@@ -25,31 +27,51 @@ updateCarriage' cid cr w = \case
     Walking -> maybeTakeStep cid cr w 
         & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
         & chasmTestCliffPush walkCliffPush cr
+    Crawling -> w & chasmTestCliffPush walkCliffPush cr
     Floating -> w
-    Flying {_zSpeed = dz, _flyInertia = x} ->
+    Flying {_zSpeed = dz} -> let x = flyInertia cr
+        in
           w & tocr . crPos . _xy +~ x *^ f (cr ^. crOldPos . _xy - oop ^. _xy)
             & tocr . crPos . _z +~ dz
             & tocr . crStance . carriage . zSpeed 
                 %~ if cr ^. crPos . _z < 17 then min 0.05 . (+0.001) else max (-0.05) . subtract 0.001
     Boosting {} -> w
-    Falling {} -> 
+    Falling {_fallRot = q, _carDir = q'} -> 
         let v = 0.95 *^ (cr ^. crOldPos - oop & _z -~ 0.5)
             ep = cr ^. crPos + v
         in if ep ^. _z < 0 && cr ^. crOldPos . _z >= 0 &&
                 (not (any (pointInPoly (ep ^. _xy)) (w ^. cWorld . chasms))
                     || any (uncurry $ crOnSeg cr) (w ^. cWorld . cliffs))
             then w & tocr . crPos .~ (ep & _z .~ 0)
-                    & cWorld . lWorld . creatures . ix cid . crStance . carriage .~ OnGround
+                    & cWorld . lWorld . creatures . ix cid . crStance . carriage .~ OnGround q'
             else w & cWorld . lWorld . creatures . ix cid . crPos .~ ep
+                    & cWorld . lWorld . creatures . ix cid . crStance . carriage . carDir *~ q
+                        
     OnGround {} -> w
         & tocr . crPos . _xy +~ 0.8 *^ (cr ^. crOldPos . _xy - oop ^. _xy)
         & chasmTestCliffPush groundCliffPush cr
+    Rooted {} -> w
+    Mounted mid p -> fromMaybe w $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        mp <- mcr ^? crPos
+        d <- mcr ^? crType . slimeCompression
+        r <- mcr ^? crType . slimeRad
+        return $ w & tocr . crPos .~ mp + (p & _xy %~ compressionScale ((1/r) *^ d))
   where
     tocr = cWorld . lWorld . creatures . ix cid
     oop = cr ^. crOldOldPos
     f v | norm v > 10 = 10 *^ signorm v
         | otherwise = v
 
+compressionScale :: Point2 -> Point2 -> Point2
+compressionScale d p = dot d p *^ normalize d
+    + (dot d' p / norm d) *^ d'
+  where
+    d' = vNormal $ normalize d
+
+flyInertia :: Creature -> Float
+flyInertia _ = 0.975
+
 pushAgainst :: Point2 -> Point2 -> Point2
 pushAgainst x y
     | a > norm y = 0
@@ -68,7 +90,8 @@ walkCliffPush cr xs = pushAgainst (cr ^. crOldPos . _xy - cr ^. crOldOldPos . _x
 groundCliffPush :: Creature -> [(Point2,Point2)] -> Point2
 groundCliffPush cr xs = x *^ circSegsInside cxy r xs
   where
-    x = max 0 $ 0.25 * (1 - dist cxy p / (2*r)) ** 2
+    -- at least 0.01 so that corpses don't hang on the edge of a cliff too long
+    x = max 0.01 $ 0.25 * (1 - dist cxy p / (2*r)) ** 2
     cxy = cr ^. crPos . _xy
     r = cr ^. crType . to crRad
     p = circSegsInside' cxy r xs
@@ -105,7 +128,10 @@ chasmTestCliffPush f' cr w
             & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
             & tocr . crPos . _xy +~ f' cr (xy:xys) -- (f cr (xy:xys)) *^ h xy xys
             & chasmRotate cr (uncurry (-) xy)
-    | any f (w ^. cWorld . chasms) = w & tocr . crStance . carriage .~ Falling -- %~ startFalling
+    | any f (w ^. cWorld . chasms) = w & tocr . crStance . carriage 
+        .~ Falling 
+            (Q.axisAngle (0 & _xy .~ vNormal (cr^.crOldOldPos._xy - cr^.crOldPos._xy)) 0.03) 
+            Q.qid
     | otherwise = w
   where
     cxy = cr ^. crPos . _xy

src/Dodge/Creature/Statistics.hs

@@ -3,7 +3,7 @@ module Dodge.Creature.Statistics (
     getCrMoveSpeed,
     crStrength,
     crDexterity,
-    crIntelligence,
+--    crIntelligence,
 ) where
 
 import Dodge.Data.Equipment.Misc
@@ -38,16 +38,19 @@ crStrength cr = case cr ^. crType of
     LampCrit {} -> 0
     _ -> 46
 
-crIntelligence :: Creature -> Int
+--crIntelligence :: Creature -> Int
-crIntelligence  cr = case cr ^. crType of
+--crIntelligence  cr = case cr ^. crType of
-    Avatar { _avIntelligence = x } -> x
+--    Avatar { _avIntelligence = x } -> x
-    ChaseCrit {} -> 20
+--    ChaseCrit {} -> 20
-    CrabCrit {} -> 20
+--    CrabCrit {} -> 20
-    HoverCrit {} -> 20
+--    HoverCrit {} -> 20
-    SwarmCrit -> 20
+--    SwarmCrit -> 20
-    AutoCrit -> 20
+--    AutoCrit -> 20
-    BarrelCrit {} -> 0
+--    BarrelCrit {} -> 0
-    LampCrit {} -> 0
+--    LampCrit {} -> 0
+--    SlinkCrit{} -> 5
+--    SlimeCrit{} -> 1
+--    BeeCrit{} -> 20
     
 
 getCrMoveSpeed :: LWorld -> Creature -> Int

src/Dodge/Creature/Test.hs

@@ -133,7 +133,8 @@ isAnimate :: Creature -> Bool
 {-# INLINE isAnimate #-}
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
-    _ -> True
+    SlimeIntelligence -> False
+    ActionPlan{} -> True
 
 hasAutoDoorBody :: Creature -> Bool
 hasAutoDoorBody cr = case cr ^. crHP of

src/Dodge/Creature/Update.hs

@@ -1,15 +1,23 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Dodge.Creature.Update (updateCreature) where
 
-import Dodge.Base.You
+--import Dodge.WorldEvent.ThingsHit
-import Control.Monad
+import Dodge.Base.Collide
+import Data.List (sortOn)
+import Dodge.Creature.Radius
+import Dodge.Zoning.Creature
+import Dodge.Creature.ChaseCrit
+import Dodge.Creature.Damage
 import Color
-import qualified Data.IntMap.Strict as IM
+import Control.Monad
+import qualified IntMapHelp as IM
 import Data.Maybe
 import Dodge.Barreloid
+import Dodge.Base.You
 -- import Dodge.Base.NewID
-import Dodge.Corpse.Make
 import Dodge.Creature.Action
+import Dodge.Creature.Picture
 import Dodge.Creature.State
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Vocalization
@@ -27,44 +35,281 @@ import Geometry
 import LensHelp
 import Linear
 import NewInt
+import qualified Quaternion as Q
 import RandomHelp
 import Shape
 import ShapePicture.Data
+import qualified Data.IntSet as IS
 
 -- Should separate out creature movement from other parts here
 -- 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
-    | CrIsCorpse _ <- cr ^. crHP = updateCarriage (_crID cr)
+    | otherwise = case cr ^. crHP of
-    | null (cr ^? crHP . _HP) = id
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . damageCorpse (_crID cr) cr
-    | otherwise = updateLivingCreature cr
+        CrDestroyed{} -> id
+        HP{} -> cleardamage . updateLivingCreature cr
   where
+    cleardamage = tocr . 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 =
+updateLivingCreature cr = case cr ^. crType of
-    case _crType cr of
+    Avatar{} ->
-        Avatar{} ->
+        (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
-            (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
+            . crUpdate cid
-                . crUpdate cid
+            . yourControl
-                . yourControl
+    LampCrit{} -> updateLampoid cr
-        LampCrit{} -> updateLampoid cr
+    BarrelCrit bt -> updateBarreloid bt cr
-        BarrelCrit bt -> updateBarreloid bt cr
+    ChaseCrit{} -> \w ->
-        ChaseCrit{} -> \w ->
+        crUpdate cid . performActions cid $
-            crUpdate cid . performActions cid $
+            over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
-                over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
+    CrabCrit{} ->
-        CrabCrit{} -> \w ->
+        crUpdate cid . performActions cid . crabCritInternal cid
-            crUpdate cid . performActions cid $
+    AutoCrit{} -> crUpdate cid
-                over (cWorld . lWorld . creatures . ix cid) (crabCritInternal w) w
+    SwarmCrit{} -> crUpdate cid
-        AutoCrit {} -> crUpdate cid
+    HoverCrit{} -> \w ->
-        SwarmCrit {} -> crUpdate cid
+        crUpdate cid . performActions cid . hoverCritHoverSound cr $
-        HoverCrit {} -> \w ->
+            over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
-            crUpdate cid . performActions cid . hoverCritHoverSound cr $
+    SlinkCrit{} -> slinkCritUpdate cid
-                over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
+    SlimeCrit{} -> slimeCritUpdate cid
+    BeeCrit{} -> crUpdate cid . performActions cid . updateBeeFromPheremones cr cid . updateBeeCrit cr cid
+    HiveCrit{} -> crUpdate cid . performActions cid . updateHiveCrit cr cid
   where
     cid = cr ^. crID
 
+updateHiveCrit :: Creature -> Int -> World -> World
+updateHiveCrit cr cid w
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees
+    , Just y <- cr ^? crType . hiveGestation
+    , y == 0 = w 
+        & tocr . crType . hiveChildren %~ IS.insert nid
+        & tocr . crType . hiveGestation .~ 50
+        & cWorld . lWorld . creatures . at nid ?~ ncr
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees = w
+        & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
+    | otherwise = w
+  where
+    nbees = 10
+    tocr = cWorld . lWorld . creatures . ix cid
+    nid = IM.newKey $ w ^. cWorld . lWorld . creatures
+    ncr = beeCrit & crPos .~ (cr ^. crPos + (0 & _xy +~ 25))
+        & crID .~ nid
+        & crType . beeHive ?~ cid
+
+updateBeeFromPheremones :: Creature -> Int -> World -> World
+updateBeeFromPheremones cr cid w
+    | 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
+
+updateBeeCrit :: Creature -> Int -> World -> World
+updateBeeCrit cr
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr
+    | otherwise = updateCalmBee cr
+
+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)
+        & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+    | otherwise = w & tocr . crType . beeAggro -~ 1
+        & tocr . crActionPlan . apStrategy .~ Search
+  where
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = tcr ^. crID == 0
+        && hasLOS cxy (tcr ^. crPos . _xy) w
+
+-- do bees need to be able to see slime targets?
+-- if no path can be made, reset harvest action
+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
+        = w & tocr . crType . beeSlime -~ 0.5
+    | Just hcr <- gethive
+    , Just _ <- cr ^? crStance . carriage . mountID
+    , Just x <- cr ^? crType . beeSlime 
+    , x >= 15
+        = w & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+            & tocr . crStance . carriage .~ Flying 0
+    | Just mid <- cr ^? crStance . carriage . mountID
+    , mountshakeoff mid = w & tocr . crActionPlan . apStrategy .~ Search
+            & 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 =
+         w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+    | 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)))
+    | Just (tcr,ti) <- gettarg
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.9*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 . crActionPlan . apAction .~ NoAction
+    | Just (tcr,_) <- gettarg = w
+            & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+    | otherwise = w & tocr . crActionPlan . apStrategy .~ Search
+  where
+    cxy = cr ^. crPos . _xy
+    mountshakeoff mid = fromMaybe True $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        SlimeCrit {_slimeSplitTimer = x} <- mcr ^? crType
+        return $ x > 0
+    sspeed = 0.05
+    gettarg = do
+        i <- cr ^? crActionPlan . apStrategy . harvestTarget 
+        tcr <-  w ^? cWorld . lWorld . creatures . ix i
+        x <- tcr ^? crType . slimeRad
+        guard $ x > 12
+        return (tcr,i)
+    gethive = do
+        i <- cr ^? crType . beeHive . _Just
+        w ^? cWorld . lWorld . creatures . ix i
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = fromMaybe False $ do
+        r <- tcr ^? crType . slimeRad
+        return $ r > 12
+
+slimeCritUpdate :: Int -> World -> World
+slimeCritUpdate cid w 
+    | r < 5 = w & cWorld . lWorld . creatures . ix cid . crHP .~ CrDestroyed Gibbed
+    | 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
+        = 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 . slimeEngulfProgress %~ (max 0 . subtract 0.5)
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    v = 0.1 *^ normalize p 
+    mvslime = cr & crType . slimeCompression +~ f v
+        & crPos . _xy +~ v
+        & crType . slimeIsCompressing %~ f'
+    f | t = negate
+      | otherwise = id
+    f'  | norm p > 3*r/2 = const True
+        | otherwise = id
+    t = cr ^?! crType . slimeIsCompressing
+    r = cr ^?! crType . slimeRad
+    p = cr ^?! crType . slimeCompression
+
+setSlimeDir :: Int -> Creature -> World -> State StdGen World
+setSlimeDir cid cr w = do
+    i <- state $ randomR (0,1)
+    d <- state $ randomR (0,2*pi)
+    if i < (r - 11) / 50
+        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
+--                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
+    
+
+doSlimeRadChange :: Creature -> Creature
+doSlimeRadChange = crType . slimeRadWobble %~ f
+  where
+    f x | x > 1 = x - 1
+        | x < -1 = x + 1
+        | otherwise = 0
+
+splitSlimeCrit' :: Point2 -> Point2 -> Int -> Creature -> World -> Maybe World
+splitSlimeCrit' p v cid cr w = do
+    (cr1,cr2) <- splitSlimeCrit p v cr
+    let cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
+        (s,g) = runState (takeOne [popS,pop1S,pop2S,pop3S]) (w ^. randGen)
+    return $ w & cWorld . lWorld . creatures . ix cid .~ cr1
+            & cWorld . lWorld . creatures . at cid' ?~ (cr2 & crID .~ cid')
+            & soundStart (CrSound cid) (cr ^. crPos . _xy) s Nothing
+            & randGen .~ g
+
+splitSlimeCrit :: Point2 -> Point2 -> Creature -> Maybe (Creature, Creature)
+splitSlimeCrit p v cr = do
+    let mp = closestPointOnLine p (p+v) cxy
+        h = r - distance mp cxy
+    guard $ h > 0
+    let a1 = segmentArea r h
+        a2 = pi*r*r - a1
+        r1 = sqrt (a1/pi)
+        r2 = sqrt (a2/pi)
+        mvdir 
+            | isLHS p (p+v) cxy = normalize (vNormal v)
+            | otherwise = - normalize (vNormal v)
+    return (cr' & crPos . _xy .~ mp + (r1 + 0.51) *^ mvdir
+                & crType . slimeRad .~ r1
+                & crType . slimeCompression .~ rotateV (argV mvdir) (V2 r1 0)
+                & crDir .~ argV mvdir
+        ,cr' & crPos . _xy .~ mp - (r2 + 0.51) *^ mvdir
+                & crType . slimeRad .~ r2
+                & crType . slimeCompression .~ rotateV (argV (-mvdir)) (V2 r2 0)
+                & crDir .~ argV (-mvdir)
+                & crType . slimeEngulfProgress .~ 0
+        )
+  where
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeRad
+    cr' = cr & crDamage .~ []
+        & crType . slimeRadWobble .~ 0
+        & crType . slimeSplitTimer .~ 10
+        & crType . slimeIsCompressing .~ False
+
+-- 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))
+
+slinkCritUpdate :: Int -> World -> World
+slinkCritUpdate cid w =
+    w
+        & cWorld
+        . lWorld
+        . creatures
+        . ix cid
+        . crType
+        . slinkSpine
+        . each
+        . _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
@@ -93,73 +338,83 @@ crUpdate cid =
     checkDeath cid
         . doDamage cid
         . invItemEffs cid
-        . updateCarriage cid  -- stride appears to be updated elsewhere as well
+        . updateCarriage cid -- stride appears to be updated elsewhere as well
 
 checkDeath :: Int -> World -> World
 checkDeath cid w = maybe id checkDeath' (w ^? cWorld . lWorld . creatures . ix cid) w
 
 checkDeath' :: Creature -> World -> World
 checkDeath' cr w = case cr ^. crHP of
-    HP x | x > 0 -> w & tocr . crDamage .~ []
+    HP x | x > 0 -> w
-    HP x | x > -200 && null (cr ^. crDeathTimer)
+    HP x
-        -> w & tocr %~ startDeathTimer
+        | x > -200 && null (cr ^. crDeathTimer) ->
-    HP x | x > -200 
+            w & tocr %~ startDeathTimer
-        ,Just y <- cr ^. crDeathTimer
+    HP x
-        , y > 0 ->
+        | x > -200
-            w
+        , Just y <- cr ^. crDeathTimer
-                & tocr . crDamage .~ []
+        , y > 0 -> w & tocr . crDeathTimer . _Just -~ 1
-                & tocr . crDeathTimer . _Just -~ 1
     HP _ ->
         w
             & dropAll cr -- the order of these is possibly important
             & stopSoundFrom (CrWeaponSound (_crID cr) 0)
             & corpseOrGib cr
+            & crDeathEffects cr
             & tocr . crStance . carriage %~ toDeathCarriage
     _ -> w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
+crDeathEffects :: Creature -> World -> World
+crDeathEffects cr w = case cr ^. crType of
+    BeeCrit {_beeHive = mhid} -> beepheremone $ fromMaybe w $ do
+        hid <- mhid
+        return $ w & cWorld . lWorld . creatures . ix hid . crType . hiveChildren %~ IS.delete (cr ^. crID)
+    _ -> w
+  where
+    beepheremone = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos . _xy) 200
+
 startDeathTimer :: Creature -> Creature
-startDeathTimer cr = cr
+startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
-    & crDeathTimer ?~ case cr ^. crType of
+            HoverCrit{} -> 0
-        HoverCrit {} -> 0
+            _ -> 5
-        _ -> 5
 
 toDeathCarriage :: Carriage -> Carriage
 toDeathCarriage = \case
-    Flying {} -> Falling
+    Flying{} -> Falling Q.qid Q.qid
-    Walking -> OnGround
+    Walking -> OnGround Q.qid
-    _ -> Falling
+    _ -> Falling Q.qid Q.qid
 
 -- could look at the amount of damage here (given by maxDamage) too
 corpseOrGib :: Creature -> World -> World
-corpseOrGib cr = case cr ^? crDamage . to maxDamageType . _Just . _1 of
+corpseOrGib cr w =
-    Just CookingDamage ->
+    w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
-        sethp (CrIsCorpse $ scorchSPic thecorpse)
+        Just CookingDamage ->
-            . dodeathsound CookDeath
+            sethp (CrIsCorpse $ scorchSPic thecorpse)
-    Just PoisonDamage ->
+                . dodeathsound CookDeath
-        sethp (CrIsCorpse $ poisonSPic thecorpse)
+        Just PoisonDamage ->
-            . dodeathsound PoisonDeath
+            sethp (CrIsCorpse $ poisonSPic thecorpse)
-    Just PhysicalDamage
+                . dodeathsound PoisonDeath
-        | _crPain cr > 300 ->
+        Just PhysicalDamage
-            makeCrGibs cr
+            | _crPain cr > 300 ->
-                . sethp (CrDestroyed Gibbed)
+                makeCrGibs cr
-                . dodeathsound GibsDeath
+                    . sethp (CrDestroyed Gibbed)
-    _ ->
+                    . dodeathsound GibsDeath
-        sethp (CrIsCorpse thecorpse)
+        _ ->
-            . dodeathsound PlainDeath
+            sethp (CrIsCorpse thecorpse)
+                . dodeathsound PlainDeath
   where
     dodeathsound dt = f dt . stopSoundFrom (CrMouth cid)
-    f dt w = fromMaybe w $ do
+    f dt w' = fromMaybe w' $ do
-        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w)
+        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w')
         sid <- msid
         return $
-            w
+            w'
                 & soundStart (CrMouth cid) (cr ^. crPos . _xy) sid Nothing
-                & randGen .~ g
+                & randGen
+                .~ g
     cid = cr ^. crID
     sethp x = cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ x
-    thecorpse = makeCorpse cr
+    thecorpse = makeCorpse (w ^. randGen) cr
 
 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
@@ -171,8 +426,8 @@ 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 :: Creature -> Creature
---startFalling cr = case cr ^. crStance . carriage of
+-- startFalling cr = case cr ^. crStance . carriage of
 --    Walking -> cr & crStance . carriage .~ Falling
 --    _ -> cr & crStance . carriage .~ Falling
 

src/Dodge/Creature/Vocalization.hs

@@ -26,12 +26,16 @@ crWarningSounds cr = case cr ^. crType of
         , seagullCry1S
         , seagullCry2S
         ]
+    SlinkCrit{} -> mempty
+    SlimeCrit{} -> mempty
     CrabCrit {} -> mempty
     HoverCrit {} -> mempty
     SwarmCrit -> mempty
     AutoCrit -> mempty
     BarrelCrit{} -> mempty
     LampCrit{} -> mempty
+    BeeCrit{} -> mempty
+    HiveCrit{} -> mempty
 
 crDeathSounds :: Creature -> DeathType -> [SoundID]
 crDeathSounds cr dt = case cr ^. crType of
@@ -39,10 +43,14 @@ crDeathSounds cr dt = case cr ^. crType of
     ChaseCrit{} -> defaultDeathSounds dt
     CrabCrit{} -> defaultDeathSounds dt
     HoverCrit{} -> hoverDeathSounds dt
+    SlinkCrit{} -> defaultDeathSounds dt
+    SlimeCrit{} -> defaultDeathSounds dt
     SwarmCrit -> mempty
     AutoCrit -> mempty
     BarrelCrit{} -> mempty
     LampCrit{} -> mempty
+    BeeCrit{} -> defaultDeathSounds dt
+    HiveCrit{} -> defaultDeathSounds dt
 
 defaultDeathSounds :: DeathType -> [SoundID]
 defaultDeathSounds = \case

src/Dodge/Damage.hs

@@ -66,7 +66,7 @@ damageInCircle f p r w =
         & cWorld . lWorld . creatures %~ docrdams
   where
     dowldams wds = foldl' g wds (wlsHitRadial p r w)
-    docrdams crs = foldl' h crs (crsHitRadial p r w)
+    docrdams crs = foldl' h crs (bodiesHitRadial p r w)
     g wds (x, wl) = wds & at (_wlID wl) . non mempty .:~ f x
     h crs (x, cr) = crs & ix (_crID cr) . crDamage .:~ f x
 

src/Dodge/Data/ActionPlan.hs

@@ -13,6 +13,7 @@ import Sound.Data
 
 data ActionPlan
     = Inanimate
+    | SlimeIntelligence
     | ActionPlan
         { -- _apImpulse :: [Impulse] -- done per frame
          _apAction :: Action -- updated per frame, likely persist across frames
@@ -39,12 +40,15 @@ data Impulse
     | DropItem
     | Bark SoundID -- placeholder for various communication types
     | Melee Int
+    | MeleeL Int
+    | MeleeR Int
     | ChangePosture Posture
     | MakeSound SoundID
     | ChangeStrategy Strategy
     | AddGoal Goal
     | ImpulseUseTarget { _impulseUseTarget :: CrImp }
     | ImpulseNothing
+    | UpdateRandGen
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data RandImpulse
@@ -146,6 +150,7 @@ data Strategy
     | Flee
 --    | MeleeStrike
     | Search
+    | HarvestFrom {_harvestTarget :: Int}
     deriving (Eq, Ord, Show) --Generic, Flat)
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Cloud.hs

@@ -42,9 +42,16 @@ data Gas = Gas
 data GasType = PoisonGas
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+data BeePheremone = BPheremone
+    { _bpPos :: Point2
+    , _bpTimer :: Int
+    }
+
 makeLenses ''Cloud
+makeLenses ''BeePheremone
 deriveJSON defaultOptions ''CloudType
 deriveJSON defaultOptions ''Cloud
+deriveJSON defaultOptions ''BeePheremone
 makeLenses ''Dust
 deriveJSON defaultOptions ''Dust
 makeLenses ''Gas

src/Dodge/Data/ComposedItem.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.ComposedItem where
 
+import Color.Data
 import Control.Lens
 import Dodge.Data.AmmoType
 import Dodge.Data.Item
@@ -26,7 +27,7 @@ data ItemSF -- Structural Function
     | JoystickSF
     | RemoteDetonatorSF
     | SmokeReducerSF
-    | NoSF
+    | NoSF Color
     | AmmoModifierSF AmmoType
     | AmmoTargetingSF AmmoType
     | AmmoPayloadSF AmmoType

src/Dodge/Data/Creature.hs

@@ -65,7 +65,7 @@ data CrHP
     | CrIsCorpse SPic
     | CrDestroyed CrDestructionType
 
-data CrDestructionType = Gibbed | Pitted
+data CrDestructionType = Gibbed | Pitted | Swallowed
 
 data DeathType = CookDeath | PoisonDeath | PlainDeath | GibsDeath
 

src/Dodge/Data/Creature/Misc.hs

@@ -15,6 +15,7 @@ import Dodge.Data.CamouflageStatus
 import Dodge.Data.FloatFunction
 import Dodge.Data.Material
 import Geometry.Data
+import qualified Data.IntSet as IS
 
 data Vocalization
     = VocTimer {_vcTime :: Int ,_vcMaxTime :: Int }
@@ -25,16 +26,16 @@ data CrMvType
     = NoMvType
     | MvWalking {_mvSpeed :: Float} -- note this may interact with a friction element
     -- so currently 26.04.03 the actual max speed when walking is twice this
-    | CrMvType
+    | JitMvType
         { _mvSpeed :: Float
         , _mvTurnRad :: FloatFloat
         , _mvTurnJit :: Float
-        , _mvAimSpeed :: FloatFloat
         }
---    | CrAccMv
+    | StartStopMvType
---        { _mvAcc :: Float
+        { _mvSpeed :: Float
---        , _mvTopSpeed :: Float
+        , _mvTurnSpeed :: Float
---        }
+        , _mvPulseTime :: Int
+        }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Pulse = PulseStatus
@@ -61,11 +62,34 @@ data CreatureType
     | CrabCrit 
         { _meleeCooldownL :: Int
         , _meleeCooldownR :: Int
-        , _footForward :: FootForward
-        , _strideAmount :: Float
         , _dodgeCooldown :: Int
+        , _lFootPos :: Point2
+        , _rFootPos :: Point2
         }
     | HoverCrit {_meleeCooldown :: Int}
+    | SlinkCrit 
+        { _meleeCooldown :: Int
+        , _slinkSpine :: [Point3Q]
+        , _slinkHeadPos :: Point3Q
+        }
+    | SlimeCrit
+        { _slimeRad :: Float
+        , _slimeRadWobble :: Float
+        , _slimeSplitTimer :: Int
+        , _slimeCompression :: Point2
+        , _slimeIsCompressing :: Bool
+        , _slimeEngulfProgress :: Float
+        } 
+    | BeeCrit
+        { _beeSlime :: Float
+        , _beeHive :: Maybe Int
+        , _startStopMv :: Int
+        , _beeAggro :: Int
+        }
+    | HiveCrit
+        { _hiveChildren :: IS.IntSet
+        , _hiveGestation :: Int
+        }
     | SwarmCrit
     | AutoCrit
     | BarrelCrit {_barrelType :: BarrelType}
@@ -80,7 +104,7 @@ data CreatureShape
         , _skinLower :: Color
         }
     | Barreloid
-    | NonDrawnCreature
+    | NoCreatureShape
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BarrelType

src/Dodge/Data/Creature/Stance.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -11,6 +12,7 @@ import Data.Aeson
 import Data.Aeson.TH
 import Dodge.Data.AimStance
 import Geometry.Data
+import Linear
 
 data Stance = Stance
     { _carriage :: Carriage
@@ -20,11 +22,14 @@ data Stance = Stance
 
 data Carriage
     = Walking 
+    | Crawling
     | Floating
-    | Flying {_zSpeed :: Float, _flyInertia :: Float}
+    | Flying {_zSpeed :: Float}--, _flyInertia :: Float}
     | Boosting Point2
-    | Falling 
+    | Falling {_fallRot :: Quaternion Float, _carDir :: Quaternion Float}
-    | OnGround
+    | OnGround {_carDir :: Quaternion Float}
+    | Rooted
+    | Mounted {_mountID :: Int, _mountPos :: Point3}
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data FootForward = LeftForward | RightForward
@@ -36,6 +41,7 @@ data Posture = Aiming | AtEase
 makeLenses ''Stance
 makeLenses ''Carriage
 makeLenses ''Posture
+deriveJSON defaultOptions ''Quaternion
 deriveJSON defaultOptions ''FootForward
 deriveJSON defaultOptions ''Posture
 deriveJSON defaultOptions ''Carriage

src/Dodge/Data/Item/Combine.hs

@@ -33,6 +33,7 @@ data ItemType
     | DETECTOR {_ibtDetector :: Detector}
     | ARHUD
     | LASER
+    | COMPASS
     deriving (Eq, Ord, Show, Read)
 
 data InventoryPathing

src/Dodge/Data/LWorld.hs

@@ -96,6 +96,7 @@ data LWorld = LWorld
     , _creatureGroups :: IM.IntMap CrGroupParams
     , _items :: IM.IntMap Item
     , _clouds :: [Cloud]
+    , _beePheremones :: [BeePheremone]
     , _dusts :: [Dust]
     , _gasses :: [Gas]
     , _gusts :: IM.IntMap Gust

src/Dodge/Data/SoundOrigin.hs

@@ -13,6 +13,7 @@ data SoundOrigin
     | BackgroundSound
     | OnceSound
     | CrSound Int
+    | CrFootSound Int Int
     | CrMouth Int
     | CrChasm Int
     | CrWeaponSound Int Int

src/Dodge/Data/WorldEffect.hs

@@ -60,7 +60,6 @@ data WdBl
     | WdBlNegate WdBl
     | WdBlCrFilterNearPoint Float Point2 CrBl
     | WdBlBtOn Int
---    | WdBlBtNotOff Int
 
 data WdP2f
     = WdP2f0

src/Dodge/Default/Creature.hs

@@ -49,8 +49,6 @@ defaultCreature =
         , _crFaction = NoFaction
         , _crIntention = defaultIntention
         , _crGroup = LoneWolf
---        , _crMvType = defaultAimMvType
---        , _crHammerPosition = HammerUp
         , _crName = "DEFAULTCRNAME"
 --        , _crStatistics = CreatureStatistics 50 50 50
         , _crDeathTimer = Nothing

src/Dodge/Default/World.hs

@@ -114,6 +114,7 @@ defaultLWorld =
         , _creatures = IM.empty
         , _creatureGroups = IM.empty
         , _clouds = mempty
+        , _beePheremones = mempty
         , _gasses = mempty
         , _dusts = mempty
         , _gusts = IM.empty

src/Dodge/HeldUse.hs

@@ -38,7 +38,7 @@ import Dodge.Tesla
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
-import Linear (_xy,_xyz)
+import Linear (_xy,_xyz,(*^))
 import ListHelp
 import NewInt
 import Picture.Base
@@ -228,7 +228,7 @@ heldItemMuzzles loc = \case
     BURSTRIFLE -> dbwMuzzles & ix 0 . mzPos .~ V2 25 0 & ix 0 . mzInaccuracy .~ 0.05
     MINIGUNX i ->
         [ Muzzle
-            (V2 (40 * fromIntegral j / fromIntegral i) 0)
+            (V2 (15 + 25 * fromIntegral j / fromIntegral i) 0)
             0
             0.05
             maguse1
@@ -1005,7 +1005,7 @@ makeBullet thebullet itm (p, q) w =
             .:~ ( thebullet
                     & buPos .~ bulpos
                     & buOldPos .~ bulpos
-                    & buVel %~ (rotateV dir . (muzvel *.*))
+                    & buVel %~ (rotateV dir . (muzvel *^))
                     & buDrag *~ drag
                 )
   where

src/Dodge/Humanoid.hs

@@ -26,20 +26,22 @@ chaseCritInternal w cr =
         , const (crVocalization %~ updateVocTimer)
         ]
 
-crabCritInternal :: World -> Creature -> Creature
+crabCritInternal :: Int -> World -> World
-crabCritInternal w =
+crabCritInternal cid w =
-    (crVocalization %~ updateVocTimer)
+--    (crVocalization %~ updateVocTimer)
-        . (crType . meleeCooldownL %~ max 0 . subtract 1)
+        (tocr %~ (crType . meleeCooldownL %~ max 0 . subtract 1))
-        . (crType . meleeCooldownR %~ max 0 . subtract 1)
+        . (tocr %~ (crType . meleeCooldownR %~ max 0 . subtract 1))
-        . (crType . dodgeCooldown %~ max 0 . subtract 1)
+        . (tocr %~ (crType . dodgeCooldown %~ max 0 . subtract 1))
-        . searchIfDamaged
+        . (tocr %~ searchIfDamaged)
-        . targetYouWhenCognizant w
+        . (tocr %~ targetYouWhenCognizant w)
-        . perceptionUpdate [0] w
+        . (tocr %~ perceptionUpdate [0] w)
-        . crabCritMv w
+        . crabActionUpdate cid
-        . setMvPosToTargetCr w
+        . (tocr %~ setMvPosToTargetCr w)
-        . setViewPos w
+        . (tocr %~ setViewPos w)
 --        . overrideMeleeCloseTarget w
-        . doStrategyActions
+        $ (tocr %~ doStrategyActions) w
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
 
 hoverCritInternal :: World -> Creature -> Creature
 hoverCritInternal w cr =

src/Dodge/Inventory/SelectionList.hs

@@ -8,6 +8,7 @@ module Dodge.Inventory.SelectionList (
     getItemValue,
 ) where
 
+import Geometry.Vector
 import Dodge.Creature.MaxHP
 import Dodge.Data.Equipment.Misc
 import Numeric
@@ -83,6 +84,7 @@ itemExternalValue :: Item -> World -> Creature -> Maybe (Either Int String)
 itemExternalValue itm w cr
     | EQUIP WRIST_ECG <- itm ^. itType = Just . Right .
         displayPulse $ cr ^?! crType . avatarPulse . pulseProgress
+    | COMPASS <- itm ^. itType = Just . Right . radToCompass . normalizeAngle $ w ^. wCam . camRot
     | Just t <- itm ^? itType . ibtIntroScanType = Just $ introScanValue cr t
     | ITEMSCAN <- itm ^. itType
     , Just ExamineInventory <- w ^? hud . subInventory
@@ -106,6 +108,20 @@ itemExternalValue itm w cr
         Just . Left $ ugateCalc x y
     | otherwise = mempty
 
+radToCompass :: Float -> String
+radToCompass x
+    | x > f 7 = "N"
+    | x > f 6 = "NE"
+    | x > f 5 = "E"
+    | x > f 4 = "SE"
+    | x > f 3 = "S"
+    | x > f 2 = "SW"
+    | x > f 1 = "W"
+    | x > f 0 = "NW"
+    | otherwise = "N"
+  where
+    f i = i * pi / 4 + pi/8
+
 ugateCalc :: Int -> Int -> Int
 ugateCalc x y = (x `div` ((2::Int) ^ (f y ::Int))::Int) `mod` 2
   where

src/Dodge/Item.hs

@@ -38,6 +38,7 @@ itemFromBase = \case
     UNIGATE -> unigate
     BINGATE -> bingate
     LASER -> laser
+    COMPASS -> compass
 
 itemFromAmmoMag :: AmmoMagType -> Item
 itemFromAmmoMag at = case at of

src/Dodge/Item/Display.hs

@@ -82,6 +82,7 @@ itemBaseName = \case
     UNIGATE -> "UNIGATE"
     NULGATE -> "NULGATE"
     LASER -> "LASER"
+    COMPASS -> "COMPASS"
 
 showInventoryPathing :: InventoryPathing -> String
 showInventoryPathing = \case

src/Dodge/Item/Draw/SPic.hs

@@ -36,6 +36,7 @@ itemSPic it = case it ^. itType of
     UNIGATE -> defSPic
     NULGATE -> defSPic
     LASER -> lasGunPic it
+    COMPASS -> defSPic
 
 craftItemSPic :: CraftType -> Shape
 craftItemSPic = \case

src/Dodge/Item/Grammar.hs

@@ -9,6 +9,7 @@ module Dodge.Item.Grammar (
     invIndents,
 ) where
 
+import Color
 import NewInt
 import Dodge.Item.Orientation
 import Dodge.ItemUseCondition
@@ -122,7 +123,7 @@ itemToFunction itm = case itm ^. itType of
     _ | Just amtype <- magAmmoType itm-- ^? itConsumables . magType
           , Just _ <- itm ^? itLocation . ilEquipSite . _Just ->
             AmmoMagSF 0 amtype
-    AMMOMAG{} -> maybe NoSF (AmmoMagSF 0) $ magAmmoType itm -- ^? itConsumables . magType
+    AMMOMAG{} -> maybe (NoSF (greyN 0.5)) (AmmoMagSF 0) $ magAmmoType itm -- ^? itConsumables . magType
     ATTACH REMOTESCREEN -> RemoteScreenSF
     ATTACH JOYSTICK -> JoystickSF
     ATTACH REMOTEDETONATOR -> RemoteDetonatorSF
@@ -143,7 +144,8 @@ itemToFunction itm = case itm ^. itType of
     ATTACH CAPACITOR -> CapacitorSF
     CRAFT TRANSFORMER -> TransformerSF
     CRAFT PUMP -> PumpSF
-    _ -> NoSF
+    COMPASS -> NoSF white
+    _ -> NoSF $ greyN 0.5
 
 treeToPotentialFunction :: DTree CItem -> S.Set ItemSF
 treeToPotentialFunction ldt = case ldt ^. dtValue . _1 . itType of

src/Dodge/Item/Held/BatteryGuns.hs

@@ -2,12 +2,12 @@ module Dodge.Item.Held.BatteryGuns (
     teslaCoil,
     laser,
     tractorGun,
+    compass, -- this should be elsewhere
 ) where
 
 import Control.Lens
 import Dodge.Data.Item
 import Dodge.Default.Item
---import Geometry.Data
 
 teslaCoil :: Item
 teslaCoil =
@@ -35,6 +35,9 @@ laser =
                 }
         & itType .~ LASER
 
+compass :: Item
+compass = defHeldItem & itType .~ COMPASS
+
 -- previous attractionPower values: 1, -1, -10, 0
 tractorGun :: Item
 tractorGun = defHeldItem & itType .~ HELD TRACTORGUN

src/Dodge/Item/InventoryColor.hs

@@ -29,7 +29,7 @@ sfInvColor = \case
     JoystickSF -> azure
     RemoteDetonatorSF -> azure
     SmokeReducerSF -> azure
-    NoSF -> greyN 0.5
+    NoSF c -> c
     AmmoModifierSF{} -> orange
     AmmoTargetingSF{} -> green
     AmmoPayloadSF{} -> violet

src/Dodge/Layout.hs

@@ -6,13 +6,12 @@ module Dodge.Layout (
     shuffleRoomPos,
 ) where
 
-import Control.Monad
 -- import Dodge.Path.Translate
 import qualified Control.Foldl as L
 import Control.Lens
+import Control.Monad
 import Data.Foldable
 import Data.Function
-import Linear
 -- import Data.Graph.Inductive (labEdges, labNodes)
 import Data.List (nubBy, sortOn)
 import Data.Maybe
@@ -33,6 +32,7 @@ import Dodge.Wall.Zone
 import Dodge.Zoning.Pathing
 import Geometry
 import qualified IntMapHelp as IM
+import Linear
 import RandomHelp
 
 generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld
@@ -68,9 +68,12 @@ randomCompass w =
 setTiles :: GenWorld -> GenWorld
 setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw
 
+-- setTiles gw = foldl' (flip setTile) gw . reverse . IM.elems $ _genRooms gw
+
 roomTileZeroShift :: Room -> Point2A
-roomTileZeroShift rm = fromMaybe (rm ^. rmShift) 
+roomTileZeroShift rm =
-    $ rm ^? rmFloor . tiles . ix 0 . tileZeroShift . _Just
+    fromMaybe (rm ^. rmShift) $
+        rm ^? rmFloor . tiles . ix 0 . tileZeroShift . _Just
 
 setTile :: Room -> GenWorld -> GenWorld
 setTile r gw = case _rmFloor r of
@@ -78,16 +81,18 @@ setTile r gw = case _rmFloor r of
         pid <- r ^. rmMParent
         rm <- gw ^? genRooms . ix pid
         guard $ rm ^? rmFloor . tiles . ix 0 . tileArrayZ == xs ^? ix 0 . tileArrayZ
-        return $ gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor . tiles . ix 0 . tileZeroShift 
+        return $
-            ?~ roomTileZeroShift rm
+            gw
+                & genRooms . ix (fromJust (_rmMID r)) . rmFloor . tiles . ix 0 . tileZeroShift
+                    ?~ roomTileZeroShift rm
     InheritFloor ->
         gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly]
   where
     t = fromMaybe (Tile poly (V2 0 0) (V2 1 0) 16 Nothing) $ do
-            pid <- r ^. rmMParent
+        pid <- r ^. rmMParent
-            rm <- gw ^? genRooms . ix pid
+        rm <- gw ^? genRooms . ix pid
-            (rm ^? rmFloor . tiles . ix 0)
+        (rm ^? rmFloor . tiles . ix 0)
-                <&> tileZeroShift ?~ roomTileZeroShift rm
+            <&> tileZeroShift ?~ roomTileZeroShift rm
     poly =
         orderPolygon
             . convexHullSafe
@@ -108,7 +113,7 @@ doInPlacements w =
     g rm = (rm ^?! rmMID . _Just,) <$> (rm ^. rmInPmnt)
     rplaceSpot i gw rx = placeSpot i (gw & gwWorld . randGen .~ gen) x
       where
-        (x,gen) = runState rx (gw ^. gwWorld . randGen)
+        (x, gen) = runState rx (gw ^. gwWorld . randGen)
 
 doIndividualPlacements :: GenWorld -> GenWorld
 doIndividualPlacements gw = foldl' doRoomPlacements gw (_genRooms gw)
@@ -219,6 +224,7 @@ tilesFromRooms = concatMap (getTiles . _rmFloor . doRoomShift)
 getTiles :: Floor -> [Tile]
 getTiles fl = case fl of
     Tiled xs -> xs
+    --    _ -> []
     _ -> error "tiles not correctly set for some room"
 
 -- divideWall :: Wall -> [Wall]

src/Dodge/LevelGen/StaticWalls.hs

@@ -6,7 +6,7 @@ module Dodge.LevelGen.StaticWalls
     ( cutWalls
     , removeInverseWalls
     , expandPolyByFixed
-    , cutPoly
+    , carvePoly
     , expandPolyCorners
     )
     where
@@ -35,13 +35,13 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     _  -> cutWallsRetry 0 ps wls
   where
-    newWalls = cutPoly ps wls
+    newWalls = carvePoly ps wls
 cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
 cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
     _  -> cutWallsRetry (i+1) ps wls
   where
-    newWalls = cutPoly ps' wls
+    newWalls = carvePoly ps' wls
     ps' = map (rotateV a) $ expandPolyBy x ps
     x = fromIntegral i / 100
     a | even i    = 0.001
@@ -74,8 +74,8 @@ checkWallRight (x,y) wls
 -- wall may be added where it shouldn't because the wrong facing wall is
 -- collided with
 -- Be aware that we do not remove all colinear walls; this may still cause bugs
-cutPoly :: [Point2] -> [WallP] -> [WallP]
+carvePoly :: [Point2] -> [WallP] -> [WallP]
-cutPoly qs wls = nubOrd
+carvePoly qs wls = nubOrd
     . removeInverseWalls
     . filter (not . wallIsZeroLength) 
     . fuseWallsWith zs

src/Dodge/LevelGen/StaticWalls/Deprecated.hs

@@ -49,7 +49,7 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
         ++ "\nWalls after cut:\n"
         ++ unlines (map show newWalls)
   where
-    newWalls = cutPoly ps wls
+    newWalls = carvePoly ps wls
     errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
 -- | Given a specific wall and list of walls, checks that the number of walls leaving the
 -- second point is the same as the number of walls entering the second point of

src/Dodge/Machine/Draw.hs

@@ -1,4 +1,4 @@
-module Dodge.Machine.Draw (drawMachine,mcColor) where
+module Dodge.Machine.Draw (drawMachine, mcColor) where
 
 import Control.Lens
 import qualified Data.Map.Strict as M
@@ -10,6 +10,7 @@ import Dodge.Placement.TopDecoration
 import Dodge.Room.Foreground
 import Dodge.Terminal.Color
 import Geometry
+import Linear
 import Picture
 import Shape
 import ShapePicture
@@ -38,16 +39,13 @@ drawDamSensor ::
     M.Map SensorType (PaletteColor, DecorationShape) ->
     DamageSensor ->
     SPic
-drawDamSensor gp sens = fold $ do
+drawDamSensor gp sens = foldMap sensorSPic $ gp ^? ix (sens ^. sensType)
-    let st = sens ^. sensType
-    x <- gp ^? ix st
-    return $ sensorSPic x
 
 terminalSPic :: LWorld -> Machine -> SPic
 terminalSPic lw = noPic . terminalShape lw
 
 terminalShape :: LWorld -> Machine -> Shape
-terminalShape lw mc = fromMaybe mempty $ do
+terminalShape lw mc = fold $ do
     tid <- mc ^? mcMounts . ix OTTerminal
     term <- lw ^? terminals . ix tid
     return $
@@ -56,28 +54,22 @@ terminalShape lw mc = fromMaybe mempty $ do
             ( prismBox
                 Medium
                 Typical
-                [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10]
+                tps
-                (addZ 0 `map` rectWH 10 10)
+                (tps & each . _z .~ 0)
             )
             <> screenbackground (getcol term)
   where
+    tps = [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10]
+    sps = [V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10]
     getcol term = fromMaybe black $ termScreenColor term
     screenbackground col =
         colorSH
             col
-            $ prismBox
+            $ prismBox Small Typical sps (sps & each . _z -~ 1)
-                Small
-                Typical
-                [V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10]
-                [V3 8 8 19, V3 (-8) 8 19, V3 0 (-8) 9]
 
 drawBaseMachine :: Float -> Machine -> SPic
 drawBaseMachine h mc =
-    noPic
+    noPic . colorSH (mcColor mc) . upperBox Medium Typical h . square $ 10
-        . colorSH (mcColor mc)
-        . upperBox Medium Typical h
-        . square
-        $ 10
 
 mcColor :: Machine -> Color
 mcColor mc = case mc ^. mcType of

src/Dodge/Render.hs

@@ -77,10 +77,15 @@ doDrawing' win pdata u = do
                 (0, 0, 0)
                 ws
             )
+    ncvs'' <- -- foldM (pokeCloud $ pdata ^. cloudVBO . vboPtr) 0 (w ^. cWorld . lWorld . clouds)
+        V.foldM'
+            (pokeBeePheremone (pdata ^. cloudVBO . vboPtr))
+            0
+            (V.fromList $ w ^. cWorld . lWorld . beePheremones)
     nCloudVs' <- -- foldM (pokeCloud $ pdata ^. cloudVBO . vboPtr) 0 (w ^. cWorld . lWorld . clouds)
         V.foldM'
             (pokeCloud (pdata ^. cloudVBO . vboPtr))
-            0
+            ncvs''
             (V.fromList $ w ^. cWorld . lWorld . clouds)
     nCloudVs <-
         V.foldM'

src/Dodge/Render/ShapePicture.hs

@@ -108,30 +108,6 @@ drawPlasmaBall pb =
         . setLayer BloomLayer
         $ circleSolidCol green white 5
 
-drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
-drawCreature w m cr = translateSP (_crPos cr) . rotateSP (_crDir cr) $
-    case cr ^. crType of
-        _ | CrIsCorpse sp <- cr ^. crHP -> sp
-        _ | null (cr ^? crHP . _HP) -> mempty
-        BarrelCrit{} -> barrelShape
-        LampCrit{_lampHeight = h} -> lampCrSPic h
-        ChaseCrit {} -> noPic $ drawChaseCrit w cr
-        Avatar {} -> basicCrPict m cr
-        SwarmCrit -> basicCrPict m cr
-        AutoCrit -> basicCrPict m cr
-        CrabCrit {} -> noPic $ drawCrabCrit w cr
-        HoverCrit{} -> noPic $ drawHoverCrit cr
-
-barrelShape :: SPic
-barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
-  where
-    ps = polyCirc 3 10
-
-lampCrSPic :: Float -> SPic
-lampCrSPic h =
-    colorSH blue (upperBox Small Undesired h $ rectWH 5 5)
-        :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-
 shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
 shiftDraw fpos fdir fdraw x =
     uncurryV translateSPxy (fpos x)

src/Dodge/Room/Tutorial.hs

@@ -57,11 +57,21 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
-        , chasmSpitTerminal
+        --, tToBTree "" . return . cleatOnward <$> (xChasm 200 200
-        , corDoor
+        , tToBTree "" . return . cleatOnward <$> ((putSingleLight =<< roomRectAutoLights 300 300)
-        , loadAmmoTut
+            <&> rmPmnts <>~ [sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 150 100
-        , corDoor
+            , sps0 (PutCrit hiveCrit) & plSpot . psPos .~ V2 250 50
-        , chasmSpitTerminal
+            , sps0 (PutCrit chaseCrit) & plSpot . psPos .~ V2 250 100
+            ]
+            )
+--        , tToBTree "" . return . cleatOnward <$> (cChasm
+--            <&> rmPmnts .:~ (sps0 (PutCrit slimeCrit) & plSpot . psPos .~ V2 100 20))
+--        , corDoor
+--        , loadAmmoTut
+--a        , corDoor
+--a        , chasmSpitTerminal
+--a        , corDoor
+--a        , tutHub
 --b        , corDoor
 --b        , tToBTree "slowCrush" . return . cleatOnward <$> pushCaverns
 --b        , corDoor
@@ -138,6 +148,27 @@ tutDrop = do
                , makeTermLine "-------------------------------------------"
                ]
 
+xChasm :: Float -> Float -> State LayoutVars Room
+xChasm x y = shuffleLinks =<< putSingleLight (roomRect x y 2 2
+    & rmLinks %~ (setOutLinks f . setInLinks f)
+    & rmPmnts <>~ fmap g [id,vNormal,vNormal.vNormal,vNormal.vNormal.vNormal]
+    )
+  where
+    g g' = sps0 $ putConvexChasm (ps & each %~ g'
+        & each +~ V2 (x/2) (y/2))
+    ps = fst (cutPoly (V2 x' (y'-10)) (V2 (x'-10) y') $ rectWH x' y')
+        & each -~ V2 (x/4+10) (y/4+10)
+    x' = x/4 - 10
+    y' = y/4 - 10
+    f rl = FromEdge North 1 `S.member` xs || FromEdge East 1 `S.member` xs
+      where
+        xs = rl ^. rlType
+--        & rmLinks %~ setOutLinks (isCornerLink NorthWest)
+--        <&> rmLinks
+--        %~ setInLinks (isCornerLink SouthWest)
+--        <&> rmPmnts
+--        <>~ [sps0 $ putConvexChasm (rectNSWE (y - 50) 50 0 (x - 50))]
+
 cChasm :: State LayoutVars Room
 cChasm = do
     x <- state $ randomR (150, 300)
@@ -339,14 +370,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
     return $
         tToBTree "chasmTerm" $
             Node
                 (addDoorToggleTerminal' i1 (PS 150 0) y')
-                [ treePost [triggerDoorRoom i1, deadEndPSType (PutCrit crabCrit)]
+                [ treePost [triggerDoorRoom i1, deadEndPSType cr]
-                --[ treePost [triggerDoorRoom i1, deadEndPSType (PutCrit hoverCrit)]
+                , treePost [triggerDoorRoom i1, deadEndPSType cr]
-                --[ treePost [triggerDoorRoom i1, deadEndRoom]
-                , treePost [triggerDoorRoom i1, deadEndPSType (PutCrit crabCrit)]
                 , return $ cleatOnward $ triggerDoorRoom i1
                 ]
   where
@@ -432,7 +462,7 @@ tutLight = do
 
 crabRoom :: State LayoutVars Room
 crabRoom = (putSingleLight =<< roomNgon 6 150)
-    <&> rmPmnts .:~ psPtPl (PS 100 0) (PutCrit crabCrit)
+    <&> rmPmnts .:~ psPtPl (PS 40 0) (PutCrit slimeCrit)
 
 loadAmmoTut :: State LayoutVars (MetaTree Room String)
 loadAmmoTut = do

src/Dodge/TestString.hs

@@ -2,6 +2,7 @@
 
 module Dodge.TestString where
 
+import Dodge.Creature.Radius
 import AesonHelp
 import qualified Control.Foldl as L
 import Control.Lens
@@ -41,8 +42,19 @@ tocrs :: (IM.IntMap Creature
 tocrs = uvWorld . cWorld . lWorld . creatures
 
 testStringInit :: Universe -> [String]
-testStringInit u = u ^.. tocrs . ix 1 . crActionPlan . apStrategy . to show
+testStringInit u = u ^.. tocrs . ix 2 . crType . hiveChildren . to show
-    <> u ^.. tocrs . ix 1 . crActionPlan . apAction . to show
+    <> u ^.. tocrs . ix 3 . crStance . carriage . to show
+    <> u ^.. tocrs . ix 3 . crDir . 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
+--    <> u ^.. tocrs . ix 1 . crType . to crRad . to show
+--    <> u ^.. tocrs . ix 1 . crType . slimeRad . to show
+--    <> u ^.. tocrs . ix 1 . crType . slimeRadWobble . to show
+--    <> u ^.. tocrs . ix 1 . crType . slimeIsCompressing . to show
+--    <> u ^.. tocrs . ix 1 . crDir . to show
+--    <> u ^.. tocrs . ix 1 . crDamage . to show
 --  where
 --    tocr = uvWorld . cWorld . lWorld . creatures . ix 0
 --    f = fromMaybe 0

src/Dodge/Update.hs

@@ -316,6 +316,7 @@ functionalUpdate =
             (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave)
         . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
         . over uvWorld updateClouds
+        . over uvWorld updateBeePheremones
         . over uvWorld updateGasses
         . over uvWorld updateDusts
         . over uvWorld updateGusts
@@ -371,13 +372,25 @@ muzzleWallCheck w cr = fromMaybe cr $ do
         _ -> Nothing
 
 updateCreatureStrides :: World -> World
-updateCreatureStrides = cWorld . lWorld . creatures . each %~ updateCreatureStride
+updateCreatureStrides w = foldl' updateCreatureStride w (w ^. cWorld . lWorld . creatures)
 
-updateCreatureStride :: Creature -> Creature 
+updateCreatureStride :: World -> Creature -> World
-updateCreatureStride cr 
+updateCreatureStride  w cr 
-    | Walking <- cr ^. crStance . carriage = cr & crType . strideAmount +~ d
+    | Walking <- cr ^. crStance . carriage 
-    | otherwise = cr
+        , CrabCrit {} <- cr ^. crType
+        = w & f footPin1S (g 10) (cr ^?! crType . lFootPos) lFootPos
+            & f footPin2S (g (-10)) (cr ^?! crType . rFootPos) rFootPos
+    | Walking <- cr ^. crStance . carriage
+        , isJust $ cr ^? crType . strideAmount = w & tocr . crType . strideAmount +~ d
+    | otherwise = w
   where
+    tocr = cWorld . lWorld . creatures . ix cid
+    cid = cr ^. crID
+    f sn p q fp 
+        | distance p q > 10 = (tocr . crType . fp .~ (p - 9 *^ signorm (q - p)))
+            . soundStart (CrFootSound cid 0) (p - 9 *^ signorm (q - p)) sn Nothing
+        | otherwise = id
+    g x = cr ^. crPos . _xy + x *^ vNormal (unitVectorAtAngle (cr ^. crDir))
     s = 2 * fromMaybe 1 (crMvType cr ^? mvSpeed)
 --    d = min s . norm $ cr ^. crPos - cr ^. crOldPos
     d = max 0 . min s $ dotV (cr ^. crPos . _xy - cr ^. crOldPos . _xy) (unitVectorAtAngle (cr ^. crMvDir))
@@ -596,7 +609,13 @@ setOldPos cr = cr & crOldPos .~ _crPos cr
 
 zoneCreatures :: World -> World
 zoneCreatures w =
-    w & crZoning .~ foldl' zoneCreature mempty (w ^. cWorld . lWorld . creatures)
+    w & crZoning .~ foldl' zoneCreature mempty (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures)
+
+zonableCreature :: Creature -> Bool
+zonableCreature cr = case cr ^. crHP of
+    HP{} -> True
+    CrIsCorpse{} -> True
+    CrDestroyed{} -> False
 
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w =
@@ -761,6 +780,15 @@ 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
+
 updateGasses :: World -> World
 updateGasses = updateObjCatMaybes gasses updateGas
 
@@ -868,7 +896,7 @@ checkEndGame uv = case w ^? timeFlow . respawnDelay of
                 & uvWorld . timeFlow .~ NormalTimeFlow
                 & uvWorld %~ respawn
     Just _ -> uv & uvWorld . timeFlow . respawnDelay -~ 1
-    _ | null (you w ^? crHP . _HP) -> uv & uvWorld . timeFlow .~ RespawnDelay 50
+    _ | null (you w ^? crHP . _HP) -> uv & uvWorld . timeFlow .~ RespawnDelay 100
     _ -> uv
   where
     w = _uvWorld uv
@@ -981,13 +1009,25 @@ canSpring cr =
         CrIsCorpse{} -> True
         CrDestroyed{} -> False
 
--- should possibly limit how big this can get
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2
     | id1 == id2 = id
     | vec == V2 0 0 = id
     | diff >= comRad = id
     | diffheight = id
+    | SlimeCrit{} <- c1 ^. crType
+    , SlimeCrit{} <- c2 ^. crType
+    , id2 > id1 
+    , distance xy1 xy2 < abs (r1 - r2) + 1 = fuseSlimes c1 c2
+    | SlimeCrit{} <- c1 ^. crType
+    , slimeFood c2
+    , distance xy1 xy2 < r1 - (r2 + 5)
+        = feedSlime c1 c2
+    | Just t <- c1 ^? crType . slimeSplitTimer 
+        , slimeFood c2
+        , t <= 0 = slimeSuck c1 c2
+    | SlimeCrit{} <- c1 ^. crType = id
+    | SlimeCrit{} <- c2 ^. crType = id
     | otherwise = cWorld . lWorld . creatures %~ ( olap c1 c2 . olap' c2 c1)
   where
     z c = c ^. crPos . _z
@@ -1000,11 +1040,86 @@ crCrSpring c1 c2
     olap' a b = ix (a ^. crID) . crPos . _xy -~ overlap b
     id1 = _crID c1
     id2 = _crID c2
+    xy1 = c1 ^. crPos . _xy
+    xy2 = c2 ^. crPos . _xy
     vec = c1 ^. crPos . _xy - c2 ^. crPos . _xy
     diff = magV vec
+    r1 = crRad (c1 ^. crType)
+    r2 = crRad (c2 ^. crType)
     comRad = crRad (c1 ^. crType) + crRad (c2 ^. crType)
-    overlap c = ((comRad - diff) * crMass (_crType c) * 0.5 / massT) *^ signorm vec
+    overlap c = ((comRad - diff) * cmass c * 0.5 / massT) *^ signorm vec
-    massT = crMass (_crType c1) + crMass (_crType c2)
+    massT = cmass c1 + cmass c2
+    cmass c = case c ^. crStance . carriage of
+        Falling {} -> crMass (c ^. crType) * 10
+        _ -> crMass (c ^. crType)
+
+slimeSuck :: Creature -> Creature -> World -> World
+slimeSuck c1 c2 = cWorld . lWorld . creatures %~ (rolap . rolap')
+  where
+    suckx = (min 1 $ 2 * (1 - distance xy1 xy2 / (r1 + r2))) ^ (2:: Int)
+    rolap = ix id1 . crPos . _xy +~ f (suckx * 1.5 * m2 / (m1+m2)) *^ normalize (xy2 - xy1)
+    rolap' = ix id2 . crPos . _xy +~ f (suckx * 1.5*m1 / (m1+m2)) *^ normalize (xy1 - xy2)
+    f = min (distance xy1 xy2/2)
+    id1 = _crID c1
+    id2 = _crID c2
+    xy1 = c1 ^. crPos . _xy
+    xy2 = c2 ^. crPos . _xy
+    r1 = crRad (c1 ^. crType)
+    r2 = crRad (c2 ^. crType)
+    m1 = crMass $ c1 ^. crType
+    m2 = crMass $ c2 ^. crType
+
+slimeFood :: Creature -> Bool
+slimeFood cr = case cr ^. crType of
+    Avatar{} -> True
+    ChaseCrit{} -> True
+    CrabCrit {} -> True
+    _ -> False
+
+feedSlime :: Creature -> Creature -> World -> World
+feedSlime s c w = fromMaybe w $ do
+    ch <- crHeight c
+    return $ if min 10 r1 + s ^?! crType . slimeEngulfProgress < max 15 (ch + 2)
+        then w & cWorld.lWorld.creatures.ix (s^.crID).crType.slimeEngulfProgress%~ (min r1.(+0.7))
+                & slimeSuck s c
+        else
+             w
+            & cWorld . lWorld . creatures . ix (c ^. crID) . crHP .~ CrDestroyed Swallowed
+            & cWorld . lWorld . creatures . ix (s ^. crID) %~ f
+            & slimeEatSound (s ^. crID) (s ^. crPos . _xy)
+  where
+    f cr = cr & crType . slimeRad .~ r
+            & crType . slimeRadWobble +~ r - r1
+            & crType . slimeCompression %~ ((r/r1) *^)
+    r1 = s ^?! crType . slimeRad
+    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)
+  where
+    c' | c1 ^?! crType . slimeRad > c2 ^?! crType . slimeRad = c1
+       | otherwise = c2
+    mini = min i1 i2
+    maxi = max i1 i2
+    i1 = c1 ^. crID
+    i2 = c2 ^. crID
+    c = c' & crType . slimeRad .~ r
+            & crType . slimeRadWobble +~ r - max r1 r2
+            & crType . slimeCompression %~ ((r/max r1 r2) *^)
+            & crID .~ mini
+    r1 = c1 ^?! crType . slimeRad
+    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
+        & randGen .~ g
+      where
+        (s,g) = runState (takeOne [slurp1S,slurp2S,slurp3S,slurp4S,slurp5S]) (w ^. randGen)
+    
 
 updateDelayedEvents :: World -> World
 updateDelayedEvents w =

src/Dodge/Update/Cloud.hs

@@ -1,5 +1,6 @@
 module Dodge.Update.Cloud (cloudPoisonDamage) where
 
+import Data.Maybe
 import Data.Foldable
 import Dodge.Creature.Radius
 import Dodge.Data.World
@@ -15,4 +16,5 @@ cloudPoisonDamage c w = foldl' (flip doDam) w (filter f $ crsNearPoint clpos w)
     doDam cr =
         cWorld . lWorld . creatures . ix (_crID cr) . crDamage .:~ Poison 1
     f cr = dist3 (_crPos cr & _z +~ 20) (_gsPos c) < crRad (cr ^. crType) + 20
+        && isJust (cr ^? crHP . _HP)
     clpos = stripZ $ _gsPos c

src/Dodge/WorldEvent/ThingsHit.hs

@@ -6,10 +6,11 @@ Find which objects lie upon a line.
 module Dodge.WorldEvent.ThingsHit (
     thingsHit,
     thingsHitZ,
+    thingsHitZ',
     thingHit,
     thingHitFilt,
     thingsHitExceptCr,
-    crsHitRadial,
+    bodiesHitRadial,
     wlsHitRadial,
     wlHitPos,
     crHit,
@@ -59,6 +60,14 @@ thingsHitZ z sp ep w =
         (map (second Left) (crsHitZ z sp ep w))
         (map (second Right) (wlsHit sp ep w))
 
+-- includes cr exit wounds
+thingsHitZ' :: Float -> Point2 -> Point2 -> World -> [(Point2, Either Creature Wall)]
+thingsHitZ' z sp ep w =
+    List.mergeOn
+        (dist sp . fst)
+        (map (second Left) (crsHitZ' z sp ep w))
+        (map (second Right) (wlsHit sp ep w))
+
 crWlPbHit :: Point2 -> Point2 -> World -> [(Point2, Object)]
 crWlPbHit sp ep w =
     List.mergeOn
@@ -104,6 +113,26 @@ crsHitZ z sp ep w
             . IS.toList
             . crixsNearSeg sp ep
             $ w
+  where
+    f cr
+--        | CrDestroyed{} <- cr ^. crHP = Nothing
+--        | otherwise = Just cr
+        | HP{} <- cr ^. crHP = Just cr
+        | CrIsCorpse{} <- cr ^. crHP
+            , z < 5 = Just cr
+        | otherwise = Nothing
+
+-- records exit wounds if there is no entry wound
+crsHitZ' :: Float -> Point2 -> Point2 -> World -> [(Point2, Creature)]
+crsHitZ' z sp ep w
+    | sp == ep = mempty
+    | otherwise =
+        sortOn (dist sp . fst)
+            . overlapSegCrs' sp ep
+            . mapMaybe (\cid -> f =<< w ^? cWorld . lWorld . creatures . ix cid)
+            . IS.toList
+            . crixsNearSeg sp ep
+            $ w
   where
     f cr
         | HP{} <- cr ^. crHP = Just cr
@@ -182,12 +211,21 @@ wlsHitRadial p r = IM.mapMaybe f . wlsNearCirc p r
         mhp = orthp <|> t (return x) <|> t (return y)
 --        v = normalizeV . vNormal . uncurry (-) $ _wlLine wl
 
-crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
+--crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
-crsHitRadial p r = mapMaybe f . IM.elems . crsNearCirc p r
+--crsHitRadial p r = mapMaybe f . IM.elems . crsNearCirc p r
+--  where
+--    f cr = do
+--        let cp = cr ^. crPos . _xy
+--        guard $ dist p cp < r + crRad (_crType cr)
+--        return (cp + (1 + crRad (_crType cr)) *^ (cp - p), cr)
+
+bodiesHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
+bodiesHitRadial p r = mapMaybe f . IM.elems . crsNearCirc p r
   where
     f cr = do
         let cp = cr ^. crPos . _xy
         guard $ dist p cp < r + crRad (_crType cr)
+            && (isJust (cr ^? crHP . _HP) || isJust (cr ^? crHP . _CrIsCorpse))
         return (cp + (1 + crRad (_crType cr)) *^ (cp - p), cr)
 
 isFlyable :: Point2 -> Point2 -> World -> Bool

src/Geometry/Intersect.hs

@@ -4,6 +4,7 @@
 {- Testing for and finding intersection points.  -}
 module Geometry.Intersect where
 
+import Data.List (sortOn)
 import Control.Applicative
 import Control.Lens
 import Control.Monad
@@ -264,6 +265,14 @@ intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail x
   where
     lineColl = intersectSegSeg a b
 
+-- orders intersecting points according to the line
+intersectLinePoly :: Point2 -> Point2 -> [Point2] -> [Point2]
+intersectLinePoly a b (p:ps) = sortOn (dotV (b - a)) 
+    . catMaybes
+    $ zipWith (\x y -> intersectSegLine x y a b) (p:ps) (ps ++[p])
+intersectLinePoly _ _ [] = error "intersectLinePoly empty polygon"
+
+
 {- | Given a line and a point return the point on the line closest to the
  point.
 -}

src/Geometry/Polygon.hs

@@ -202,3 +202,41 @@ shrinkPolyOnEdges _ _ = error "too few vertices in polygon"
 shrinkVert :: Float -> [Point2] -> Point2
 shrinkVert d [x, y, z] = x +.+ (d *.* normalizeV (x -.- y)) +.+ (d *.* normalizeV (z -.- y))
 shrinkVert _ _ = error "wrong number of vertices"
+
+-- divide a polygon into two along a line
+-- assumes the line intersects the polygon exactly twice, nocolinearity
+-- this may duplicate points
+-- this should be tested: there are many possible points of failure...
+cutPoly :: Point2 -> Point2 -> [Point2] -> ([Point2],[Point2])
+cutPoly a b (p:ps)
+    | not (isLHS a b p) && not (isRHS a b p) = cutPolyL a b ps p p [p] [p]
+    | isLHS a b p = cutPolyL a b ps p p [p] []
+    | otherwise = cutPolyR a b ps p p [] [p]
+cutPoly _ _ [] = error "cutPoly empty poly"
+
+cutPolyL :: Point2 -> Point2 -> [Point2] -> Point2 -> Point2 -> [Point2] -> [Point2] -> ([Point2], [Point2])
+cutPolyL a b (p:ps) e x ls rs
+    | isLHS a b p = cutPolyL a b ps e p (p\:ls) rs
+    | otherwise = case intersectLineLine x p a b of
+        Nothing -> error "cutPolyL nonintersecting lines"
+        Just p' -> cutPolyR a b ps e p (p'\:ls) (p\:p'\:rs)
+cutPolyL 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))
+
+cutPolyR :: Point2 -> Point2 -> [Point2] -> Point2 -> Point2 -> [Point2] -> [Point2] -> ([Point2], [Point2])
+cutPolyR a b (p:ps) e x ls rs
+    | isRHS a b p = cutPolyR a b ps e p ls (p\:rs)
+    | otherwise = case intersectLineLine x p a b of
+        Nothing -> error "cutPolyR nonintersecting lines"
+        Just p' -> cutPolyL a b ps e p (p\:p'\:ls) (p'\:rs)
+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))
+
+infixr 5 \:
+(\:) :: Eq a => a -> [a] -> [a]
+(\:) x (y:ys) 
+    | x /= y = x:y:ys
+    | otherwise = y:ys 
+(\:) x [] = [x]

src/Geometry/Vector.hs

@@ -67,6 +67,12 @@ angleVV a b
             d = a `dotV` b
          in acos $ d / (ma * mb)
 
+-- returns the angle opposite length a
+angleThreeSides :: Float -> Float -> Float -> Float
+angleThreeSides a b c = acos $ (f b + f c - f a) / (2*b*c)
+  where
+    f = (^ (2 ::Int))
+
 -- | Safe version of 'angleVV' that returns 0 if either vector is null.
 safeAngleVV :: Point2 -> Point2 -> Float
 {-# INLINE safeAngleVV #-}

src/Geometry/Vector3D.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
 module Geometry.Vector3D
     where
+import Linear
 import Geometry.Vector
 import Geometry.Data
 
@@ -121,7 +122,7 @@ dotV3 (V3 x y z) (V3 a b c) = x*a + y*b + z*c
 
 angleVV3 :: Point3 -> Point3 -> Float
 angleVV3 a b 
-    | a == b = 0
+    | a == b || norm a == 0 || norm b == 0 = 0
     | otherwise = acos $ dotV3 a b / (magV3 a * magV3 b)
 
 --projV3 :: Point3 -> Point3 -> Point3

src/Shader/Poke.hs

@@ -133,11 +133,12 @@ pokeShapeObj ::
     IO (Int, Int, Int)
 {-# INLINE pokeShapeObj #-}
 pokeShapeObj shadowtest ptr iptr ieptr counts surf@(Surface shtype shVerts col _ _) = case shtype of
-    FlatFaces size -> pokeBox blockshadows col size ptr iptr ieptr counts shVerts
+    FlatFaces size -> pokeBox t col size ptr iptr ieptr counts shVerts
-    RoundedFaces size -> pokeRoundedFaces blockshadows col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces t col size ptr iptr ieptr counts shVerts
-    Cylinder size -> pokeCylinder blockshadows col size ptr iptr ieptr counts shVerts
+    Cylinder size -> pokeCylinder t col size ptr iptr ieptr counts shVerts
+    Cone n -> pokeCone t col n ptr iptr ieptr counts shVerts
   where
-    blockshadows = shadowtest surf
+    t = shadowtest surf
 
 pokeRoundedFaces ::
     Bool ->
@@ -167,7 +168,7 @@ pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = d
   where
     xdata
         | sfid = 0 -- this records whether the shadow should be shown or not
-        -- honestly, I think things where faster without this
+        -- honestly, I think things were faster without this
         | otherwise = 1
 pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined
 
@@ -211,11 +212,19 @@ pokeRoundedCurve xdata col ptr tc bc = go True
     go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs
     go _ [] n = return n
 
+pokeCone :: Bool -> Color -> Int -> Ptr Float -> Ptr GLuint -> Ptr GLuint 
+    ->  (Int,Int,Int) -> [Point3] -> IO (Int,Int,Int)
+pokeCone t c n ptr iptr ieptr (nv,nsi,nei) (p:ps) = do
+    nv' <- undefined t c n ptr iptr ieptr (nv,nsi,nei) (p:ps)
+    nsi' <- undefined
+    nei' <- undefined
+    return (nv', nsi', nei')
+pokeCone _ _ _ _ _ _ _ _ = undefined
+
 -- I am not completely sure the normals are correct here
 -- they assume that we do actually have a cylinder, with normals for the caps
 -- that can be determined by the first two vertices
-pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> [Point3] -> Int 
+pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> [Point3] -> Int -> IO Int
-    -> IO Int
 {-# INLINE pokeCylinderCaps #-}
 pokeCylinderCaps xdata col ptr (a:b:as) = go True (a:b:as)
   where

src/Shader/Poke/Cloud.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Shader.Poke.Cloud (pokeCloud, pokeDust) where
+module Shader.Poke.Cloud (pokeCloud, pokeDust, pokeBeePheremone) where
 
+import Linear
 import Shader.Parameters
 import Color
 import Control.Lens
@@ -18,6 +19,15 @@ pokeDust :: Ptr Float -> Int -> Dust -> IO Int
 {-# INLINE pokeDust #-}
 pokeDust vptr nv = pokeCloudLike vptr nv . mkDustCloudLike
 
+pokeBeePheremone :: Ptr Float -> Int -> BeePheremone -> IO Int
+{-# INLINE pokeBeePheremone #-}
+pokeBeePheremone vptr nv = pokeCloudLike vptr nv . mkBeePheremoneCloudLike
+
+mkBeePheremoneCloudLike :: BeePheremone -> (Point3, Point4)
+mkBeePheremoneCloudLike x = (20 & _xy .~ (x ^. bpPos), V4 1 1 0 a)
+  where
+    a = 0.8 * min 1 (fromIntegral (_bpTimer x) / 100)
+
 mkCloudCloudLike :: Cloud -> (Point3, Point4)
 mkCloudCloudLike x = (x ^. clPos, V4 r g b a)
   where

src/Shape.hs

@@ -17,6 +17,7 @@ module Shape (
     upperPrismPolyHalf,
     upperPrismPolyHalfMI,
     upperPrismPolyHalfST,
+    upperPrismPolyScale,
     xCylinderST,
     prismPoly,
     prismBox,
@@ -57,12 +58,7 @@ polyCircx n = map (vNormaly . addZ 0) . polyCirc n
 -- points should be correctly ordered so that
 -- polys form a prism-like object with quad faces between them
 -- each layer of points must be arranged anticlockwise
-prismPoly ::
+prismPoly :: Size -> Importance -> [Point3] -> [Point3] -> Shape
-    Size ->
-    Importance ->
-    [Point3] ->
-    [Point3] ->
-    Shape
 {-# INLINE prismPoly #-}
 prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps downps) white shads size]
   where
@@ -201,13 +197,7 @@ upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important
 upperPrismPolyHalfST :: Float -> [Point2] -> Shape
 upperPrismPolyHalfST = upperPrismPolyHalf Small Typical
 
-upperPrismPolyHalf ::
+upperPrismPolyHalf :: Size -> Importance -> Float -> [Point2] -> Shape
-    -- | height, expected to be strictly positive
-    Size ->
-    Importance ->
-    Float ->
-    [Point2] ->
-    Shape
 {-# INLINE upperPrismPolyHalf #-}
 upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps
   where
@@ -216,6 +206,21 @@ upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps
     f (V2 x y) = V3 (0.5 * x) (0.5 * y) h
     g (V2 x y) = V3 x y 0
 
+upperPrismPolyScale ::
+    Float ->
+    Size ->
+    Importance ->
+    Float ->
+    [Point2] ->
+    Shape
+{-# INLINE upperPrismPolyScale #-}
+upperPrismPolyScale s size shad h ps = prismPoly size shad upps downps
+  where
+    upps = map f ps
+    downps = map g ps
+    f (V2 x y) = V3 (s * x) (s * y) h
+    g (V2 x y) = V3 x y 0
+
 upperBoxHalf ::
     -- | height, expected to be strictly positive
     Size ->

src/Shape/Data.hs

@@ -12,6 +12,7 @@ data ShapeType
     = FlatFaces { _topBoxSize :: Int }
     | RoundedFaces { _shapeHalfSize :: Int }
     | Cylinder { _cylinderSize :: Int }
+    | Cone {_coneBaseNum :: Int}
     deriving (Eq, Ord, Show, Read)
 -- for RoundedFaces, the first vertex in _sfVs should be the center of the top
 -- plane, the second should be the center of the bottom plane.