Cleanup

More tweaking needs to be done, after deciding a max width for selection
items.

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/AesonHelp.hs

@@ -6,7 +6,8 @@ import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Maybe
 
 getPretty :: ToJSON a => a -> [String]
-getPretty = lines . unpack . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
+--getPretty = lines . unpack . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
+getPretty = lines . unpack . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) mempty AEP.Generic False)
 
 prettyShort :: ToJSON a => a -> [String]
 prettyShort = mapMaybe cullPretty . getPretty

src/Dodge/Barreloid.hs

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

src/Dodge/Base/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,
@@ -33,8 +34,11 @@ module Dodge.Base.Collide (
     collide3WallsFloor,
     collide3,
     crHeight,
+    crMid,
 ) where
 
+import AesonHelp
+import Control.Applicative
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
@@ -66,6 +70,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
@@ -162,26 +175,41 @@ collide3Wall sp wl (ep, mo) = maybe (ep, mo) (,Just (n, OWall wl)) $ intersectSe
 
 collide3Creature :: Point3 -> Creature -> (Point3, MPO) -> (Point3, MPO)
 collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
-    h <- crHeight cr
-    (p, n) <-
-        fst $
-            intersectCylSeg
-                (cr ^. crPos)
-                (crRad $ cr ^. crType)
-                h
-                sp
-                ep
+    let h = crHeight cr
+    (p, n) <- fst $ intersectCylSeg (cr ^. crPos) (crRad $ cr ^. crType) h sp ep
     return (p, Just (n, OCreature cr))
 
-crHeight :: Creature -> Maybe Float
+crHeight :: Creature -> Float
 crHeight cr = case cr ^. crHP of
-    HP{} -> Just $ case cr ^. crType of
+    HP{} -> case cr ^. crType of
         HoverCrit {} -> 10
         ChaseCrit {} -> 25
         Avatar {} -> 25
-        _ -> error "Need to define crHeight for this crType"
-    CrIsCorpse{} -> Just 5
-    CrDestroyed{} -> Nothing
+        CrabCrit {} -> 25
+        SlinkCrit {} -> 25
+        SlimeCrit {_slimeSlime = r} -> min 25 $ 2 * slimeToRad r
+        BeeCrit {} -> 10
+        HiveCrit {} -> 25
+        BarrelCrit{} -> 20
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
+    CrIsCorpse{} -> 5
+    AvatarDestroyed{} -> 0
+
+crMid :: Creature -> Float
+crMid cr = case cr ^. crHP of
+    HP{} -> case cr ^. crType of
+        HoverCrit {} -> 2
+        ChaseCrit {} -> 20
+        Avatar {} -> 20
+        CrabCrit {} -> 20
+        SlinkCrit {} -> 20
+        SlimeCrit {_slimeSlime = r} -> max 3 . min 20 $ 2 * slimeToRad r - 5
+        BeeCrit {} -> 2
+        HiveCrit {} -> 20
+        BarrelCrit{} -> 20
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
+    CrIsCorpse{} -> 2
+    AvatarDestroyed{} -> 0
 
 wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
 wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])
@@ -253,7 +281,7 @@ circHitWall sp ep r w =
     xep = ep + x
 
 -- | note that this does not push the circle away from the wall at all
-collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
+collideCircWalls :: Foldable t => Point2 -> Point2 -> Float -> t Wall -> (Point2, Maybe Wall)
 {-# INLINE collideCircWalls #-}
 collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
   where
@@ -264,14 +292,11 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
             . _wlLine
             $ wl
     shiftbyrad (a, b) =
-        bimap
-            f
-            f
-            ( a +.+ rad *.* normalizeV (a -.- b)
-            , b +.+ rad *.* normalizeV (b -.- a)
+            ( f $ a + rad *^ normalizeV (a - b)
+            , f $ b + rad *^ normalizeV (b - a)
             )
       where
-        f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
+        f = (+ rad *^ normalizeV (vNormal $ a - b))
 
 overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
 {-# INLINE overlapCircWallsClosest #-}

src/Dodge/Base/You.hs

@@ -19,19 +19,19 @@ you w = w ^?! cWorld . lWorld . creatures . ix 0
 
 yourSelectedItem :: World -> Maybe Item
 yourSelectedItem w = do
-    i <- you w ^? crManipulation . manObject . imSelectedItem
-    j <- _crInv (you w) ^? ix i
+    Sel 0 i <- w ^? hud . diSelection . _Just
+    j <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix (NInt i)
     w ^? cWorld . lWorld . items . ix j
 
 yourRootItem :: World -> Maybe Item
 yourRootItem w = do
-    i <- you w ^? crManipulation . manObject . imRootSelectedItem
-    j <- _crInv (you w) ^? ix i
+    i <- w ^? hud . manObject . hiRootSelectedItem
+    j <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix i
     w ^? cWorld . lWorld . items . ix j
 
 yourRootItemDT :: World -> Maybe (DTree OItem)
 yourRootItemDT w = do
-    i <- you w ^? crManipulation . manObject . imRootSelectedItem . unNInt
+    i <- w^?hud. manObject . hiRootSelectedItem . unNInt
     invIMDT ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> you w ^. crInv) ^? ix i
 
 yourInv :: World -> NewIntMap InvInt Item

src/Dodge/Bullet.hs

@@ -108,26 +108,28 @@ updateBulVel bt = bt & buVel .*.*~ _buDrag bt
 --            return $ BezierTrajectory sp tpos (mouseWorldPos (w ^. input) (w ^. wCam))
 
 -- might want to restrict what/how bounces by material type
-bounceDir :: IM.IntMap Item -> (Point2, Either Creature Wall) -> Maybe Point2
-bounceDir _ (_, Right wl) = Just $ uncurry (-) (_wlLine wl)
-bounceDir m (p, Left cr) | crIsArmouredFrom m p cr 
+bounceDir :: World -> IM.IntMap Item -> (Point2, Either Creature Wall) -> Maybe Point2
+bounceDir _ _ (_, Right wl) = Just $ uncurry (-) (_wlLine wl)
+bounceDir w m (p, Left cr) | crIsArmouredFrom m p w cr 
     = Just $ vNormal $ p - (cr ^. crPos . _xy)
-bounceDir _ _ = Nothing
+bounceDir _ _ _ = Nothing
 
 useBulletPayload :: Bullet -> Point2 -> World -> World
 useBulletPayload bu = case _buPayload bu of
     BulPlain _ -> const id
     BulFlak -> makeFlak bu
     BulFrag -> makeFragBullets
-    BulGas -> (`makeGasCloud` V2 0 0)
-    BulBall ExplosiveBall -> makeMovingEB (_buVel bu) ExplosiveBall
+    BulGas -> (\p -> makeGasCloud o p (V2 0 0))
+    BulBall eb@ExplosiveBall{} -> makeMovingEB (_buVel bu) eb o
     BulBall ElectricalBall{} ->
         makeMovingEB
             (_buVel bu)
-            (ElectricalBall (round $ bu ^. buPos . _1))
-    BulBall FlashBall -> makeMovingEB (_buVel bu) FlashBall
-    BulBall (FlameletBall x) -> makeMovingEB (_buVel bu) (FlameletBall x)
-    BulBall IncendiaryBall -> makeMovingEB (_buVel bu) IncendiaryBall
+            (ElectricalBall (round $ bu ^. buPos . _1)) o
+    BulBall eb@FlashBall{} -> makeMovingEB (_buVel bu) eb o
+    BulBall eb@FlameletBall{} -> makeMovingEB (_buVel bu) eb o
+    BulBall eb@IncendiaryBall{} -> makeMovingEB (_buVel bu) eb o
+  where
+    o = bu ^. buOrigin
 
 makeFragBullets :: Point2 -> World -> World
 makeFragBullets p w = w & cWorld . lWorld . bullets .++~ bus
@@ -158,7 +160,7 @@ hitEffFromBul w bu = case _buEffect bu of
     PenetrateBullet -> movePenBullet bu hitstream w
     BounceBullet -> fromMaybe (expireAndDamage bu hitstream w) $ do
         (hp, crwl) <- hitstream ^? _head
-        dir <- bounceDir (w ^. cWorld . lWorld . items) (hp, crwl)
+        dir <- bounceDir w (w ^. cWorld . lWorld . items) (hp, crwl)
         return
             ( w
             , bu
@@ -168,12 +170,12 @@ 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
-    BulPlain x -> [Piercing x p v
-        ,Inertial 0 p v]
+    BulPlain x -> [Piercing x p v (bu ^. buOrigin)
+        ,Inertial 0 p v (bu ^. buOrigin)]
     _ -> []
   where
     v = _buVel bu

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,11 +11,8 @@ 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,
-    module Dodge.Creature.Volition,
     module Dodge.Creature.YourControl,
 ) where
 
@@ -34,15 +29,11 @@ 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
 import Dodge.Creature.Test
-import Dodge.Creature.Volition
 import Dodge.Creature.YourControl
 import Dodge.Data.Creature
 import Dodge.Default
@@ -98,7 +89,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

@@ -10,6 +10,10 @@ module Dodge.Creature.Action (
     youDropItem,
 ) where
 
+import qualified IntSetHelp as IS
+import Dodge.DisplayInventory
+import Dodge.Data.SelectionList
+import RandomHelp
 import Dodge.WorldEvent.ThingsHit
 import Control.Applicative
 import Control.Monad
@@ -38,78 +42,86 @@ import qualified Data.Set as S
 -- it is desirable to be able to determine when an action is finished,
 -- so that DoActionThen and the like are easy to define
 performActions :: Int -> World -> World
-performActions cid w =
-    foldl'
+performActions cid w = fromMaybe w $ do
+    a <- cr ^?crActionPlan.apAction
+    let (iss, mayas) = performAction cr w a
+    return $ foldl'
         (followImpulse cid)
         (w & cWorld . lWorld . creatures . ix cid . crActionPlan . apAction .~ mayas)
         iss
   where
     cr = w ^?! cWorld . lWorld . creatures . ix cid
-    (iss, mayas) = foldMap (performAction cr w) $ cr ^. crActionPlan . apAction
+--    (iss, mayas) = maybe ([],NoAction) (performAction cr w) (cr ^? crActionPlan . apAction)
 
-type ActionUpdate = ([Impulse], [Action])
+type ActionUpdate = ([Impulse], Action)
 
 {- | Performing an action on a frame creates an ActionUpdate:
   gives impulses and updates/deletes the action itself.
 -}
 performAction :: Creature -> World -> Action -> ActionUpdate
 performAction cr w ac = case ac of
+    Eat i x -> ([],Eat i x)
+--    Eat i x | x <= 0 -> ([],NoAction)
+--    Eat i x -> ([],Eat i (x-1))
     AimAt tcid p -> performAimAt cr w tcid p
-    WaitThen 0 newAc -> ([], [newAc])
-    WaitThen t newAc -> ([], [WaitThen (t -1) newAc])
-    ImpulsesList (xs : xss) -> (xs, [ImpulsesList xss])
-    ImpulsesList _ -> ([], mempty)
-    DoImpulses imps -> (imps, mempty)
-    DoActionThen fsta afta -> case performAction cr w fsta of -- NOTE this only does ONE continuation action
-        (imps, nxta : _) -> (imps, [DoActionThen nxta afta])
-        (imps, []) -> (imps, [afta])
-    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
+    WaitThen 0 newAc -> ([], newAc)
+    WaitThen t newAc -> ([], WaitThen (t -1) newAc)
+    ImpulsesList (xs : xss) a -> performAction cr w a & _1 <>~ xs
+        & _2 %~ ImpulsesList xss
+    ImpulsesList _ a -> performAction cr w a
+    DoImpulses imps -> (imps, NoAction)
+    DoActionThen fsta afta -> case performAction cr w fsta of
+        (imps, NoAction) -> (imps, afta)
+        (imps, nxta) -> (imps, DoActionThen nxta afta)
+--    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
     DoActionWhilePartial partAc f resetAc
         | doWdCrBl f w cr -> case performAction cr w partAc of
-            (imps, nxta : _) -> (imps, [DoActionWhilePartial nxta f resetAc])
-            (imps, []) -> (imps, [DoActionWhilePartial resetAc f resetAc])
+            (imps, NoAction) -> (imps, DoActionWhilePartial resetAc f resetAc)
+            (imps, nxta ) -> (imps, DoActionWhilePartial nxta f resetAc)
         | otherwise -> performAction cr w partAc
     DoActionIf f ifa
         | doWdCrBl f w cr -> performAction cr w ifa
-        | otherwise -> ([], mempty)
+        | otherwise -> ([], NoAction)
     DoActionIfElse ifa f elsea
         | doWdCrBl f w cr -> performAction cr w ifa
         | otherwise -> performAction cr w elsea
     DoActionWhileInterrupt repa f afta
-        | doWdCrBl f w cr -> (fst $ performAction cr w repa, [DoActionWhileInterrupt repa f afta])
+        | doWdCrBl f w cr -> (fst $ performAction cr w repa, DoActionWhileInterrupt repa f afta)
         | otherwise -> performAction cr w afta
-    DoActions [] -> ([], mempty)
-    DoActions acs ->
-        let (imps, newAcs) = foldMap (performAction cr w) acs
-         in (imps, newAcs)
-    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], mempty)
     PathTo p a -> performPathTo a cr w p
+    EvadeAim -> tryEvadeSideways cr w
     TurnToPoint p -> performTurnToA cr p
-    LeadTarget p -> fromMaybe ([], mempty) $ do
+    LeadTarget p -> fromMaybe ([], NoAction) $ do
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
-        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], mempty)
-    UseSelf f -> performAction cr w $ doCrAc f cr
-    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
-    DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
-        (imp, [nxtac]) -> (sideImp ++ imp, [DoImpulsesAlongside sideImp nxtac])
-        (imp, _) -> (sideImp ++ imp, mempty)
+        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], NoAction)
+    DoImpulsesAlongside sideImp mainAc -> performAction cr w mainAc & _1 <>~ sideImp
     DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
     DoReplicatePartial _ 0 pac -> performAction cr w pac
     DoReplicatePartial startac t partac -> case performAction cr w partac of
-        (imps, [nextac]) -> (imps, [DoReplicatePartial startac t nextac])
-        (imps, _) -> (imps, [DoReplicatePartial startac (t -1) startac])
-    NoAction -> ([], mempty)
+        (imps, NoAction) -> (imps, DoReplicatePartial startac (t -1) startac)
+        (imps, nextac) -> (imps, DoReplicatePartial startac t nextac)
+    NoAction -> ([], NoAction)
+
+tryEvadeSideways :: Creature -> World -> ActionUpdate
+tryEvadeSideways _ w = jumpleft -- (mv,mempty)
+  where
+    jumpleft = (mv,DoReplicate 5 (DoImpulses mv))
+    mv = [Walk (V2 0 d),UpdateRandGen]
+    d = evalState (takeOne [3,-3]) (w ^. randGen)
 
 performAimAt :: Creature -> World -> Int -> Point2 -> ActionUpdate
-performAimAt cr w tcid p = ([TurnToward tpos aimSp], [AimAt tcid tpos])
+performAimAt cr w tcid p = ([TurnToward tpos aimSp], AimAt tcid tpos)
   where
     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
@@ -121,76 +133,76 @@ crPathing cr = case cr ^. crStance . carriage of
 
 performPathTo :: Action -> Creature -> World -> Point2 -> ActionUpdate
 performPathTo a cr w p
-    | dist cpos p <= crRad (cr ^. crType) = mempty
+    | dist cpos p <= crRad (cr ^. crType) = (mempty,NoAction)
     | fst (crPathing cr) cpos p w = gotowards p
     | otherwise = case uncurry pointTowardsImpulse' (crPathing cr) cpos p w of
         Just q -> gotowards q
-        _ -> ([], [a])
+        _ -> ([], 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]
+    BeeMvType {} | cr ^?! crType . startStopMv == 0 -> [SetBeeRandomMovement, MvForward, MvTurnToward p]
+    BeeMvType {} -> [MvTurnToward p, MvForward]
 
 performTurnToA :: Creature -> Point2 -> ActionUpdate
 performTurnToA cr p
-    | angleVV cdirv dirv < 0.1 = mempty
-    | otherwise = ([MvTurnToward p, RandomTurn jit], [TurnToPoint p])
+    | angleVV cdirv dirv < 0.1 = (mempty,NoAction)
+    | otherwise = ([MvTurnToward p, RandomTurn jit], TurnToPoint p)
   where
     cpos = cr ^. crPos . _xy
     cdirv = unitVectorAtAngle (_crDir cr)
     dirv = p -.- cpos
     jit = _mvTurnJit $ crMvType cr
 
---setMinInvSize :: Int -> Creature -> World -> World
---setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity .~ n
-
---organiseInvKeys :: Int -> World -> World
---organiseInvKeys cid w =
---    w & cWorld . lWorld . creatures . ix cid
---        %~ ( (crInvSel . iselPos .~ newSelKey)
---                . (crInv .~ newInv)
---                . (crInvSel . iselAction .~ NoInvSelAction)
---           )
---  where
---    cr = w ^?! cWorld . lWorld . creatures . ix cid -- _creatures (_cWorld w) IM.! cid
---    pairs = IM.toList (_crInv cr)
---    newSelKey = fromMaybe 0 $ findIndex ((== crSel cr) . fst) pairs
---    newInv = IM.fromAscList $ zip [0 ..] $ map snd pairs
-
 -- why not a cid (Int)?
 dropItem :: Creature -> Int -> World -> World
-dropItem cr invid w' =
-    doanyitemdropeffect
+dropItem cr invid w =
+    itEffectOnDrop itm cr
+        . maybesetdropped
+        . (hud . diSections . ix 3 . ssSet %~ IS.map (+ 1))
+        . (hud . diSections . ix 0 . ssSet %~ IS.deleteShift invid)
         . maybeshiftseldown
         . copyItemToFloor (cr ^. crPos . _xy) itm -- . mayberemoveequip
         . rmInvItem (_crID cr) (NInt invid) -- it is important
         -- to do this before copying the item to the floor!
         . soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) whiteNoiseFadeOutS Nothing
-        $ w'
+        $ w
   where
-    --doanyitemdropeffect = fromMaybe id $ do
-    --    rmf <- itm ^? itEffect . ieOnDrop
-    --    return $ doInvEffect rmf itm cr
-    doanyitemdropeffect = itEffectOnDrop itm cr
     itm = fromMaybe (error "dropItem cannot find item") $ do
         itid <- cr ^? crInv . ix (NInt invid)
-        w' ^? cWorld . lWorld . items . ix itid
-    maybeshiftseldown w = fromMaybe w $ do
+        w ^? cWorld . lWorld . items . ix itid
+    t = fromMaybe True $ do
+        s <- w ^? hud . diCloseFilter . _Just
+        si <- w ^? hud . diSections . ix 0 . ssItems . ix invid
+        return $ plainRegex s si
+    maybesetdropped = fromMaybe id $ do
+        guard $ t && (invid `IS.member` (w ^?! hud . diSections . ix 0 . ssSet))
+        return $ hud . diSections . ix 3 . ssSet %~ IS.insert 0
+    maybeshiftseldown = fromMaybe id $ do
+        guard t
         3 <- w ^? hud . diSelection . _Just . slSec
-        return $ w & hud . diSelection . _Just . slInt +~ 1
+        return $ hud . diSelection . _Just . slInt +~ 1
 
 -- | Get your creature to drop the item under the cursor.
 youDropItem :: World -> World
 youDropItem w = fromMaybe w $ do
-    curpos <-
-        cr ^? crManipulation . manObject . imSelectedItem . unNInt
-            <|> fmap fst (IM.lookupMax (cr ^. crInv . unNIntMap))
+    curpos <- mi <|> fmap fst (IM.lookupMax (cr ^. crInv . unNIntMap))
     guard $ not $ w ^. cWorld . lWorld . lInvLock
     return $ case cr ^. crStance . posture of
         Aiming{} -> throwItem w
-        AtEase -> dropItem cr curpos w
+        AtEase -> setInvPosFromSS $ dropItem cr curpos w
   where
     cr = you w
+    mi = do
+        Sel 0 i <- w^?hud.diSelection._Just
+        return i
 
 -- placeholder, remember to deal with two handed weapon twist
 -- should throw all attached items?

src/Dodge/Creature/Action/Blink.hs

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

src/Dodge/Creature/ArmourChase.hs

@@ -20,12 +20,12 @@ flockArmourChaseCrit =
 --            IM.fromList
 --                [ --(0, frontArmour)
 --                ]
-        , _crActionPlan =
-            ActionPlan
-                { _apAction = []
-                , _apStrategy = FollowImpulses
-                , _apGoal = [Kill 0]
-                }
+--        , _crActionPlan =
+--            ActionPlan
+--                { _apAction = NoAction
+----                , _apStrategy = FollowImpulses
+--                , _apGoal = Kill 0
+--                }
         , _crGroup = ShieldGroup
 --        , _crMvType = defaultChaseMvType
         }

src/Dodge/Creature/ChaseCrit.hs

@@ -1,11 +1,18 @@
 module Dodge.Creature.ChaseCrit (
     smallChaseCrit,
     invisibleChaseCrit,
+    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
 import Dodge.Default
@@ -31,6 +38,47 @@ chaseCrit =
         & crName .~ "chaseCrit"
         & crHP .~ HP 150
         & crFaction .~ ColorFaction green
+        & crActionPlan . apGoal .~ SearchForFood
+        & crActionPlan . apStrategy .~ Search
+
+crabCrit :: Creature
+crabCrit = defaultCreature
+        & crName .~ "chaseCrit"
+        & crHP .~ HP 350
+        & crType .~ CrabCrit
+            { _meleeCooldownL = 0
+            , _meleeCooldownR = 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 (slimeToRad r) 0) False 0
+        & crType .~ SlimeCrit r 0 NoSlimeDistortion 1 False 0
+        & crFaction .~ ColorFaction (light green)
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+        & crActionPlan .~ SlimeIntelligence
+        & crStance . carriage .~ Crawling
+  where
+    r = 250000
 
 hoverCrit :: Creature
 hoverCrit =
@@ -39,4 +87,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 0 Nothing 1
+        & crFaction .~ ColorFaction yellow
+        & crStance . carriage .~ Flying 15
+
+hiveCrit :: Creature
+hiveCrit =
+    defaultCreature
+        & crName .~ "hiveCrit"
+        & crHP .~ HP 100000
+        & crType .~ HiveCrit mempty 0 400
+        & crStance . carriage .~ Rooted
+        & crFaction .~ ColorFaction yellow

src/Dodge/Creature/Damage.hs

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

src/Dodge/Creature/HandPos.hs

@@ -16,32 +16,32 @@ module Dodge.Creature.HandPos (
     strideLength,
 ) where
 
+import Dodge.Data.World
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
 import Linear
 import Control.Lens
 import Dodge.Creature.Test
-import Dodge.Data.Creature
 import Dodge.Data.Equipment.Misc
 import Geometry
 import qualified Quaternion as Q
 import ShapePicture
 
-translateToES :: Creature -> EquipSite -> Point3 -> Point3
-translateToES cr es p = fst (equipSitePQ es cr `Q.comp` (p, Q.qid))
+translateToES :: World -> Creature -> EquipSite -> Point3 -> Point3
+translateToES w cr es p = fst (equipSitePQ es w cr `Q.comp` (p, Q.qid))
 
-equipSitePQ :: EquipSite -> Creature -> Point3Q
+equipSitePQ :: EquipSite -> World -> Creature -> Point3Q
 equipSitePQ = \case
     OnLeftWrist -> leftWristPQ
     OnRightWrist -> rightWristPQ
-    OnHead -> headPQ
-    OnChest -> chestPQ
-    OnBack -> backPQ
-    OnLeftLeg -> legPQ LeftForward
-    OnRightLeg -> legPQ RightForward
+    OnHead ->  headPQ
+    OnChest ->  chestPQ
+    OnBack ->  backPQ
+    OnLeftLeg -> const $ legPQ LeftForward
+    OnRightLeg -> const $ legPQ RightForward
 
-translatePointToRightHand :: Creature -> Point3 -> Point3
-translatePointToRightHand cr p = fst (rightHandPQ cr `Q.comp` (p, Q.qid))
+translatePointToRightHand :: World -> Creature -> Point3 -> Point3
+translatePointToRightHand w cr p = fst (rightHandPQ w cr `Q.comp` (p, Q.qid))
 
 strideLength :: Creature -> Float
 strideLength cr = case cr ^. crType of
@@ -61,14 +61,14 @@ handWalkingPos b off cr = case (cr ^? crType . strideAmount,cr ^? crType . footF
 zeroOneSmooth :: Float -> Float
 zeroOneSmooth x = (1 - cos (pi * x)) / 2
 
-rightHandPQ :: Creature -> Point3Q
-rightHandPQ cr
-    | oneH cr = (V3 11 (-3) 20, Q.qid)
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0, Q.qz 1)
-    | twoFlat cr = (V3 8 (-8) 12, Q.qid)
-    | Just TwoHandTwist <- cr ^? crManipulation . manObject . imAimStance
+rightHandPQ :: World -> Creature -> Point3Q
+rightHandPQ w cr
+    | oneH w cr = (V3 11 (-3) 20, Q.qid)
+    | twists w cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0, Q.qz 1)
+    | twoFlat w cr = (V3 8 (-8) 12, Q.qid)
+    | Just TwoHandTwist <- w ^? hud . manObject . hiAimStance
         = (V3 6 (-6) 10, Q.qid)
-    | Just TwoHandFlat <- cr ^? crManipulation . manObject . imAimStance
+    | Just TwoHandFlat <- w ^? hud . manObject . hiAimStance
         = (V3 (8 - twoHandOffY cr) (-8) 12, Q.qid)
     | Just p <- crRightHandWall cr = (20 & _xy .~ p, Q.qid)
     | otherwise = (handWalkingPos LeftForward (-8) cr, Q.qid)
@@ -109,22 +109,22 @@ crLeftHandWall cr = do
     cd = cr ^. crDir
     rot = rotateV (negate cd)
 
-translateToRightHand :: Creature -> SPic -> SPic
-translateToRightHand = overPosSP . translatePointToRightHand
+translateToRightHand :: World -> Creature -> SPic -> SPic
+translateToRightHand w = overPosSP . translatePointToRightHand w
 
-rightWristPQ :: Creature -> Point3Q
-rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
+rightWristPQ :: World -> Creature -> Point3Q
+rightWristPQ w cr = rightHandPQ w cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
 
-leftHandPQ :: Creature -> Point3Q
-leftHandPQ cr
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
-    | twoFlat cr = (V3 8 8 12, Q.qid)
-    | Just TwoHandTwist <- cr ^? crManipulation . manObject . imAimStance
+leftHandPQ :: World -> Creature -> Point3Q
+leftHandPQ w cr
+    | twists w cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
+    | twoFlat w cr = (V3 8 8 12, Q.qid)
+    | Just TwoHandTwist <- w ^? hud . manObject . hiAimStance
         = (V3 (10 + twoHandOffY cr) 6 20, Q.qid)
-    | Just TwoHandFlat <- cr ^? crManipulation . manObject . imAimStance
+    | Just TwoHandFlat <- w ^? hud . manObject . hiAimStance
         = (V3 (8 + twoHandOffY cr) 6 12, Q.qid)
     | Just p <- crLeftHandWall cr = (20 & _xy .~ p, Q.qid)
-    | oneH cr = (V3 0 8 10, Q.qz 0.4)
+    | oneH w cr = (V3 0 8 10, Q.qz 0.4)
     | otherwise = (handWalkingPos RightForward 8 cr, Q.qid)
 
 twoHandOffY :: Creature -> Float
@@ -137,14 +137,14 @@ twoHandOffY cr = zeroOneSmooth $ case (cr ^? crType . strideAmount,cr ^? crType
          in f sa
     _ -> 0
 
-translatePointToLeftHand :: Creature -> Point3 -> Point3
-translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p, Q.qid))
+translatePointToLeftHand :: World -> Creature -> Point3 -> Point3
+translatePointToLeftHand w cr p = fst (leftHandPQ w cr `Q.comp` (p, Q.qid))
 
-translateToLeftHand :: Creature -> SPic -> SPic
-translateToLeftHand = overPosSP . translatePointToLeftHand
+translateToLeftHand :: World -> Creature -> SPic -> SPic
+translateToLeftHand w = overPosSP . translatePointToLeftHand w
 
-leftWristPQ :: Creature -> Point3Q
-leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qid)
+leftWristPQ :: World -> Creature -> Point3Q
+leftWristPQ w cr = leftHandPQ w cr `Q.comp` (V3 0 4 (-4), Q.qid)
 
 translateToLeftLeg :: Creature -> SPic -> SPic
 translateToLeftLeg cr = overPosSP (\p -> fst (legPQ LeftForward cr `Q.comp` (p, Q.qid)))
@@ -171,17 +171,17 @@ legPQ' g cr =
 translateToRightLeg :: Creature -> SPic -> SPic
 translateToRightLeg cr = overPosSP (\p -> fst (legPQ RightForward cr `Q.comp` (p, Q.qid)))
 
-headPQ :: Creature -> Point3Q
-headPQ cr
-    | twists cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
-    | oneH cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
+headPQ :: World -> Creature -> Point3Q
+headPQ w cr
+    | twists w cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
+    | oneH w cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
     | otherwise = (V3 2.5 0 20, Q.qid)
 
-chestPQ :: Creature -> Point3Q
-chestPQ cr = backPQ cr `Q.comp` (0, Q.qz pi)
+chestPQ :: World -> Creature -> Point3Q
+chestPQ w cr = backPQ w cr `Q.comp` (0, Q.qz pi)
 
-backPQ :: Creature -> Point3Q
-backPQ cr
-    | oneH cr = (V3 0 0 10, Q.qz 0.5)
-    | twists cr = (V3 0 3 10, Q.qz (-1.5))
+backPQ :: World -> Creature -> Point3Q
+backPQ w cr
+    | oneH w cr = (V3 0 0 10, Q.qz 0.5)
+    | twists w cr = (V3 0 3 10, Q.qz (-1.5))
     | otherwise = (V3 0 0 10, Q.qz 0)

src/Dodge/Creature/Impulse.hs

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

src/Dodge/Creature/Impulse/Movement.hs

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

src/Dodge/Creature/Impulse/UseItem.hs

@@ -2,6 +2,7 @@
 
 module Dodge.Creature.Impulse.UseItem (useItem) where
 
+import qualified Data.IntSet as IS
 import Dodge.Euse
 import NewInt
 import Control.Lens
@@ -14,7 +15,9 @@ import Dodge.HeldUse
 import Dodge.Inventory
 import Dodge.Item.Grammar
 import Dodge.Item.Location
---import qualified IntMapHelp as IM
+
+--note :: a -> Maybe b -> Either a b
+--note x = maybe (Left x) Right
 
 useItem :: Int -> Int -> World -> Maybe World
 useItem invid pt w = fmap (worldEventFlags . at InventoryChange ?~ ()) $ do
@@ -26,7 +29,10 @@ useItem invid pt w = fmap (worldEventFlags . at InventoryChange ?~ ()) $ do
 useItemLoc :: Creature -> LocationDT OItem -> Int -> World -> Maybe World
 useItemLoc cr loc pt w
     | aimuse
-      , fromMaybe False $ loc ^? locDT . dtValue . _1 . itLocation . ilIsAttached
+      , fromMaybe False $ do
+            i <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
+            is <- w ^? hud . manObject . hiAttachedItems
+            return $ i `IS.member` is
       , Aiming{} <- cr ^. crStance . posture =
         return $ gadgetEffect pt loc cr w
     | GadgetPlatformSF <- sf =

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

@@ -5,9 +5,14 @@ import Dodge.Data.Creature.Misc
 crMass :: CreatureType -> Float
 crMass = \case
     Avatar {} -> 10
-    ChaseCrit {} -> 12
+    ChaseCrit {} -> 10
+    CrabCrit {} -> 10
     HoverCrit {} -> 5
     SwarmCrit -> 2
     AutoCrit -> 10
     BarrelCrit{} -> 10
+    SlinkCrit{} -> 100
     LampCrit {} -> 3
+    SlimeCrit {_slimeSlime = r} -> fromIntegral r / 1000
+    BeeCrit {_beeSlime = x} -> 3 + fromIntegral x / 100
+    HiveCrit {} -> 100

src/Dodge/Creature/Material.hs

@@ -9,8 +9,13 @@ crMaterial :: CreatureType -> Material
 crMaterial = \case
     Avatar{_avatarMaterial = mt} -> mt
     ChaseCrit {} -> Flesh
+    CrabCrit {} -> Flesh
     HoverCrit {} -> Metal
     SwarmCrit -> Flesh
     AutoCrit -> Flesh
+    SlinkCrit{} -> Flesh
     BarrelCrit{} -> Metal
     LampCrit{} -> Glass
+    SlimeCrit{} -> Flesh
+    BeeCrit{} -> Flesh
+    HiveCrit{} -> Flesh

src/Dodge/Creature/MaxHP.hs

@@ -7,9 +7,13 @@ crMaxHP :: CreatureType -> Int
 crMaxHP = \case
     Avatar {} -> 15000
     ChaseCrit {} -> 150
+    CrabCrit {} -> 350
     HoverCrit {} -> 100
     SwarmCrit -> 50
     AutoCrit -> 100
     BarrelCrit{} -> 100
     LampCrit {} -> 50
-
+    SlinkCrit {} -> 1000
+    SlimeCrit {} -> 1000
+    BeeCrit {} -> 100
+    HiveCrit {} -> 10000

src/Dodge/Creature/MoveType.hs

@@ -7,28 +7,35 @@ import Control.Lens
 crMvType :: Creature -> CrMvType
 crMvType cr = case _crType cr of
     Avatar {} -> MvWalking 1.5
-    ChaseCrit {} -> defaultChaseMvType
-    HoverCrit {} -> defaultChaseMvType & mvSpeed .~ 0.15
+    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 {} -> BeeMvType 0.2 0.1 15
+    --BeeCrit {} -> BeeMvType 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/Perception.hs

@@ -21,12 +21,8 @@ import Linear
 import RandomHelp
 import Sound.Data
 
-perceptionUpdate ::
-    -- | List of creature ids that may direct attention and awareness
-    [Int] ->
-    World ->
-    Creature ->
-    Creature
+-- | The [Int] is a list of creature ids that may direct attention and awareness
+perceptionUpdate :: [Int] -> World -> Creature -> Creature
 perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate w . basicAttentionUpdate is w
 
 {- | Update a creatures awareness based upon the creatures' current direction
@@ -55,9 +51,9 @@ basicAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
             return $
                 (crActionPlan . apStrategy .~ WarningCry) . 
                 (crActionPlan . apAction
-                    .~ [ImpulsesList (crImpulsesOnCognizant w cr)
-                        , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy)
-                        ])
+                    .~ ImpulsesList (crImpulsesOnCognizant w cr)
+                        (AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy))
+                )
 
 crImpulsesOnCognizant :: World -> Creature -> [[Impulse]]
 crImpulsesOnCognizant w cr = case cr ^. crType of
@@ -65,6 +61,7 @@ crImpulsesOnCognizant w cr = case cr ^. crType of
         <> [[ChangeStrategy $ CloseToMelee 0]]
     HoverCrit {} | Just sid <- cognizantVoc w cr -> [Bark sid]:
           [[ChangeStrategy $ CloseToMelee 0]]
+    CrabCrit {} -> [[ChangeStrategy $ CloseToMelee 0]]
     _ | Just sid <- cognizantVoc w cr -> [Bark sid]: replicate 5 [RandomImpulse $ RandImpulseCircMove 1]
     _ -> replicate 5 [RandomImpulse $ RandImpulseCircMove 3]
 
@@ -135,14 +132,10 @@ decreaseAwareness (Cognizant 0) = Just $ Suspicious 1000
 decreaseAwareness (Cognizant x) = Just $ Cognizant $ x - 50
 
 {- | Given a fixed group of creatures, direct attention to those of them that
- - are in view.
+are in view.
+The ints are ids of creatures that may attract this creature's attention
 -}
-basicAttentionUpdate ::
-    -- | Creatures that may attract this creature's attention
-    [Int] ->
-    World ->
-    Creature ->
-    Creature
+basicAttentionUpdate :: [Int] -> World -> Creature -> Creature
 basicAttentionUpdate cids w cr =
     cr & crPerception . cpAttention
         .~ AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids)

src/Dodge/Creature/Picture.hs

@@ -3,145 +3,430 @@ Drawing of creatures.
 Takes into account damage etc.
 -}
 module Dodge.Creature.Picture (
-    basicCrPict,
-    deadScalp,
-    deadUpperBody,
-    deadFeet,
-    drawChaseCrit,
-    drawHoverCrit,
+    makeCorpse,
+    drawCreature,
 ) where
 
-import Dodge.Base.Collide
-import Control.Monad
-import Data.Maybe
-import Dodge.Data.World
-import Linear
-import Dodge.Data.Equipment.Misc
-import Dodge.Creature.HandPos
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
+import Control.Monad
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.Strict.Tuple as ST
+import Dodge.Base.Collide
+import Dodge.Creature.HandPos
 import Dodge.Creature.Radius
 import Dodge.Creature.Shape
---import Dodge.Creature.Test
+import Dodge.Creature.Slime
 import Dodge.Damage
---import Dodge.Data.Creature
+import Dodge.Data.Equipment.Misc
+import Dodge.Data.World
 import Dodge.Item.Draw
 import Dodge.Item.Grammar
 import Geometry
+import Geometry.Zone
+import Linear
 import Picture
 import qualified Quaternion as Q
+import RandomHelp
 import Shape
---import Shape
 import ShapePicture
 
-basicCrPict :: IM.IntMap Item -> Creature -> SPic
-basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
+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 w m cr
+        SwarmCrit -> basicCrPict w m cr
+        AutoCrit -> basicCrPict w 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
 
-crCamouflage :: Creature -> CamouflageStatus
-crCamouflage _ = FullyVisible
+drawSlimeCrit :: Creature -> Shape
+drawSlimeCrit cr =
+    colorSH green $
+        upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) ps
+  where
+    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
+    so = slimeOutline cr
+    ps = fromMaybe so $ do
+        SlimeDistortion x' qs _ <- cr ^? crType . slimeDistortion
+        let x = fromIntegral x'
+        guard $ length qs == 12
+        return $ zipWith (+) (fmap (0.1 * (10 - x) *^) so) (fmap (0.1 * x *^) qs)
 
-basicCrShape :: Creature -> Shape
-basicCrShape cr
-    | crCamouflage cr == Invisible = mempty
-    | otherwise =
-        scaleSH (V3 crsize crsize crsize) $
-            mconcat
-                [ colorSH (_skinHead cskin) . overPosSH (translateToES cr OnHead) $ scalp
-                , colorSH (_skinUpper cskin) $ upperBody cr
-                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-                ]
+basicCrPict :: World -> IM.IntMap Item -> Creature -> SPic
+basicCrPict w m cr = drawEquipment w m cr <> noPic (basicCrShape w cr)
+
+basicCrShape :: World -> Creature -> Shape
+basicCrShape w cr =
+    scaleSH (V3 crsize crsize crsize) $
+        mconcat
+            [ colorSH (_skinHead cskin) . overPosSH (translateToES w cr OnHead) $ scalp
+            , colorSH (_skinUpper cskin) $ upperBody w cr
+            , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+            ]
   where
     cskin = crShape $ _crType cr
     crsize = 0.1 * crRad (cr ^. crType)
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
+drawSlinkCrit :: Creature -> Shape
+drawSlinkCrit cr =
+    snd (foldl' f ((V3 0 0 0, Q.qid), mempty) $ cr ^?! crType . slinkSpine)
+        <> 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)
-    <> colorSH (_skinUpper cskin)
-    (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0,pi/2,pi,1.5*pi]])
+drawHoverCrit cr =
+    colorSH
+        (_skinHead cskin)
+        (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
+        <> colorSH
+            (_skinUpper cskin)
+            (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0, pi / 2, pi, 1.5 * pi]])
   where
     cskin = crShape $ _crType cr
     f a = tpq `Q.comp` (1 & _xy .~ rotateV a 5, Q.qid)
     tpq = (V3 0 0 0, Q.qid)
 
+drawHive :: SPic
+drawHive = noPic $ upperPrismPolyHalfMI 25 $ polyCirc 6 20
+
+drawBeeCrit :: Creature -> Shape
+drawBeeCrit cr =
+    colorSH
+        col
+        (f . upperPrismPolyHalfMI 3 $ polyCirc 6 r)
+        <> colorSH (dark col) (overPosSH (Q.apply beakpos) $ upperPrismPolyHalfST 1 [V2 0 (-2), V2 4 0, V2 0 2])
+  where
+    r = cr ^. crType . to crRad
+    beakpos = (V3 (r - 1) 0 0, Q.qid)
+    col | cr ^?! crType . beeAggro > 0 = red
+        | otherwise = yellow
+    f   | Mounted{} <- cr ^. crStance . carriage =
+            each.sfVs.each._y *~ g (modTo 1 $ cr ^?! crType . beeSlime . to ((/ 100) . fromIntegral))
+        | otherwise = id
+    g x | x > 0.5 = 2 - x
+        | otherwise = 1 + x
+
+drawCrabCrit :: World -> Creature -> Shape
+drawCrabCrit w cr =
+    mconcat
+        [ crabUpperBody w cr
+        , colorSH (_skinLower cskin) $ crabFeet w cr
+        ]
+  where
+    cskin = crShape $ _crType cr
+
 drawChaseCrit :: World -> Creature -> Shape
-drawChaseCrit w cr = mconcat 
-    [ chaseUpperBody w cr
-    , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-    ]
+drawChaseCrit w cr =
+    mconcat
+        [ chaseUpperBody w cr
+        , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+        ]
   where
     cskin = crShape $ _crType cr
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
-chaseUpperBody :: World -> Creature -> Shape
-chaseUpperBody w cr =  colorSH (_skinUpper cskin)
-    (overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI tz $ polyCirc 3 12 
-        & each %~ vNormal
-        & each . _y *~ 0.6) 
-    <> overPosSH (Q.apply neckq) (upperPrismPolyHalfMI 3 $ (+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
-    )
-    <> colorSH (_skinHead cskin)
-        (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+crabUpperBody :: World -> Creature -> Shape
+crabUpperBody _ cr =
+    colorSH
+        (_skinUpper cskin)
+        ( 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
---    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
+    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
+chaseUpperBody w cr =
+--    colorSH
+--        (_skinUpper cskin)
+        ( overPosSH
+            (Q.apply torsoq)
+            ( upperPrismPolyHalfMI tz $
+                polyCirc 3 12
+                    & each %~ vNormal
+                    & each . _y *~ 0.6
+            )
+           <> overPosSH (Q.apply neckq) lneckshape
+        <> overPosSH (Q.apply neckq2) uneckshape
+        )
+        <> colorSH
+--            (_skinHead cskin)
+            yellow headshape
+  where
+    --    time = fromIntegral (mod (w ^. unpauseClock) 100) / 5
     tz = 4
     cskin = crShape $ _crType cr
-    torsoq = (V3 0 0 (10 + tz + tbob),Q.qid)
+    torsoq = (V3 0 0 (10 + tz + tbob), Q.qy (-cr ^?! crType . chaseqy0))
     mcool = 1 - min 10 (fromIntegral . _meleeCooldown $ _crType cr) / 10
-    neckq = torsoq `Q.comp` (V3 6 0 0, Q.qz aimrot * Q.axisAngle (V3 0 1 0) (-1.8*mcool))
-    headq = neckq `Q.comp` (V3 16 0 0, Q.axisAngle (V3 0 1 0) (2*mcool+vocaltilt) * Q.qz aimrot )
+--    (qy1,qy2,qy3)  
+----        | CloseToMelee i <- cr ^?!crActionPlan.apStrategy
+----            = (0,0,0)
+--        | otherwise = (pi/3,-2*pi/3,pi/3)
+--        | otherwise = (pi * w^.cWorld.cClock.to ((*0.01).fromIntegral),0,0)
+--        | otherwise = (-1.8 * mcool , 0, 2 * mcool + vocaltilt)
+    qy1 = cr ^?! crType . chaseqy1
+    qy2 = cr ^?! crType . chaseqy2
+    qy3 = cr ^?! crType . chaseqy3
+    lneckshape = colorSH red $ upperPrismPolyHalfMI 4 (vNormal <$> trapTBH 2 5 (nlen/4))
+        & each . sfVs . each +~ V3 (nlen/4) 0 (-2)
+    uneckshape = colorSH green $ upperPrismPolyHalfMI 3 (vNormal <$> trapTBH 3 2 (nlen/4))
+        & each . sfVs . each +~ V3 (nlen/4) 0 (-1.5)
+    headshape = overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4])
+    neckq = torsoq `Q.comp` (V3 8 0 4, Q.qz aimrot * Q.qy (pi + qy1))
+    neckq2 = neckq `Q.comp` (V3 (nlen/2) 0 0, Q.qy qy2)
+    headq = neckq2 `Q.comp` (V3 (nlen/2) 0 0, Q.qy (pi + qy3) * Q.qz aimrot)
+    nlen = 16
     vocaltilt = case cr ^? crVocalization . vcTime of
         Just x | x < 20 -> -pi * 0.05 * (10 - abs (fromIntegral x - 10))
         _ -> 0
     sLen = strideLength cr
     tbob = 5 * (1 - oneSmooth (abs llegpos))
-    llegpos = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    llegpos = case (cr ^? crType . strideAmount, cr ^? crType . footForward) of
         (Just sa, Just LeftForward) -> f sa
         (Just sa, Just RightForward) -> -f sa
         _ -> 0
-    --tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
-    f i = (sLen - 2*i) / sLen
+    -- tbob = 2 * oneSmooth ((sLen - 2*i) / sLen)
+    f i = (sLen - 2 * i) / sLen
     cxy = cr ^. crPos . _xy
     aimrot = fromMaybe pi $ do
         i <- cr ^. crIntention . targetCr
         tcxy <- w ^? cWorld . lWorld . creatures . ix i . crPos . _xy
         guard $ hasLOSIndirect cxy tcxy w
-        return . (0.5*) . nearZeroAngle $  argV (tcxy - cxy) - cr ^. crDir
+        return . (0.5 *) . nearZeroAngle $ argV (tcxy - cxy) - cr ^. crDir
+
+{- NECK ARTICULATION   
+Viewed from side, all hinges, torso/lower neck also hinges in Q.qz (not shown)
+    na1 na2 na3    <- angles, in diagram all == 0, in Q.qy
+     |   |   |
+  ---.---.---.---       z
+   |   |   |   |        ^>x                           
+ torso | u.neck|                                   
+     l.neck   head                  
+Rough examples
+Flat aim:           Resting:
+                        .\\
+                        \  \\
+      .                  .
+     / \                /
+ ---.   .---        ---.
+a1 = 60             a1 = 60
+a2 = -120           a2 = 60
+a3 = 60             a3 = -160
+-}
+
+--ikTwoArms :: Point3 -> Point3 -> Point3 -> Point3 -> (QFloat,QFloat)
+--ikTwoArms 
 
 oneSmooth :: Float -> Float
 oneSmooth x = sin (pi * x * 0.5)
 
 feet :: Creature -> Shape
 {-# INLINE feet #-}
-feet cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
-    (Just sa,Just LeftForward) -> sh (f sa)
-    (Just sa,Just RightForward) -> sh (-f sa)
+feet cr = case (cr ^? crType . strideAmount, cr ^? crType . footForward) of
+    (Just sa, Just LeftForward) -> sh (f sa)
+    (Just sa, Just RightForward) -> sh (-f sa)
     _ -> sh 0
   where
-    sh x = translateSHxy x off aFoot <> translateSHxy (- x) (- off) aFoot
+    sh x = translateSHxy x off aFoot <> translateSHxy (-x) (-off) aFoot
     aFoot = upperPrismPolyST 10 $ polyCirc 3 4
     off = 5
     sLen = strideLength cr
---    f i = 8 * (sLen - 2*i) / sLen
-    f i = 8 * oneSmooth ((sLen - 2*i) / sLen)
+    --    f i = 8 * (sLen - 2*i) / sLen
+    f i = 8 * oneSmooth ((sLen - 2 * i) / sLen)
+
+crabFeet :: World -> Creature -> Shape
+{-# INLINE crabFeet #-}
+crabFeet _ cr =
+    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 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
+    rpos = rot (cr ^?! crType . rFootPos - cxy)
+    rot = rotateV cdir
+    lpos = rot (cr ^?! crType . lFootPos - cxy)
+    f p q = q + 2 *^ (p - q)
+    cdir = -cr ^. crDir
+    cxy = cr ^. crPos . _xy
+    afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2
+    (r1, r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5)
+    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)
+  where
+    -- spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+
+    a = angleThreeSides 10 (distance p q) 10
+    b = angleVV3 (q - p) (V3 0 0 (-1))
+    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 :: World -> StdGen -> Creature -> SPic
+makeCorpse w 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 w 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 #-}
 deadFeet = feet
 
-arms :: Creature -> Shape
+arms :: World -> Creature -> Shape
 {-# INLINE arms #-}
-arms cr =
+arms w cr =
     (^. _1) $
-        translateToRightHand cr aHand
-            <> translateToLeftHand cr aHand
+        translateToRightHand w cr aHand
+            <> translateToLeftHand w cr aHand
   where
     aHand = noPic $ translateSHz (-2) . upperPrismPolyHalfST 2 $ polyCirc 3 4
 
 deadScalp :: Creature -> Shape
---deadScalp cr = deadRot cr . translateSHz 5 . scalp $ cr
---deadScalp cr = deadRot cr . translateSHz (-5) . scalp $ cr
+-- deadScalp cr = deadRot cr . translateSHz 5 . scalp $ cr
+-- deadScalp cr = deadRot cr . translateSHz (-5) . scalp $ cr
 deadScalp _ = translateSH (V3 (-13) 0 0) scalp
 
 deadRot :: Creature -> Shape -> Shape
@@ -155,28 +440,39 @@ deadRot cr = overPosSH (Q.rotateToZ d)
 
 scalp :: Shape
 {-# INLINE scalp #-}
-scalp = (colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5)
+scalp =
+    (colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5)
         & each . sfShadowImportance .~ Unimportant
 
-torso :: Creature -> Shape
+torso :: World -> Creature -> Shape
 {-# INLINE torso #-}
-torso cr = overPosSH (translateToES cr OnBack) tsh
+torso w cr = overPosSH (translateToES w cr OnBack) tsh
   where
     tsh = ashoulder 3 (-0.2) <> ashoulder (-3) 0.2
     ashoulder y a = translateSHxy 0 y . rotateSH a $ scaleSH (V3 10 10 1) baseShoulder
 
-deadUpperBody :: Creature -> Shape
-deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
+deadUpperBody :: World -> Creature -> Shape
+deadUpperBody w cr = deadRot cr . translateSHz (negate 10) . upperBody w $ cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
---baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
+-- baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 baseShoulder = scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 
-upperBody :: Creature -> Shape
+upperBody :: World -> Creature -> Shape
 {-# INLINE upperBody #-}
-upperBody cr = arms cr <> torso cr
+upperBody w cr = arms w cr <> torso w cr
 
-drawEquipment :: IM.IntMap Item -> Creature -> SPic
+drawEquipment :: World -> IM.IntMap Item -> Creature -> SPic
 {-# INLINE drawEquipment #-}
-drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
+drawEquipment w m cr = foldMap (itemEquipPict w 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

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

src/Dodge/Creature/ReaderUpdate.hs

@@ -1,6 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
 module Dodge.Creature.ReaderUpdate (
-    doStrategyActions,
-    setTargetMv,
     targetYouWhenCognizant,
     overrideMeleeCloseTarget,
     watchUpdateStrat,
@@ -9,11 +8,13 @@ module Dodge.Creature.ReaderUpdate (
 --    goToTarget,
     flockACC,
     chaseCritMv,
-    setMvPos,
+    crabActionUpdate,
+    setMvPosToTargetCr,
     setViewPos,
     hoverCritMv,
 ) where
 
+import Dodge.WorldEvent.ThingsHit
 import Control.Applicative
 import Control.Monad
 import Data.Bifunctor
@@ -23,7 +24,7 @@ import Dodge.Base
 import Dodge.Creature.Perception
 import Dodge.Creature.Radius
 import Dodge.Creature.Vocalization
-import Dodge.Data.CreatureEffect
+--import Dodge.Data.CreatureEffect
 import Dodge.Data.World
 import Dodge.Zoning.Creature
 import FoldableHelp
@@ -43,21 +44,20 @@ tryMeleeAttack cr tcr
     | _meleeCooldown (_crType cr) == 0
         && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
         && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
-        && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 =
+        && abs (_crDir cr - argV (tpos - cpos)) < pi / 4 =
         cr & crActionPlan . apAction
-                .~ [ DoImpulses [Melee $ _crID tcr] `DoActionThen`
+                .~ DoImpulses [Melee $ _crID tcr] `DoActionThen`
                         DoReplicate 10 NoAction
-                        `DoActionThen` DoImpulses
-                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
-                   ]
-            & crActionPlan . apStrategy .~ MeleeStrike
+--                        `DoActionThen` DoImpulses
+--                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
+--            & crActionPlan . apStrategy .~ MeleeStrike
     | otherwise = cr
   where
     cpos = cr ^. crPos . _xy
     tpos = tcr ^. crPos . _xy
 
-setMvPos :: World -> Creature -> Creature
-setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
+setMvPosToTargetCr :: World -> Creature -> Creature
+setMvPosToTargetCr w cr = cr & crIntention . mvToPoint .~ mpos
   where
     int = _crIntention cr
     mtpos = do
@@ -81,17 +81,17 @@ attentionViewPoint w cr = do
     guard $ visionCheck cr (tcr ^. crPos . _xy) > 0
     tcr ^? crPos . _xy
 
-setTargetMv ::
-    -- | Function for determining target
-    (World -> Creature -> Maybe Creature) ->
-    World ->
-    Creature ->
-    Creature
-setTargetMv targFunc w cr =
-    maybe
-        cr
-        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
-        (targFunc w cr)
+--setTargetMv ::
+--    -- | Function for determining target
+--    (World -> Creature -> Maybe Creature) ->
+--    World ->
+--    Creature ->
+--    Creature
+--setTargetMv targFunc w cr =
+--    maybe
+--        cr
+--        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
+--        (targFunc w cr)
 
 -- ugly
 flockACC :: World -> Creature -> Creature
@@ -120,48 +120,130 @@ flockACC w cr = fromMaybe cr $ do
                             else negate r *.* horDir
                  in cr & crIntention . mvToPoint ?~ tpos +.+ horShift
 
+crabActionUpdate :: Int -> World -> World
+crabActionUpdate cid w = case _apStrategy (_crActionPlan cr) of
+    _ | Just tid <- meleel -> w & tocr . crActionPlan . apAction 
+                .~ DoImpulses [MeleeL tid] `DoActionThen`
+                        DoReplicate 10 NoAction
+    _ | Just tid <- meleer -> w & tocr . crActionPlan . apAction 
+                .~ DoImpulses [MeleeR tid] `DoActionThen`
+                        DoReplicate 10 NoAction
+    WarningCry -> w
+    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 -> w & tocr . crActionPlan . apStrategy .~ CloseToMelee tid
+    _ -> case cr ^? crIntention . mvToPoint . _Just of
+        Just p
+            | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
+                w & tocr . crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
+            | otherwise ->
+                w -- & tocr . crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & tocr . crActionPlan . apStrategy .~ Search
+                    & tocr . crIntention . mvToPoint .~ Nothing
+        _ -> w & tocr %~ viewTarget w
+  where
+    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
+            tpos = tcr ^. crPos . _xy
+        guard $ _meleeCooldownL (_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 . meleeCooldownR < 15
+        return tid
+    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
+        Just AimAt {} -> False
+        _ -> 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
+        0 <- cr ^? crType . dodgeCooldown
+        return $ hasLOS cxy txy w
+            && 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
     WarningCry -> cr
-    MeleeStrike -> cr
     CloseToMelee cid
         | VocReady == (cr ^. crVocalization) ->
             cr
                 & crActionPlan . apAction
-                    .:~ ImpulsesList
+                    .~ ImpulsesList
                         ( [Bark soundid] :
                           replicate numjits [RandomImpulse thejitter]
                             ++ [[ChangeStrategy (CloseToMelee cid)]]
-                        )
+                        ) NoAction
                 & resetCrVocCoolDown w
                 & crActionPlan . apStrategy .~ WarningCry
       where
         thejitter = RandImpulseCircMove 3
         soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
         numjits = fst $ randomR (15, 25) (_randGen w)
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
     _ -> case cr ^? crIntention . mvToPoint . _Just of
         Just p
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
-                cr & crActionPlan . apAction .~ [PathTo p (DoImpulses [ChangeStrategy Wander])]
+                cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ [bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]]
-                    & crActionPlan . apStrategy .~ WatchAndWait
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & crActionPlan . apStrategy .~ Search
                     & crIntention . mvToPoint .~ Nothing
         _ -> viewTarget w cr
+  where
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
 
 hoverCritMv :: World -> Creature -> Creature
 hoverCritMv w cr = case _apStrategy (_crActionPlan cr) of
     WarningCry -> cr
-    MeleeStrike -> cr
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
     _ -> case cr ^? crIntention . mvToPoint . _Just of
         Just p
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
-                cr & crActionPlan . apAction .~ [PathTo p (DoImpulses [ChangeStrategy Wander])]
+                cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ [bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]]
-                    & crActionPlan . apStrategy .~ WatchAndWait
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & crActionPlan . apStrategy .~ Search
                     & crIntention . mvToPoint .~ Nothing
         _ -> viewTarget w cr
+  where
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
 
 --goToTarget :: World -> Creature -> Creature
 --goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
@@ -173,25 +255,18 @@ viewTarget w cr = case cr ^? crIntention . viewPoint . _Just of
     Just p
         | hasLOSIndirect p (cr ^. crPos . _xy) w ->
             cr
-                & crActionPlan . apAction .~ [TurnToPoint p]
+                & crActionPlan . apAction .~ TurnToPoint p
                 & crIntention . viewPoint .~ Nothing
                 & crActionPlan . apStrategy .~ Investigate
         | otherwise ->
-            cr & crActionPlan . apAction %~ replaceNullWith (PathTo p (DoImpulses [ChangeStrategy Wander]))
+--            cr & crActionPlan . apAction %~ replaceNullWith (PathTo p (DoImpulses [ChangeStrategy Wander]))
+            cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
                 & crActionPlan . apStrategy .~ Investigate
     Nothing -> cr
 
-replaceNullWith :: a -> [a] -> [a]
-replaceNullWith x [] = [x]
-replaceNullWith _ xs = xs
-
-doStrategyActions :: Creature -> Creature
-doStrategyActions cr = case cr ^? crActionPlan . apStrategy of
-    Just (StrategyActions strat acs) ->
-        cr
-            & crActionPlan . apAction .~ acs
-            & crActionPlan . apStrategy .~ strat
-    _ -> cr
+--replaceNullWith :: a -> [a] -> [a]
+--replaceNullWith x [] = [x]
+--replaceNullWith _ xs = xs
 
 overrideInternal :: (Creature -> Bool) -> (Creature -> Creature) -> Creature -> Creature
 overrideInternal test update cr
@@ -231,16 +306,11 @@ searchIfDamaged cr
     | _crPain cr > 0
         && _apStrategy (_crActionPlan cr) == WatchAndWait =
         cr & crPerception . cpVigilance .~ Vigilant
-            & crActionPlan . apStrategy
-                .~ StrategyActions
-                    LookAround
-                    [ TurnToPoint (cr ^. crPos . _xy -.- unitVectorAtAngle (_crDir cr))
-                        `DoActionThen` 40 `WaitThen` bfsThenReturn 500
-                    ]
+            & crActionPlan . apStrategy .~ LookAround
     | otherwise = cr
 
-bfsThenReturn :: Int -> Action
-bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
+--bfsThenReturn :: Int -> Action
+--bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
 
 --    theaction
 --  where

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

@@ -9,8 +9,13 @@ crShape :: CreatureType -> CreatureShape
 crShape = \case
     Avatar{} -> Humanoid (greyN 0.9) (lightx4 black) (greyN 0.3)
     ChaseCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
+    CrabCrit {} -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
     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/Slime.hs

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

src/Dodge/Creature/State.hs

@@ -4,6 +4,8 @@ module Dodge.Creature.State (
     invItemEffs,
 ) where
 
+import qualified Data.IntSet as IS
+import Dodge.Creature.Radius
 import qualified Data.IntMap.Strict as IM
 import Linear
 import NewInt
@@ -43,16 +45,38 @@ import qualified SDL
 doDamage :: Int -> World -> World
 doDamage cid w = fromMaybe w $ do
     cr <- w ^? cWorld . lWorld . creatures . ix cid
-    return $ applyPastDamages cr $ applyCreatureDamage (cr ^. crDamage) cr w
+    return $ crPainEffect cr $ applyCreatureDamage cid cr w
 
 -- TODO generalise shake to arbitrary damage amounts
-applyPastDamages :: Creature -> World -> World
-applyPastDamages cr w
-    | HoverCrit {} <- cr ^. crType 
-    , _crPain cr > 50 = w
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1
-    | HoverCrit {} <- cr ^. crType  = w
+crPainEffect :: Creature -> World -> World
+crPainEffect cr = case cr ^. crType of
+    HoverCrit {} -> hoverPainEffect cr
+    HiveCrit{} -> hivePainEffect cr
+    _ -> jitterPain cr
+
+
+hoverPainEffect :: Creature -> World -> World
+hoverPainEffect cr
+    | _crPain cr > 50 =
+                (cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50)
+                . (cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1)
+    | otherwise = id
+
+
+hivePainEffect :: Creature -> World -> World
+hivePainEffect cr w
+    | _crPain cr > 0 = w & cWorld . lWorld . creatures . ix (cr ^. crID) . crPain %~ (max 0 . subtract 5)
+        & cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos & _xy +~ p & _z .~ 20) v 200
+        & randGen .~ g
+    | otherwise = w
+  where
+    (a,g') = randomR (0,2*pi) $ w ^. randGen
+    (b,g) = runState randOnUnitSphere g'
+    p = (crRad (cr ^. crType) + 5) *^ unitVectorAtAngle a
+    v = 3 *^ b
+
+jitterPain :: Creature -> World -> World
+jitterPain cr w
     | _crPain cr > 200 = dojitter 3 100
     | _crPain cr > 20 = dojitter 2 10
     | _crPain cr > 0 = dojitter 1 1
@@ -60,7 +84,7 @@ applyPastDamages cr w
   where
     dojitter x y =
         let (p, g) = runState (randInCirc x) (_randGen w)
-         in w & cWorld . lWorld . creatures . ix (_crID cr) %~ crMvByNoStride p (w ^. cWorld . lWorld)
+         in w & cWorld . lWorld . creatures . ix (_crID cr) %~ crMvByNoStride p w
                 & cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ y
                 & randGen .~ g
 
@@ -83,19 +107,23 @@ invItemLocUpdate cr loc w = doAnyEquipmentEffect loc cr $ case itm ^. itType of
     HELD MINIGUNX{} -> coolMinigun itm w
     HELD MACHINEPISTOL{} -> coolMachinePistol cr itm w
     LASER | loc ^. locDT . dtValue . _2 == WeaponTargetingSF
-        , itm ^? itLocation . ilIsAttached == Just True -> shineTargetLaser cr loc w
+        , isattached -> shineTargetLaser cr loc w
     HELD LED 
-        | itm ^? itLocation . ilIsAttached == Just True -> shineTorch cr loc w
+        | isattached -> shineTorch cr loc w
     TARGETING tt 
-        | itm ^? itLocation . ilIsAttached == Just True -> updateItemTargeting tt cr itm w
+        | isattached -> updateItemTargeting tt cr itm w
     ARHUD
-        | itm ^? itLocation . ilIsAttached == Just True -> drawARHUD loc w
+        | isattached -> drawARHUD loc w
     _ -> w
   where
     haspulse =
         w ^? cWorld . lWorld . creatures . ix 0 . crType . avatarPulse . pulseProgress
             == Just 0
     itm = loc ^. locDT . dtValue . _1
+    isattached = fromMaybe False $ do
+        i <- itm ^? itLocation . ilInvID . unNInt
+        is <- w ^? hud . manObject . hiAttachedItems
+        return $ i `IS.member` is
 
 coolMinigun :: Item -> World -> World
 coolMinigun itm
@@ -138,7 +166,7 @@ copierItemUpdate itm cr w = fromMaybe w $ do
     x <- itm ^? itScroll . itsInt
     invid <- itm ^? itLocation . ilInvID
     ip <- itm ^? itType . ibtPathing
-    i <- getInventoryPath x ip (_unNInt invid) cr
+    i <- getInventoryPath w x ip (_unNInt invid) cr
     itm' <- cr ^? crInv . ix (NInt i) >>= \k -> w ^? cWorld . lWorld . items . ix k
     v <- getItemValue itm' w cr
     return $ w & pointerToItem itm . itUse . uValue .~ v
@@ -212,7 +240,7 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
     magitid <- mag ^? dtValue . _1 . itID . unNInt
     return $
         w
-            & worldEventFlags . at InventoryChange ?~ ()
+            & worldEventFlags . at InventoryChange ?~ () -- why?
             & cWorld . lWorld . items
                 . ix magitid
                 . itConsumables
@@ -225,9 +253,10 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
                     , _lpPos = pos
 --                    , _lpColor = col
                     , _lpType = TargetingLaser (_itID itm)
+                    , _lpOrigin = CrWeaponO $ cr ^. crID
                     }
   where
-    o = locOrient loc cr
+    o = locOrient w loc cr
     itmtree = loc ^. locDT
     (p, q) = o `Q.comp` (V3 5 0 0, Q.qid)
     x = 1
@@ -240,19 +269,19 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
     itid = itm ^. itID . unNInt
 
 shineTorch :: Creature -> LocationDT OItem -> World -> World
-shineTorch cr loc = fromMaybe id $ do
+shineTorch cr loc w = fromMaybe w $ do
     mag <- find (isammolink . (^. dtValue . _2)) (itmtree ^. dtLeft)
     i <- mag ^. dtValue . _1 . itConsumables
 --    guard $ crIsAiming cr
     guard $ i >= x
     itid <- mag ^? dtValue . _1 . itID . unNInt
-    return $
-        (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
-           . (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
-            . (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
+    return $ w
+       & (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
+       &     (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
+       &      (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
   where
     itmtree = loc ^. locDT
-    (p, q) = locOrient loc cr
+    (p, q) = locOrient w loc cr
     x = 10
     isammolink AmmoMagSF{} = True
     isammolink _ = False
@@ -288,7 +317,10 @@ updateItemTargeting tt cr itm w = case tt of
   where
     pointittarg = cWorld . lWorld . items . ix itid . itTargeting
     itid = itm ^. itID . unNInt
-    isattached = itm ^?! itLocation . ilIsAttached
+    isattached = fromMaybe False $ do
+        i <- itm ^? itLocation . ilInvID . unNInt
+        is <- w ^? hud . manObject . hiAttachedItems
+        return $ i `IS.member` is
     rbpressed = SDL.ButtonRight `M.member` _mouseButtons (_input w)
 
 setRBCreatureTargeting :: Creature -> World -> ItemTargeting -> ItemTargeting

src/Dodge/Creature/State/WalkCycle.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Creature.State.WalkCycle (updateCarriage) where
+module Dodge.Creature.State.WalkCycle (updateCarriage
+    ,compressionScale
+    , flyInertia
+    ) where
 
+import qualified Quaternion as Q
 import Dodge.Creature.Radius
 import Geometry
 import Dodge.Update.Camera.Rotate
@@ -25,50 +29,71 @@ 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
+        return $ w & tocr . crPos .~ mp + (oxyrot (mcr ^. crDir) 
+            (oxyrot (-mcr^.crDir) p & _x *~ d & _y %~ (/d)))
   where
+    oxyrot a = over _xy (rotateV a)
     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
     | a > 0 = y - project y x
     | otherwise = y
   where
-    -- project y x is the projection of x onto y
     a = dotV (normalize y) (project y x)
 
 walkCliffPush :: Creature -> [(Point2,Point2)] -> Point2
 walkCliffPush cr xs = pushAgainst (cr ^. crOldPos . _xy - cr ^. crOldOldPos . _xy) (-h xs)
   where
     cxy = cr ^. crPos . _xy
-    h = circSegsInside cxy (cr ^. crType . to crRad)
+    h = circSegsInside cxy (min 10 (cr ^. crType . to crRad))
 
 groundCliffPush :: Creature -> [(Point2,Point2)] -> Point2
 groundCliffPush cr xs = x *^ circSegsInside cxy r xs
   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,14 +130,22 @@ 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
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
-    g = uncurry $ crOnSeg cr
+    --g = uncurry $ crOnSeg cr
+    g = uncurry $ crOnSeg' cr
     f = pointInPoly cxy
 
+crOnSeg' :: Creature -> Point2 -> Point2 -> Bool
+{-# INLINE crOnSeg' #-}
+crOnSeg' cr = circOnSeg (cr ^. crPos . _xy) (min 10 (cr ^. crType . to crRad))
+
 chasmRotate :: Creature -> Point2 -> World -> World
 chasmRotate cr v w
     | t = rotateTo8 (argV v) w

src/Dodge/Creature/Statistics.hs

@@ -3,13 +3,13 @@ module Dodge.Creature.Statistics (
     getCrMoveSpeed,
     crStrength,
     crDexterity,
-    crIntelligence,
+--    crIntelligence,
 ) where
 
+import Dodge.Data.World
 import Dodge.Data.Equipment.Misc
 import qualified Data.Map.Strict as M
 import NewInt
-import Dodge.Data.LWorld
 import Data.Maybe
 --import qualified IntMapHelp as IM
 import qualified Data.IntMap.Strict as IM
@@ -25,6 +25,7 @@ crDexterity cr = case cr ^. crType of
     AutoCrit -> 46
     BarrelCrit {} -> 0
     LampCrit {} -> 0
+    _ -> 46
 
 crStrength :: Creature -> Int
 crStrength cr = case cr ^. crType of
@@ -35,20 +36,25 @@ crStrength cr = case cr ^. crType of
     AutoCrit -> 46
     BarrelCrit {} -> 0
     LampCrit {} -> 0
+    _ -> 46
 
-crIntelligence :: Creature -> Int
-crIntelligence  cr = case cr ^. crType of
-    Avatar { _avIntelligence = x } -> x
-    ChaseCrit {} -> 20
-    HoverCrit {} -> 20
-    SwarmCrit -> 20
-    AutoCrit -> 20
-    BarrelCrit {} -> 0
-    LampCrit {} -> 0
+--crIntelligence :: Creature -> Int
+--crIntelligence  cr = case cr ^. crType of
+--    Avatar { _avIntelligence = x } -> x
+--    ChaseCrit {} -> 20
+--    CrabCrit {} -> 20
+--    HoverCrit {} -> 20
+--    SwarmCrit -> 20
+--    AutoCrit -> 20
+--    BarrelCrit {} -> 0
+--    LampCrit {} -> 0
+--    SlinkCrit{} -> 5
+--    SlimeCrit{} -> 1
+--    BeeCrit{} -> 20
     
 
-getCrMoveSpeed :: LWorld -> Creature -> Int
-getCrMoveSpeed lw cr = strFromHeldItem lw cr + strFromEquipment lw cr + crStrength cr
+getCrMoveSpeed :: World -> Creature -> Int
+getCrMoveSpeed w cr = strFromHeldItem w cr + strFromEquipment (w^.cWorld.lWorld) cr + crStrength cr
 
 strFromEquipment :: LWorld -> Creature -> Int
 strFromEquipment lw = sum . fmap equipmentStrValue . crCurrentEquipment lw
@@ -64,12 +70,12 @@ crCurrentEquipment lw = fmap f . _crEquipment
   where
     f i = lw ^?! items . ix (_unNInt i)
 
-strFromHeldItem :: LWorld -> Creature -> Int
-strFromHeldItem lw cr = fromMaybe 0 $ do
+strFromHeldItem :: World -> Creature -> Int
+strFromHeldItem w cr = fromMaybe 0 $ do
     Aiming {} <- cr ^? crStance . posture
-    is <- cr ^? crManipulation . manObject . imAttachedItems
+    is <- w^?hud . manObject . hiAttachedItems
     let js = IM.elems $ IM.restrictKeys  (cr ^. crInv . unNIntMap) is
-    return . negate . sum . fmap itemWeight $ IM.restrictKeys (lw ^. items) $ IS.fromList js
+    return . negate . sum . fmap itemWeight $ IM.restrictKeys (w ^.cWorld.lWorld. items) $ IS.fromList js
 
 itemWeight :: Item -> Int
 itemWeight it = case it ^. itType of

src/Dodge/Creature/Strategy.hs

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

src/Dodge/Creature/Test.hs

@@ -29,7 +29,6 @@ import Dodge.Creature.Radius
 import Dodge.Data.Equipment.Misc
 import Dodge.Data.AimStance
 import Control.Lens
-import Data.List (find)
 import Data.Maybe
 import Dodge.Base.Collide
 import Dodge.Data.World
@@ -81,31 +80,28 @@ crStratConMatches strat cr = strat == _apStrategy (_crActionPlan cr)
 -- this equality check might be slow...
 
 crAwayFromPost :: Creature -> Bool
-crAwayFromPost cr = case find sentinelGoal . _apGoal $ _crActionPlan cr of
-    Just (SentinelAt p _) -> dist p (cr ^. crPos . _xy) > 15
+crAwayFromPost cr = case _apGoal $ _crActionPlan cr of
+    SentinelAt p _ -> dist p (cr ^. crPos . _xy) > 15
     _ -> False
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
 
-crInAimStance :: AimStance -> Creature -> Bool
-crInAimStance as cr = cr ^? crStance . posture == Just Aiming
-    && cr ^? crManipulation . manObject . imAimStance == Just as
+crInAimStance :: AimStance -> World -> Creature -> Bool
+crInAimStance as w cr = cr ^? crStance . posture == Just Aiming
+    && w ^? hud . manObject . hiAimStance == Just as
 
-oneH :: Creature -> Bool
+oneH :: World -> Creature -> Bool
 oneH = crInAimStance OneHand
 
-twoFlat :: Creature -> Bool
+twoFlat :: World -> Creature -> Bool
 twoFlat = crInAimStance TwoHandFlat
 
-twists :: Creature -> Bool
+twists :: World -> Creature -> Bool
 twists = crInAimStance TwoHandTwist
 
 -- the use of crOldPos is because the damage position is calculated on the
 -- previous frame
 -- Not sure if it is a good idea
-crIsArmouredFrom :: IM.IntMap Item -> Point2 -> Creature -> Bool
-crIsArmouredFrom m p cr = fromMaybe False $ do
+crIsArmouredFrom :: IM.IntMap Item -> Point2 -> World -> Creature -> Bool
+crIsArmouredFrom m p w cr = fromMaybe False $ do
     NInt itid <- cr ^? crEquipment . ix OnChest
     ittype <- m ^? ix itid . itType
     return $
@@ -116,8 +112,8 @@ crIsArmouredFrom m p cr = fromMaybe False $ do
   where
     -- even though angleVV can generate NaN, the comparison seems to deal with it
     frontarmdirection
-        | crInAimStance OneHand cr = 0.5
-        | crInAimStance TwoHandTwist cr = negate 1
+        | crInAimStance OneHand w cr = 0.5
+        | crInAimStance TwoHandTwist w cr = negate 1
         | otherwise = 0
 
 --crOnSeg :: Point2 -> Point2 -> Creature -> Bool
@@ -133,11 +129,19 @@ isAnimate :: Creature -> Bool
 {-# INLINE isAnimate #-}
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
-    _ -> True
+    SlimeIntelligence -> True
+    ActionPlan{} -> True
 
 hasAutoDoorBody :: Creature -> Bool
-hasAutoDoorBody cr = case cr ^. crHP of
-    HP {} -> True
-    CrIsCorpse {} -> True
-    CrDestroyed {} -> False
+hasAutoDoorBody cr = crittype && notdestroyed
+  where
+    notdestroyed = case cr ^. crHP of
+        HP {} -> True
+        CrIsCorpse {} -> True
+        AvatarDestroyed {} -> False
+    crittype = case cr ^. crType of
+        SlimeCrit {} -> False
+        BeeCrit {} -> False
+        HiveCrit {} -> False
+        _ -> True
     

src/Dodge/Creature/Update.hs

@@ -1,15 +1,28 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Dodge.Creature.Update (updateCreature) where
 
-import Dodge.Base.You
-import Control.Monad
+import qualified Data.Semigroup as Semi
+import Dodge.WorldEvent.ThingsHit
+import Dodge.Humanoid
+import Dodge.Creature.Perception
+import Dodge.Creature.ReaderUpdate
+import Dodge.Creature.Slime
+import Dodge.Creature.Radius
+import Dodge.Creature.MoveType
+import Dodge.Base.Collide
+import Data.List (sortOn)
+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.NewID
-import Dodge.Corpse.Make
+import Dodge.Base.You
 import Dodge.Creature.Action
+import Dodge.Creature.Picture
 import Dodge.Creature.State
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Vocalization
@@ -17,7 +30,6 @@ import Dodge.Creature.YourControl
 import Dodge.Damage
 import Dodge.Data.Damage.Type
 import Dodge.Data.World
-import Dodge.Humanoid
 import Dodge.Inventory
 import Dodge.Lampoid
 import Dodge.Prop.Gib
@@ -27,52 +39,475 @@ 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)
-    | null (cr ^? crHP . _HP) = id
-    | otherwise = updateLivingCreature cr
+    | cr ^. crPos . _z < negate 300 = (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature) 
+        . destroyAllInvItems cr
+    | otherwise = case cr ^. crHP of
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . applyCreatureDamage (_crID cr) cr
+        AvatarDestroyed{} -> id
+        HP{} -> cleardamage . updateLivingCreature cr
   where
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
+    cleardamage = cWorld . lWorld . creatures . ix (cr^.crID) . crDamage .~ mempty
 
 updateLivingCreature :: Creature -> World -> World
-updateLivingCreature cr =
-    case _crType cr of
-        Avatar{} ->
-            (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
-                . crUpdate cid
-                . yourControl
-        LampCrit{} -> updateLampoid cr
-        BarrelCrit bt -> updateBarreloid bt cr
-        ChaseCrit{} -> \w ->
-            crUpdate cid . performActions cid $
-                over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
-        AutoCrit {} -> crUpdate cid
-        SwarmCrit {} -> crUpdate cid
-        HoverCrit {} -> \w ->
-            crUpdate cid . performActions cid . hoverCritHoverSound cr $
-                over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
+updateLivingCreature cr = case cr ^. crType of
+    Avatar{} ->
+        (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
+            . crUpdate cid
+            . yourControl
+    LampCrit{} -> updateLampoid cr
+    BarrelCrit bt -> updateBarreloid bt cr
+    ChaseCrit{} -> crUpdate cid . performActions cid . setChaseCritKinematics cid . updateChaseCrit cid cr
+    CrabCrit{} -> crUpdate cid . performActions cid . crabCritInternal cid
+    AutoCrit{} -> crUpdate cid
+    SwarmCrit{} -> crUpdate cid
+    HoverCrit{} -> crUpdate cid . performActions cid . hoverCritHoverSound cr .
+            updateHoverCrit cid
+    SlinkCrit{} -> slinkCritUpdate cid
+    SlimeCrit{} -> updateSlimeCrit 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 
+    , Just z <- cr ^? crType . hiveSlime
+    , z >= 400
+        = w 
+        & tocr . crType . hiveChildren %~ IS.insert nid
+        & tocr . crType . hiveGestation .~ 50
+        & cWorld . lWorld . creatures . at nid ?~ ncr
+        & tocr . crType . hiveSlime -~ 400
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees = w
+        & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
+    | otherwise = w
+  where
+    nbees = 15
+    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 . _xy) < 20
+
+updateBeeCrit :: Creature -> Int -> World -> World
+updateBeeCrit cr cid
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr cid
+    | otherwise = beeLifespanCheck cr cid . updateCalmBee cr cid
+
+beeLifespanCheck :: Creature -> Int -> World -> World
+beeLifespanCheck cr cid
+    | Just ls <- cr ^? crType . beeLifespan
+    , Just x <- cr ^? crType . beeSlime
+    , ls < 1
+    , x < 5
+        = cWorld . lWorld . creatures . ix cid . crHP . _HP -~ 1
+    | otherwise = id
+
+updateAggroBee :: Creature -> Int -> World -> World
+updateAggroBee cr cid w
+    | Mounted{} <- cr ^. crStance . carriage = w & tocr . crStance . carriage .~ Flying 0 
+    | Just tcr <- atarget
+    , distance (tcr ^. crPos . _xy) (cr ^. crPos . _xy) < crRad (cr ^. crType) + crRad (tcr ^. crType) + 1
+    , nearZeroAngle (argV (tcr ^. crPos . _xy - cr ^. crPos . _xy) - cr ^. crDir) < pi / 2
+    , 0 <- cr ^?! crType . meleeCooldown
+        = w & tocr . crPos .~ (cr ^. crOldPos & _xy -~ 5 *^ unitVectorAtAngle (cr ^. crDir))
+            & tocr . crType . startStopMv .~ (cr ^?! to crMvType . mvPulseTime)
+            & cWorld . lWorld . creatures . ix (tcr ^. crID) . crDamage 
+                .:~ Blunt 50 (cxy + crRad (cr ^. crType) *^ vdir) vdir (CrMeleeO (cr ^. crID))
+            & tocr . crType . meleeCooldown .~ 20
+    | Just tcr <- atarget = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
+        & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w & tocr . crType . beeAggro -~ 1
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | otherwise = w & tocr . crType . beeAggro -~ 1
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+        & randGen .~ g 
+  where
+    (p,g) = runState (randOnCirc 150) (w ^. randGen)
+    atarget = listToMaybe . sortOn (distance cxy . (^.crPos._xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w
+    vdir = unitVectorAtAngle (cr ^. crDir)
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = t (tcr ^. crType)
+        && isJust (tcr ^? crHP . _HP)
+        && hasLOS cxy (tcr ^. crPos . _xy) w
+    t = \case
+        Avatar{} -> True
+        ChaseCrit{} -> True
+        CrabCrit{} -> True
+        _ -> False
+
+-- do bees need to be able to see slime targets?
+-- if no path can be made, reset harvest action
+-- this should all be simplified
+-- should count how many are mounted on an individual slime, try for a different
+-- slime if too many
+updateCalmBee :: Creature -> Int -> World -> World
+updateCalmBee cr cid w 
+    | Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just x <- cr ^? crType . beeSlime 
+    , x >= 50 = w 
+        & tocr . crType . beeSlime -~ 50
+        & cWorld . lWorld . creatures . ix (hcr ^. crID) . crType . hiveSlime +~ 50
+    | Just x <- cr ^? crType . beeSlime 
+    , x < 50
+    , Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just ReturnToHive <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just ReturnToHive <- cr ^? crActionPlan . apStrategy = w 
+    | Just x <- cr ^? crType . beeSlime 
+    , x >= 1500 = starthivereturn
+        & randGen .~ gsa
+        & tocr . crType . beeLifespan %~ max 0 . subtract sa
+    | Just mid <- cr ^? crStance . carriage . mountID
+    , mountshakeoff mid = startsearch
+    | Nothing <- cr ^? crActionPlan . apStrategy . harvestTarget 
+    ,  xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g') <- runState (takeOne xs) (w ^. randGen) =
+         w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+            & randGen .~ g'
+    | Just tid <- cr ^? crStance . carriage . mountID
+    , Just SlimeCrit{} <- w ^? cWorld . lWorld . creatures . ix tid . crType = w
+        & tocr . crType . beeSlime +~ sspeed
+        & cWorld . lWorld . creatures . ix tid . crType . slimeSlime -~ sspeed
+    | Just (tcr,ti) <- gettarg
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.8*crRad (tcr ^. crType) 
+    , Just d <- tcr ^? crType . slimeCompression
+        = w
+        & tocr . crStance . carriage .~ Mounted ti 
+            (oxyrot (tcr^.crDir) 
+                (oxyrot (-tcr^.crDir) (cr ^. crPos - tcr ^. crPos) & _x %~ (/d) & _y *~ d))
+        & tocr . crActionPlan . apAction .~ NoAction
+    | Just (tcr,_) <- gettarg = w
+            & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+    | Just (HarvestFrom{}) <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just (SearchTimed 0) <- cr ^? crActionPlan . apStrategy = starthivereturn
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w
+        & tocr . crActionPlan . apStrategy . searchTimer %~ (max 0 . subtract 1)
+    | otherwise = startsearch
+  where
+    oxyrot a = over _xy (rotateV a)
+    (sa,gsa) = runState (takeOne [0,1]) (w ^. randGen)
+    starthivereturn = fromMaybe w $ do
+        hcr <- gethive
+        return $ w
+            & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+            & tocr . crActionPlan . apStrategy .~ ReturnToHive
+            & tocr . crStance . carriage %~ dounmount
+    dounmount x = case x of
+        Flying{} -> x
+        _ -> Flying 0
+    startsearch = w
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crStance . carriage %~ dounmount
+        & randGen .~ g
+        & tocr . crActionPlan . apStrategy .~ SearchTimed 200
+    (p,g) = runState (randOnCirc 200) (w ^. randGen)
+    cxy = cr ^. crPos . _xy
+    mountshakeoff mid = fromMaybe False $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        x <- mcr ^? crType . slimeDistortion . sdTime
+        return $ x > 8
+    sspeed = 5
+    gettarg = do
+        i <- cr ^? crActionPlan . apStrategy . harvestTarget 
+        tcr <-  w ^? cWorld . lWorld . creatures . ix i
+        x <- tcr ^? crType . slimeSlime . to slimeToRad
+        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 . slimeSlime . to slimeToRad
+        return $ r > 12
+
+updateSlimeCrit :: Int -> World -> World
+updateSlimeCrit cid w 
+    | cr ^?! crType . slimeSlime < 2500 
+        = w & cWorld . lWorld . creatures . at cid .~ Nothing
+    | Just hitp <- w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmPos
+        , Just hitv <-  w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmVector
+        , Just w' <- splitSlimeCrit' hitp hitv cid cr w = w'
+    | (cr ^?! crType . slimeIsCompressing) && 1 > p
+        = let (w',g) = runState (setSlimeDir cid cr 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 . slimeDistortion %~ fsst
+        & tocr . crType . slimeEngulfProgress %~ (max 0 . subtract 0.5)
+  where
+    fsst (SlimeDistortion x ps t) | x > 0 = SlimeDistortion (x-1) ps t
+    fsst _ = NoSlimeDistortion
+    tocr = cWorld . lWorld . creatures . ix cid
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    mvslime cr' = cr' & crType . slimeCompression +~ f (0.1/r)
+        & crPos . _xy +~ 0.1 *^ unitVectorAtAngle (cr' ^. crDir)
+        & crType . slimeIsCompressing %~ f'
+    f | cr ^?! crType . slimeIsCompressing = negate
+      | otherwise = id
+    f'  | p > 1.5 = const True
+        | otherwise = id
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    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
+        else return $ w & tocr . crDir .~ d
+                & tocr . crType . slimeIsCompressing .~ False
+                & tocr . crDamage .~ mempty
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+
+doSlimeRadChange :: Creature -> Creature
+doSlimeRadChange = crType . slimeSlimeChange %~ f
+  where
+    f x | x > 1000 = x - 1000
+        | x < -1000 = x + 1000
+        | 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)
+        (ps',qs') 
+            | isLHS p (p+v) cxy = (ps,qs)
+            | otherwise = (qs,ps)
+        c1 = cr' & crPos . _xy .~ mp + r1 *^ mvdir
+                & crType . slimeSlime .~ round (r1 ^ (2 :: Int) * 100)
+                & crDir .~ argV mvdir
+        c2 = cr' & crPos . _xy .~ mp - r2 *^ mvdir
+                & crType . slimeSlime .~ round (r2^(2::Int) * 100)
+                & crDir .~ argV (-mvdir)
+        c1ps = qs' & each +~ cxy - (mp + r1 *^ mvdir) & each %~ rotateV (- c1 ^. crDir)
+        c2ps = ps' & each +~ cxy - (mp - r2 *^ mvdir) & each %~ rotateV (- c2 ^. crDir)
+    return (c1 & crType . slimeDistortion . sdShape .~ f c1ps c1
+        ,c2 & crType . slimeDistortion . sdShape .~ f c2ps c2
+        )
+  where
+    f xs@(_:_) c = polyInPoly (centroid xs) xs (slimeOutline c)
+    f _ _ = mempty
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    cr' = cr & crDamage .~ []
+        & crType . slimeSlimeChange .~ 0
+        & crType . slimeDistortion .~ SlimeDistortion 10  mempty True
+        & crType . slimeIsCompressing .~ False
+        & crType . slimeCompression .~ 1
+    (ps,qs) = cutPoly (p-cxy) (p+v-cxy) $ slimeOutline cr & each %~ rotateV (cr ^. crDir)
+    
+-- h is the height of the segment, ie r - distance to center
+segmentArea :: Float -> Float -> Float
+segmentArea r h = r*r*acos(1-h/r) - (r-h)*sqrt(h*(2*r-h))
+
+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)
+
+setChaseCritKinematics :: Int -> World -> World
+setChaseCritKinematics cid w = w
+    & cWorld . lWorld . creatures . ix cid %~ setChaseCritKinematics' w
+
+ccAngles :: World -> Creature -> (Float,Float,Float,Float)
+ccAngles w cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f (-a) 0 0
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f 
+            (0.45*pi - a)
+            (-0.9*pi)
+            (0.45*pi)
+    | otherwise = f (0.6*pi) (-0.2*pi) (-0.4*pi)
+  where
+    f a b c = (0,a,b,c)
+
+ccKState :: World -> Creature -> ChaseKState
+ccKState _ cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = PeckingCK i
+    | CloseToMelee i <- cr^?!crActionPlan.apStrategy = AimingCK i
+    | otherwise = UprightCK
+
+setChaseCritKinematics' :: World -> Creature -> Creature
+setChaseCritKinematics' w = f . g
+  where
+    g cr | ccKState w cr == cr ^?! crType . chaseKState = cr
+        | PeckingCK i <- ccKState w cr = cr
+            & crType . chaseLerp .~ 3
+            & crType . chaseKState .~ PeckingCK i
+        | otherwise = cr & crType . chaseLerp .~ 20
+            & crType . chaseKState .~ ccKState w cr
+    f cr = 
+        let (a,b,c,d) = ccAngles w cr
+            x = cr ^?! crType . chaseLerp
+        in if x <= 1
+            then cr & crType . chaseqy0 .~ a
+              & crType . chaseqy1 .~ b
+              & crType . chaseqy2 .~ c
+              & crType . chaseqy3 .~ d
+            else cr 
+              & crType . chaseqy0 %~ h x a
+              & crType . chaseqy1 %~ h x b
+              & crType . chaseqy2 %~ h x c
+              & crType . chaseqy3 %~ h x d
+              & crType . chaseLerp -~ 1
+    h x a b = 1/fromIntegral x * a + (1-1/fromIntegral x) * b
+
+updateChaseCrit :: Int -> Creature -> World -> World
+updateChaseCrit cid cr 
+    | SearchForFood <- cr ^?! crActionPlan . apGoal = updateFoodSearchChaseCrit cid cr
+    | Flee <- cr^?!crActionPlan.apGoal
+        , NoAction <- cr^?!crActionPlan.apAction = tocr.crActionPlan.apGoal.~SearchForFood
+    | Flee <- cr^?!crActionPlan.apGoal = id
+    | otherwise = updateCalmChaseCrit cid
+  where
+    tocr = cWorld.lWorld.creatures.ix cid
+
+updateFoodSearchChaseCrit :: Int -> Creature -> World -> World
+updateFoodSearchChaseCrit cid cr w 
+    | (tcr:_) <- sortOn f . IM.elems . IM.filter avoidcr $ crsNearCirc cxy 60 w 
+        = let p = fleePoint cr cxy (20 *^ normalize (cxy - tcr^.crPos._xy)) w
+          in w &tocr.crActionPlan.apAction.~PathTo p NoAction
+                &tocr.crActionPlan.apGoal.~Flee
+    | Eat i 0 <- cr^?! crActionPlan.apAction = w
+            & cWorld .lWorld.creatures . at i .~ Nothing
+            & tocr . crActionPlan.apAction.~NoAction
+            & tocr . crActionPlan.apStrategy.~Search
+    | Eat i x <- cr^?! crActionPlan.apAction = w
+            & tocr .crActionPlan.apAction.acTimer-~1
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Nothing <- w ^?cWorld.lWorld.creatures.ix i = w & tocr . crActionPlan.apStrategy .~ Search
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Just tcr <-w^?cWorld.lWorld.creatures.ix i
+        ,distance cxy (tcr^.crPos._xy) < 15 = w
+            & tocr.crActionPlan.apAction.~Eat i 5
+--            & tocr.crActionPlan.apAction.~NoAction
+--            & tocr.crActionPlan.apStrategy.~Search
+--            & cWorld.lWorld.creatures.at i.~Nothing
+    | CloseToMelee{}<-cr^?!crActionPlan.apStrategy 
+        ,PathTo{}<-cr^?!crActionPlan.apAction= w
+    | xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g) <- runState (takeOne xs) (w ^. randGen) = w&tocr.crActionPlan.apAction.~DoImpulses[MvForward]
+        &tocr.crActionPlan.apStrategy.~CloseToMelee (tcr^.crID)
+        &tocr.crActionPlan.apAction.~PathTo (tcr^.crPos._xy) NoAction
+        &randGen.~g
+    | otherwise = w
+  where
+    f c = fromMaybe 100 $ do
+        s <- cr^?crType.slimeSlime
+        return $ dist cxy (c^.crPos._xy) - sqrt(0.01*fromIntegral s)
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    avoidcr c | ct@SlimeCrit{} <- c^.crType = distance cxy (c^.crPos._xy)-crRad ct < 10
+        | otherwise = False
+    istarget tcr 
+        | BeeCrit{} <- tcr^.crType 
+        , CrIsCorpse{} <- tcr^.crHP = True
+        | otherwise = False
+    
+fleePoint :: Creature -> Point2 -> Point2 -> World -> Point2
+fleePoint c p v w = g . minimum $ f <$> [p+v, p+0.9*^vNormal v, p-0.9*^vNormal v]
+  where
+    f ep = let q = walkablePoint c p ep w
+            in Semi.Arg (-distance q p) q
+    g (Semi.Arg _ x) = x
+
+
+updateCalmChaseCrit :: Int -> World -> World
+updateCalmChaseCrit cid w = w
+    & tocr %~ overrideMeleeCloseTarget w
+    & tocr %~ setViewPos w
+    & tocr %~ setMvPosToTargetCr w
+    & tocr %~ chaseCritMv w
+    & tocr %~ perceptionUpdate [0] w
+    & tocr %~ targetYouWhenCognizant w
+    & tocr %~ searchIfDamaged
+    & tocr . crType . meleeCooldown %~ max 0 . subtract 1
+    & tocr . crVocalization %~ updateVocTimer
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+
+
 hoverCritHoverSound :: Creature -> World -> World
-hoverCritHoverSound cr w = fromMaybe w $ do
-    guard $ d < 100
-    return $
-        soundContinueVol
-            (0.5 * (1 - 0.01 * d))
-            (CrSound cid)
-            cxy
-            buzz1S
-            (Just 2)
-            w
+hoverCritHoverSound cr w
+    | d < 100 
+        = soundContinueVol (0.5 * (1 - 0.01 * d)) (CrSound cid) cxy buzz1S (Just 2) w
+    | otherwise = w
   where
     cxy = cr ^. crPos . _xy
     d = max 0 (dist (you w ^. crPos . _xy) cxy - 100)
@@ -90,73 +525,85 @@ 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 > -200 && null (cr ^. crDeathTimer)
-        -> w & tocr %~ startDeathTimer
-    HP x | x > -200 
-        ,Just y <- cr ^. crDeathTimer
-        , y > 0 ->
-            w
-                & tocr . crDamage .~ []
-                & tocr . crDeathTimer . _Just -~ 1
+    HP x | x > 0 -> w
+    HP x | x > -200 && null (cr ^. crDeathTimer) -> w & tocr %~ startDeathTimer
+    HP x
+        | x > -200
+        , Just y <- cr ^. crDeathTimer
+        , y > 0 -> w & 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 
+        | Just x <- cr ^? crType . beeLifespan
+        ,   x < 1 = id
+        | otherwise = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos) (cr ^. crPos - cr ^. crOldPos) 200
+
 startDeathTimer :: Creature -> Creature
-startDeathTimer cr = cr
-    & crDeathTimer ?~ case cr ^. crType of
-        HoverCrit {} -> 0
-        _ -> 5
+startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
+            HoverCrit{} -> 0
+            BeeCrit{} -> 0
+            _ -> 5
 
 toDeathCarriage :: Carriage -> Carriage
 toDeathCarriage = \case
-    Flying {} -> Falling
-    Walking -> OnGround
-    _ -> Falling
+    Flying{} -> Falling Q.qid Q.qid
+    Walking -> OnGround Q.qid
+    _ -> 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
-    Just CookingDamage ->
-        sethp (CrIsCorpse $ scorchSPic thecorpse)
-            . dodeathsound CookDeath
-    Just PoisonDamage ->
-        sethp (CrIsCorpse $ poisonSPic thecorpse)
-            . dodeathsound PoisonDeath
-    Just PhysicalDamage
-        | _crPain cr > 300 ->
-            makeCrGibs cr
-                . sethp (CrDestroyed Gibbed)
-                . dodeathsound GibsDeath
-    _ ->
-        sethp (CrIsCorpse thecorpse)
-            . dodeathsound PlainDeath
+corpseOrGib cr w =
+    w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
+        Just CookingDamage ->
+            sethp (CrIsCorpse $ scorchSPic thecorpse)
+                . dodeathsound CookDeath
+        Just PoisonDamage ->
+            sethp (CrIsCorpse $ poisonSPic thecorpse)
+                . dodeathsound PoisonDeath
+        Just PhysicalDamage
+            | _crPain cr > 300 ->
+                makeCrGibs cr
+                    . (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature)
+                    . dodeathsound GibsDeath
+        _ ->
+            sethp (CrIsCorpse thecorpse)
+                . dodeathsound PlainDeath
   where
     dodeathsound dt = f dt . stopSoundFrom (CrMouth cid)
-    f dt w = fromMaybe w $ do
-        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w)
+    f dt w' = fromMaybe w' $ do
+        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 (w ^. randGen) cr
 
 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
@@ -168,11 +615,6 @@ poisonSPic = _1 %~ overColSH (mixColors 0.5 0.5 green . normalizeColor)
 dropAll :: Creature -> World -> World
 dropAll cr w = foldl' (flip (dropItem cr)) w . reverse . IM.keys . _unNIntMap $ _crInv cr
 
---startFalling :: Creature -> Creature
---startFalling cr = case cr ^. crStance . carriage of
---    Walking -> cr & crStance . carriage .~ Falling
---    _ -> cr & crStance . carriage .~ Falling
-
 updatePulse :: Pulse -> Pulse
 updatePulse p
     | p ^. pulseProgress >= p ^. pulseRate = p & pulseProgress .~ 0

src/Dodge/Creature/Vocalization.hs

@@ -26,21 +26,31 @@ 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
     Avatar{} -> mempty
     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/Creature/Volition.hs

@@ -1,38 +0,0 @@
--- | Not a good name, perhaps: internal creature actions.
-module Dodge.Creature.Volition (
-    holsterWeapon,
-    drawWeapon,
-    shootTillEmpty,
-    shootFirstMiss,
-) where
-
-import Dodge.Data.Creature
-import Dodge.Data.CreatureEffect
-import Dodge.SoundLogic.LoadSound
-import Geometry
-
-holsterWeapon, drawWeapon :: Action
-holsterWeapon = DoImpulses [ChangePosture AtEase, MakeSound whiteNoiseFadeOutS]
-drawWeapon = DoImpulses [ChangePosture Aiming, MakeSound whiteNoiseFadeInS]
-
-shootTillEmpty :: Action
---shootTillEmpty = (crCanShoot `DoActionWhile` DoImpulses [UseItem])
-shootTillEmpty =
-    (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem])
-        `DoActionThen` 20 `WaitThen` holsterWeapon
-
---advanceShoot :: Int -> Action
---advanceShoot tcid = lostest `DoActionWhile`
---    advanceShoot' `DoActionThen`
---    75 `DoReplicate`
---    advanceShoot'
---  where
---    lostest (w,cr) = canSee (_crID cr) tcid w
---    advanceShoot' = ImpulsesList [[UseItem, MoveForward 3]]
-
-shootFirstMiss :: Action
-shootFirstMiss =
-    LeadTarget (V2 30 50)
-        `DoActionThen` DoImpulses [UseItem]
-        `DoActionThen` (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0), DoImpulses [UseItem]])
-        `DoActionThen` 20 `WaitThen` holsterWeapon

src/Dodge/Creature/YourControl.hs

@@ -38,8 +38,8 @@ handleHotkeys :: World -> World
 handleHotkeys w
     | ispressed SDL.ScancodeLShift || ispressed SDL.ScancodeRShift
     , (hk : _) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
-    , Just invid <- lw ^? creatures . ix 0 . crManipulation . manObject . imSelectedItem
-    , Just itid <- lw ^? creatures . ix 0 . crInv . ix invid =
+    , Just (Sel 0 invid) <- w ^. hud .diSelection
+    , Just itid <- lw ^? creatures . ix 0 . crInv . ix (NInt invid) =
         w & cWorld . lWorld %~ assignHotkey (NInt itid) hk
     | ispressed SDL.ScancodeLCtrl || ispressed SDL.ScancodeRCtrl
     , (hk : _) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
@@ -106,7 +106,7 @@ scancodeToHotkey = \case
 wasdWithAiming :: World -> Creature -> Creature
 wasdWithAiming w cr 
     | Walking <- cr ^. crStance . carriage 
-        = wasdAim inp w $ wasdMovement (w ^. cWorld . lWorld) inp cam speed cr
+        = wasdAim inp w $ wasdMovement w inp cam speed cr
     | otherwise = cr
   where
     speed = _mvSpeed $ crMvType cr
@@ -116,17 +116,15 @@ wasdWithAiming w cr
 wasdAim :: Input -> World -> Creature -> Creature
 wasdAim inp w cr
     | SDL.ButtonRight `M.member` _mouseButtons inp
-    , AtEase <- cr ^. crStance . posture =
-        setposture Aiming (-twoHandTwistAmount)
-    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn (w ^. cWorld . lWorld) mousedir cr
-    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twoHandTwistAmount
---    | otherwise = creatureTurnTowardDir (_crMvAim cr) 0.2 cr
+    , AtEase <- cr ^. crStance . posture = setposture Aiming (-twistAmount)
+    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn w mousedir cr
+    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twistAmount
     | otherwise = creatureTurnTowardDir (_crMvDir cr) 0.2 cr
   where
     setposture x r =
         cr
             & crStance . posture .~ x
-            & doAimTwist (cr ^? crManipulation . manObject . imAimStance) r
+            & doAimTwist (w ^? hud . manObject . hiAimStance) r
     mousedir = argV $ w ^. cWorld . lWorld . lAimPos - (cr ^. crPos . _xy)
 
 doAimTwist :: Maybe AimStance -> Float -> Creature -> Creature
@@ -134,11 +132,11 @@ doAimTwist as x
     | as == Just TwoHandTwist = crDir +~ x
     | otherwise = id
 
-twoHandTwistAmount :: Float
-twoHandTwistAmount = 1.6 * pi
+twistAmount :: Float
+twistAmount = 1.6 * pi
 
-wasdMovement :: LWorld -> Input -> Camera -> Float -> Creature -> Creature
-wasdMovement lw inp cam speed = theMovement -- . setMvAim
+wasdMovement :: World -> Input -> Camera -> Float -> Creature -> Creature
+wasdMovement w inp cam speed = theMovement -- . setMvAim
   where
 --    setMvAim = fromMaybe id $ do
 --        dir <- safeArgV movDir
@@ -147,14 +145,14 @@ wasdMovement lw inp cam speed = theMovement -- . setMvAim
     movAbs = rotateV (cam ^. camRot) $ normalizeV movDir
     theMovement
         | movDir == V2 0 0 = id
-        | otherwise = crMvAbsolute lw (speed *^ movAbs)
+        | otherwise = crMvAbsolute w (speed *^ movAbs)
 
-aimTurn :: LWorld -> Float -> Creature -> Creature
+aimTurn :: World -> Float -> Creature -> Creature
 aimTurn lw a cr = creatureTurnTowardDir a (x * 0.2) cr
   where
     x = fromMaybe 1 $ do
-        itRef <- cr ^? crManipulation . manObject . imRootSelectedItem
-        fmap itemBulkiness $ cr ^? crInv . ix itRef >>= \k -> lw ^? items . ix k . itType
+        itRef <- lw ^? hud . manObject . hiRootSelectedItem
+        fmap itemBulkiness $ cr ^? crInv . ix itRef >>= \k -> lw ^?cWorld.lWorld. items . ix k . itType
 
 itemBulkiness :: ItemType -> Float
 itemBulkiness = \case
@@ -209,14 +207,6 @@ tryClickUse pkeys w = fromMaybe w $ do
     ltime <- pkeys ^? ix SDL.ButtonLeft
     rtime <- pkeys ^? ix SDL.ButtonRight
     guard $ ltime <= rtime
-    case w
-        ^? cWorld
-        . lWorld
-        . creatures
-        . ix 0
-        . crManipulation
-        . manObject
-        . imSelectedItem
-        . unNInt of
-        Just invid -> useItem invid ltime w
-        Nothing -> interactWithCloseObj <$> getSelectedCloseObj w ?? w
+    case w ^.hud.diSelection of
+        Just (Sel 0 invid) -> useItem invid ltime w
+        _ -> interactWithCloseObj <$> getSelectedCloseObj w ?? w

src/Dodge/CreatureEffect.hs

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

src/Dodge/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,17 +13,19 @@ import Sound.Data
 
 data ActionPlan
     = Inanimate
+    | SlimeIntelligence
     | ActionPlan
         { -- _apImpulse :: [Impulse] -- done per frame
-         _apAction :: [Action] -- updated per frame, likely persist across frames
-        , _apStrategy :: Strategy -- current strategy
-        , _apGoal :: [Goal] -- particular ordered goals
+         _apAction :: Action -- updated per frame, likely persist across frames
+        , _apStrategy :: Strategy
+        , _apGoal :: Goal
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data Impulse
     = Move Point2
+    | Walk Point2
     | MoveForward Float
     | MoveNoStride Point2
     | Turn Float
@@ -38,12 +40,16 @@ data Impulse
     | DropItem
     | Bark SoundID -- placeholder for various communication types
     | Melee Int
+    | MeleeL Int
+    | MeleeR Int
     | ChangePosture Posture
     | MakeSound SoundID
     | ChangeStrategy Strategy
-    | AddGoal Goal
+--    | AddGoal Goal
     | ImpulseUseTarget { _impulseUseTarget :: CrImp }
     | ImpulseNothing
+    | UpdateRandGen
+    | SetBeeRandomMovement
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data RandImpulse
@@ -56,7 +62,7 @@ infixr 9 `WaitThen`
 
 infixr 9 `DoActionThen`
 
-infixr 9 `DoActionWhile`
+--infixr 9 `DoActionWhile`
 
 infixr 9 `DoReplicate`
 
@@ -68,17 +74,15 @@ data Action
         , _targetSeenAt :: Point2
         }
     | PathTo { _pathToPoint :: Point2, _pathFailAction :: Action }
+    | Eat {_targetID :: Int, _acTimer :: Int}
+    | EvadeAim
     | TurnToPoint { _turnToPoint :: Point2 }
-    | ImpulsesList { _impulsesListList :: [[Impulse]] }
+    | ImpulsesList { _impulsesListList :: [[Impulse]], _acAction :: Action }
     | DoImpulses { _doImpulsesList :: [Impulse] }
     | WaitThen
         { _waitThenTimer :: Int
         , _waitThenAction :: Action
         }
-    | DoActionWhile
-        { _doActionWhileCondition :: WdCrBl
-        , _doActionWhileAction :: Action
-        }
     | DoActionWhilePartial
         { _doActionWhilePartial :: Action
         , _doActionWhileCondition :: WdCrBl
@@ -98,7 +102,7 @@ data Action
         , _doActionWhileThenCondition :: WdCrBl
         , _doActionWhileThenThen :: Action
         }
-    | DoActions { _doActionsList :: [Action] }
+--    | DoActions { _doActionsList :: [Action] }
     | DoActionThen
         { _doActionThenFirst :: Action
         , _doActionThenSecond :: Action
@@ -114,9 +118,6 @@ data Action
         }
     | LeadTarget { _leadTargetBy :: Point2 }
     | NoAction
-    | StartSentinelPost
-    | UseSelf { _useSelf :: CrAc }
-    | ArbitraryAction {_arbitraryAction :: CrWdAc}
 -- | Repeatedly perform impulses alongside a main action until the main action terminates
     | DoImpulsesAlongside
         { _sideImpulses :: [Impulse]
@@ -131,24 +132,26 @@ data Strategy
     | Lure Int Point2
     | Patrol [Point2]
     | ShootAt Int
-    | FollowImpulses
+--    | FollowImpulses
     | WatchAndWait
     | Investigate
     | WarningCry
     | LookAround
     | Wander
     | CloseToMelee {_meleeTarget :: Int}
-    | StrategyActions Strategy [Action]
     | GetTo Point2
-    | Reload
-    | Flee
-    | MeleeStrike
     | Search
+    | SearchTimed {_searchTimer :: Int}
+    | ReturnToHive
+    | HarvestFrom {_harvestTarget :: Int}
+    | StrategyInt {_strategyInt :: Int}
     deriving (Eq, Ord, Show) --Generic, Flat)
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Goal
     = LiveLongAndProsper
+    | SearchForFood
+    | Flee
     | Kill {_killTarget :: Int}
     | SentinelAt {_sentinelPos :: Point2, _sentinelDir :: Float}
     deriving (Eq, Ord, Show) --Generic, Flat)

src/Dodge/Data/Bullet.hs

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

src/Dodge/Data/CamouflageStatus.hs

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

src/Dodge/Data/CardinalPoint.hs

@@ -44,4 +44,9 @@ data CardinalCover
 data XInfinity a = NegInf | NonInf {_nonInf :: a} | PosInf
     deriving (Eq, Ord, Show)
 
+instance Functor XInfinity where
+    fmap f (NonInf x) = NonInf (f x)
+    fmap _ NegInf = NegInf
+    fmap _ PosInf = PosInf
+
 makeLenses ''XInfinity

src/Dodge/Data/Cloud.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Cloud where
 
+import Dodge.Data.Damage
 import Dodge.Data.Material
 import Control.Lens
 import Data.Aeson
@@ -36,15 +37,24 @@ data Gas = Gas
     , _gsVel :: Point3
     , _gsTimer :: Int
     , _gsType :: GasType
+    , _gsOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data GasType = PoisonGas
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+data BeePheremone = BPheremone
+    { _bpPos :: Point3
+    , _bpVel :: Point3
+    , _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/Config.hs

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

src/Dodge/Data/Creature.hs

@@ -42,7 +42,7 @@ data Creature = Creature
     , _crID :: Int
     , _crHP :: CrHP
     , _crInv :: NewIntMap InvInt Int
-    , _crManipulation :: Manipulation
+--    , _crManipulation :: Manipulation
     , _crEquipment :: M.Map EquipSite (NewInt ItmInt)
     , _crDamage :: [Damage]
     , _crPain :: Int
@@ -63,9 +63,16 @@ data Creature = Creature
 data CrHP
     = HP Int
     | CrIsCorpse SPic
-    | CrDestroyed CrDestructionType
+    | AvatarDestroyed
+--    | CrDestroyed CrDestructionType
 
-data CrDestructionType = Gibbed | Pitted
+destroyCreature :: Maybe Creature -> Maybe Creature
+destroyCreature mcr
+    | Just cr <- mcr
+    , _crID cr == 0 = Just cr{_crHP = AvatarDestroyed}
+    | otherwise = Nothing
+
+data CrDestructionType = Gibbed | Pitted | Swallowed
 
 data DeathType = CookDeath | PoisonDeath | PlainDeath | GibsDeath
 

src/Dodge/Data/Creature/Misc.hs

@@ -1,20 +1,17 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Dodge.Data.Creature.Misc (
-    module Dodge.Data.Creature.Misc,
-    module Dodge.Data.CamouflageStatus,
-) where
+module Dodge.Data.Creature.Misc (module Dodge.Data.Creature.Misc) where
 
 import Dodge.Data.Creature.Stance
 import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import Dodge.Data.CamouflageStatus
 import Dodge.Data.FloatFunction
 import Dodge.Data.Material
 import Geometry.Data
+import qualified Data.IntSet as IS
 
 data Vocalization
     = VocTimer {_vcTime :: Int ,_vcMaxTime :: Int }
@@ -25,16 +22,21 @@ 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
---        { _mvAcc :: Float
---        , _mvTopSpeed :: Float
---        }
+    | StartStopMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
+    | BeeMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Pulse = PulseStatus
@@ -57,13 +59,72 @@ data CreatureType
     | ChaseCrit {_meleeCooldown :: Int
         , _footForward :: FootForward
         , _strideAmount :: Float
+        , _chaseqy0 :: Float
+        , _chaseqy1 :: Float
+        , _chaseqy2 :: Float
+        , _chaseqy3 :: Float
+        , _chaseqz :: Float
+        , _chaseLerp :: Int
+        , _chaseKState :: ChaseKState
+        }
+    | CrabCrit 
+        { _meleeCooldownL :: Int
+        , _meleeCooldownR :: Int
+        , _dodgeCooldown :: Int
+        , _lFootPos :: Point2
+        , _rFootPos :: Point2
         }
     | HoverCrit {_meleeCooldown :: Int}
+    | SlinkCrit 
+        { _meleeCooldown :: Int
+        , _slinkSpine :: [Point3Q]
+        , _slinkHeadPos :: Point3Q
+        }
+    | SlimeCrit
+        { _slimeSlime :: Int -- note multiplied by 100
+        , _slimeSlimeChange :: Int
+--        , _slimeRadWobble :: Float
+        --, _slimeSplitTimer :: Int
+        , _slimeDistortion :: SlimeShapeDistortion
+        , _slimeCompression :: Float
+        , _slimeIsCompressing :: Bool
+        , _slimeEngulfProgress :: Float
+        } 
+    | BeeCrit
+        { _beeSlime :: Int
+        , _beeHive :: Maybe Int
+        , _startStopMv :: Int
+        , _beeAggro :: Int
+        , _meleeCooldown :: Int
+        , _beeRandomMovement :: Maybe FootForward
+        , _beeLifespan :: Int
+        }
+    | HiveCrit
+        { _hiveChildren :: IS.IntSet
+        , _hiveGestation :: Int
+        , _hiveSlime :: Int
+        }
     | SwarmCrit
     | AutoCrit
     | BarrelCrit {_barrelType :: BarrelType}
     | LampCrit {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int}
 
+data ChaseKState
+    = UprightCK
+    | AimingCK Int
+    | PeckingCK Int
+    deriving (Eq)
+
+data SlimeShapeDistortion = SlimeDistortion
+    { _sdTime :: Int
+    , _sdShape :: [Point2]
+    , _sdIsSplit :: Bool
+    }
+    | NoSlimeDistortion
+
+slimeToRad :: Int -> Float
+slimeToRad x = sqrt $ fromIntegral x * 0.01
+
 data AvatarPosture = AvPosture
 
 data CreatureShape
@@ -73,7 +134,7 @@ data CreatureShape
         , _skinLower :: Color
         }
     | Barreloid
-    | NonDrawnCreature
+    | NoCreatureShape
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BarrelType
@@ -87,6 +148,9 @@ makeLenses ''Vocalization
 makeLenses ''CrMvType
 makeLenses ''CreatureType
 makeLenses ''CreatureShape
+makeLenses ''SlimeShapeDistortion
+deriveJSON defaultOptions ''ChaseKState
+deriveJSON defaultOptions ''SlimeShapeDistortion
 deriveJSON defaultOptions ''Pulse
 deriveJSON defaultOptions ''Vocalization
 deriveJSON defaultOptions ''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 
-    | OnGround
+    | Falling {_fallRot :: Quaternion Float, _carDir :: Quaternion Float}
+    | 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/CreatureEffect.hs

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

src/Dodge/Data/Damage.hs

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

src/Dodge/Data/EnergyBall.hs

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

src/Dodge/Data/EnergyBall/Type.hs

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

src/Dodge/Data/Flame.hs

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

src/Dodge/Data/HUD.hs

@@ -3,13 +3,14 @@
 
 module Dodge.Data.HUD where
 
+import Dodge.Data.Item.Use.Consumption.LoadAction
 import Control.Lens
-import qualified Data.IntSet as IS
 import Dodge.Data.Combine
 import Dodge.Data.Item.Location
 import Dodge.Data.SelectionList
 import Geometry.Data
 import NewInt
+import qualified Data.IntMap.Strict as IM
 
 data SubInventory
     = NoSubInventory
@@ -32,11 +33,14 @@ data HUD = HUD
     , _diSelection :: Maybe Selection
     , _diInvFilter :: Maybe String
     , _diCloseFilter :: Maybe String
-    , _closeItems :: [NewInt ItmInt]
+    , _closeItems :: [NewInt ItmInt]  -- add bool showing whether in ssSet?
     , _closeButtons :: [Int]
+    , _manObject :: ManipulatedObject
+    , _closeItemsInv :: IM.IntMap Int
     }
 
-data Selection = Sel {_slSec :: Int, _slInt :: Int, _slSet :: IS.IntSet}
+data Selection = Sel {_slSec :: Int, _slInt :: Int}
+  deriving (Eq,Show)
 
 makeLenses ''HUD
 makeLenses ''Selection

src/Dodge/Data/Input.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Input where
 
+import Dodge.Data.CardinalPoint
 import Dodge.Data.Config
 import Dodge.Data.Terminal.Status
 import Control.Lens
@@ -14,10 +15,9 @@ data MouseContext
     = NoMouseContext
     | MouseAiming
     | MouseInGame
-    | MouseMenuClick {_mcoMenuClick :: Int}
-    | MouseMenuCursor
-    | OverInvDrag {_mcoDragSection :: Int , _mcoMaybeSelect :: Maybe (Int,Int) }
-    | OverInvDragSelect { _mcoSecSelStart :: Maybe (Int,Int), _mcoSelEnd :: Maybe Int }
+    | MouseMenu {_mcoMenuClick :: Maybe Int}
+    | OverInvDrag {_mcoDragSection :: Int }
+    | OverInvDragSelect { _mcoSecSelStart :: XInfinity (Int,Int) }
     | OverInvSelect { _mcoInvSelect :: (Int,Int)}
     | OverCombFiltInv { _mcoInvFilt :: (Int,Int)}
     | OverCombSelect { _mcoCombSelect :: (Int,Int)}

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/Item/Location.hs

@@ -29,25 +29,17 @@ data ItemLocation
     = InInv
         { _ilCrID :: Int
         , _ilInvID :: NewInt InvInt
-        , _ilIsRoot :: Bool -- of any item
-        , _ilIsSelected :: Bool
-        , _ilIsAttached :: Bool -- to selected item.  question: downwards and upwards?
         , _ilEquipSite :: Maybe EquipSite
         }
     | OnTurret {_ilTuID :: Int}
-    | OnFloor -- {_ilFlID :: NewInt FloorInt}
+    | OnFloor 
     | InVoid
     deriving (Eq, Show, Ord, Read) --Generic, Flat)
 
 instance ShortShow ItemLocation where
-    shortShow (InInv cid invid rootb selb attb esite) =
+    shortShow (InInv cid invid esite) =
         "InInv:cid" <> shortShow cid <> "invid" <> shortShow (_unNInt invid)
-            <> "root"
-            <> shortShow rootb
-            <> "sel"
-            <> shortShow selb
-            <> "att"
-            <> shortShow attb
+            <> "esite"
             <> shortShow (fmap (SString . show) esite)
     shortShow x = show x
 

src/Dodge/Data/Item/Use/Consumption/LoadAction.hs

@@ -10,29 +10,14 @@ import qualified Data.IntSet as IS
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
---import Sound.Data
-
-data Manipulation -- should be ManipulatedObject?
-    = Manipulator {_manObject :: ManipulatedObject }
-    | Brute
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data ManipulatedObject
-    = SortInventory
-    | SelectedItem
-        { _imSelectedItem :: NewInt InvInt
-        , _imRootSelectedItem :: NewInt InvInt
-        , _imAimStance :: AimStance
-        , _imAttachedItems :: IS.IntSet -- this should probably be NewIntSet InvInt also
+    = HeldItem
+        { _hiRootSelectedItem :: NewInt InvInt
+        , _hiAimStance :: AimStance
+        , _hiAttachedItems :: IS.IntSet -- this should probably be NewIntSet InvInt also
         }    
-    | SelNothing
-    | SortCloseItem
-    | SelCloseItem {_ispCloseItem :: Int}
-    | SortCloseButton
-    | SelCloseButton {_ispCloseButton :: Int}
-     deriving (Eq, Ord, Show, Read) --Generic, Flat)
+    | HandsFree
 
 makeLenses ''ManipulatedObject
-makeLenses ''Manipulation
 deriveJSON defaultOptions ''ManipulatedObject
-deriveJSON defaultOptions ''Manipulation

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
@@ -145,7 +146,7 @@ data LWorld = LWorld
     , _hotkeys :: M.Map Hotkey (NewInt ItmInt)
     , _imHotkeys :: NewIntMap ItmInt Hotkey
     , _lAimPos :: Point2
-    , _lInvLock :: Bool
+    , _lInvLock :: Bool -- used eg burstRifle fire
     , _respawnPos :: (Point2, Float)
     }
 

src/Dodge/Data/Laser.hs

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

src/Dodge/Data/PlasmaBall.hs

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

src/Dodge/Data/Projectile.hs

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

src/Dodge/Data/PulseLaser.hs

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

src/Dodge/Data/SelectionList.hs

@@ -10,6 +10,7 @@ import Dodge.Data.CardinalPoint
 import Dodge.Data.ScreenPos
 import Picture.Data
 import Linear
+import qualified Data.IntSet as IS
 
 data LDParams = LDP -- List display parameters
     { _ldpPos :: ScreenPos
@@ -30,10 +31,11 @@ data SectionCursor = SectionCursor
 
 data SelSection a = SelSection
     { _ssItems :: IntMap (SelectionItem a)
-    , _ssOffset :: Int
+    , _ssYOffset :: Int
     , _ssShownItems :: [Picture]
     , _ssShownLength :: Int
     , _ssIndent :: Int
+    , _ssSet :: IS.IntSet
     }
 
 type IMSS a = IntMap (SelSection a)

src/Dodge/Data/Shockwave.hs

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

src/Dodge/Data/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/TeslaArc.hs

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

src/Dodge/Data/World.hs

@@ -43,6 +43,7 @@ data World = World
     , _wSoundFilter :: SoundFilter
     , _input :: Input
     , _testFloat :: Float
+    , _testString :: String
     , _rbState :: RightButtonState
     , _hud :: HUD
     , _worldEventFlags :: Set WorldEventFlag

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/Debug.hs

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

src/Dodge/Default/Creature.hs

@@ -5,9 +5,10 @@ import qualified Data.Map.Strict as M
 import Dodge.Data.Creature
 import Dodge.Data.FloatFunction
 import Geometry.Data
---import qualified IntMapHelp as IM
---import Picture
---import MaybeHelp
+
+-- import qualified IntMapHelp as IM
+-- import Picture
+-- import MaybeHelp
 
 defaultCreature :: Creature
 defaultCreature =
@@ -15,50 +16,46 @@ defaultCreature =
         { _crPos = V3 0 0 0
         , _crOldPos = V3 0 0 0
         , _crOldOldPos = V3 0 0 0
---        , _crZ = 0
---        , _crZVel = 0
         , _crDir = 0
         , _crMvDir = 0
---        , _crMvAim = 0
---        , _crTwist = 0
         , _crID = 1
-        , _crType = ChaseCrit 0 LeftForward 0
---        , _crRad = 10
+        , _crType =
+            ChaseCrit
+                { _meleeCooldown = 0
+                , _footForward = LeftForward
+                , _strideAmount = 0
+                , _chaseqy0 = 0
+                , _chaseqy1 = 0.45 * pi
+                , _chaseqy2 = -0.9*pi
+                , _chaseqy3 = 0.45*pi
+                , _chaseqz = 0
+                , _chaseLerp = 0
+                , _chaseKState = UprightCK
+                }
         , _crHP = HP 100
---        , _crMaxHP = 150
         , _crInv = mempty
-        , _crManipulation = Manipulator SelNothing
---        , _crInvCapacity = 25
         , _crDamage = []
---        , _crCorpse = MakeDefaultCorpse
---        , _crMaterial = Flesh
         , _crPain = 0
---        , _crInvEquipped = mempty
         , _crEquipment = M.empty
---        , _crInvHotkeys = mempty
---        , _crHotkeys = M.empty
         , _crStance =
             Stance
                 { _carriage = Walking
                 , _posture = AtEase
                 }
         , _crVocalization = VocReady
-        , _crActionPlan = ActionPlan [] (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper]
+        , _crActionPlan = ActionPlan NoAction WatchAndWait LiveLongAndProsper
         , _crPerception = defaultPerceptionState
         , _crMemory = defaultCreatureMemory
         , _crFaction = NoFaction
         , _crIntention = defaultIntention
         , _crGroup = LoneWolf
---        , _crMvType = defaultAimMvType
---        , _crHammerPosition = HammerUp
         , _crName = "DEFAULTCRNAME"
---        , _crStatistics = CreatureStatistics 50 50 50
         , _crDeathTimer = Nothing
         , _crWallTouch = mempty
         }
 
---defaultCreatureSkin :: CreatureType
---defaultCreatureSkin = Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3) InanimateAI
+-- defaultCreatureSkin :: CreatureType
+-- defaultCreatureSkin = Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3) InanimateAI
 
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
@@ -104,15 +101,14 @@ defaultIntention =
         , _viewPoint = Nothing
         }
 
-
 defaultAimingCrit :: Creature
 defaultAimingCrit = defaultCreature
 
 yourDefaultStrideLength :: Float
 yourDefaultStrideLength = 35
 
---defaultState :: CreatureState
---defaultState =
+-- defaultState :: CreatureState
+-- defaultState =
 --    CrSt
 --        { _csDamage = []
 ----        , _csSpState = GenCr

src/Dodge/Default/World.hs

@@ -43,6 +43,7 @@ defaultWorld =
         , _playingSounds = M.empty
         , _randGen = mkStdGen 2
         , _testFloat = 0
+        , _testString = ""
         , _rbState = NoRightButtonState
         , _hud = defaultHUD
         , _worldEventFlags = mempty
@@ -114,6 +115,7 @@ defaultLWorld =
         , _creatures = IM.empty
         , _creatureGroups = IM.empty
         , _clouds = mempty
+        , _beePheremones = mempty
         , _gasses = mempty
         , _dusts = mempty
         , _gusts = IM.empty
@@ -176,9 +178,11 @@ defaultHUD =
     HUD
         { _subInventory = NoSubInventory
         , _diSections = mempty
-        , _diSelection = Just (Sel 1 0 mempty)
+        , _diSelection = Just (Sel 1 0)
         , _diInvFilter = mempty
         , _diCloseFilter = mempty
         , _closeItems = mempty
         , _closeButtons = mempty
+        , _manObject = HandsFree
+        , _closeItemsInv = mempty
         }

src/Dodge/DisplayInventory.hs

@@ -8,8 +8,10 @@ module Dodge.DisplayInventory (
     updateInventoryPositioning,
     updateCombinePositioning,
     toggleCombineInv,
+    plainRegex,
 ) where
 
+import qualified Data.IntSet as IS
 import Control.Applicative
 import Control.Lens
 import Control.Monad
@@ -95,16 +97,15 @@ checkInventorySelectionExists w
     | isJust $ w ^? hud . diSections . ix i . ssItems . ix j = w
     | otherwise = scrollAugNextInSection w
   where
-    Sel i j _ = fromMaybe (Sel 1 (-1) mempty) $ w ^? hud . diSelection . _Just
+    Sel i j = fromMaybe (Sel 1 (-1)) $ w ^? hud . diSelection . _Just
 
 checkCombineSelectionExists :: SubInventory -> SubInventory
 checkCombineSelectionExists si
     | Just sss <- si ^? ciSections
-      , Sel i j _ <- fromMaybe (Sel 0 0 mempty) $ si ^? ciSelection . _Just
+      , Sel i j <- fromMaybe (Sel 0 0) $ si ^? ciSelection . _Just
       , isNothing $ si ^? ciSections . ix i . ssItems . ix j =
-        si & ciSelection ?~ Sel 0 (-1) mempty
-            & ciSelection
-            %~ scrollSelectionSections (-1) sss
+        si & ciSelection ?~ Sel 0 (-1)
+            & ciSelection %~ scrollSelectionSections (-1) sss
     | otherwise = si
 
 displayIndents :: Int -> Int
@@ -246,27 +247,27 @@ updateSectionsPositioning ::
     IM.IntMap (SelSection a) ->
     IM.IntMap (SelSection a)
 updateSectionsPositioning h mselpos allavailablelines lsss sss =
-    IM.intersectionWithKey (\k -> updateSection (h k) (m k)) ls ssizes `g` offsets
+    IM.intersectionWithKey (\k -> updateSection (h k) (m k)) lsss ssizes `g` offsets
   where
-    offsets = fmap _ssOffset sss
+    offsets = fmap (\ss -> (ss^.ssYOffset, ss^.ssSet)) sss
     m k = do
-        Sel k' i _ <- mselpos
+        Sel k' i <- mselpos
         guard $ k == k'
         return i
-    ls = lsss
     -- defaults non-existing offsets to 0
-    g = merge (mapMissing (const ($ 0))) dropMissing (zipWithMatched (const ($)))
+    g = merge (mapMissing (const ($ (0,mempty)))) dropMissing (zipWithMatched (const ($)))
     lk = mselpos ^.. _Just . slSec
-    ssizes = sectionsSizes allavailablelines lk $ sectionsDesiredLines ls
+    ssizes = sectionsSizes allavailablelines lk $ sectionsDesiredLines lsss
 
-updateSection :: Int -> Maybe Int -> IMSI a -> Int -> Int -> SelSection a
-updateSection indent mcsel sis availablelines oldoffset =
+updateSection :: Int -> Maybe Int -> IMSI a -> Int -> (Int,IS.IntSet) -> SelSection a
+updateSection indent mcsel sis availablelines (oldoffset,sset) =
     SelSection
         { _ssItems = sis
-        , _ssOffset = offset
+        , _ssYOffset = offset
         , _ssShownItems = shownitems
         , _ssShownLength = min aslength availablelines
         , _ssIndent = indent
+        , _ssSet = sset
         }
   where
     shownitems = tweakfirst . tweaklast $ take availablelines shownstrings
@@ -323,8 +324,7 @@ enterCombineInv cfig w =
     w & hud . subInventory
         .~ CombineInventory
             { _ciSections = updateCombineSections w cfig mempty
-            , _ciSelection = Just (Sel 0 0 mempty)
+            , _ciSelection = Just (Sel 0 0)
             , _ciFilter = Nothing
             }
-        & hud . diInvFilter
-        .~ Nothing
+        & hud . diInvFilter .~ Nothing

src/Dodge/EnergyBall.hs

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

src/Dodge/EnergyBall/Draw.hs

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

src/Dodge/Euse.hs

@@ -62,12 +62,12 @@ useMagShield mt _ cr w =
 --    _ -> w
 
 createHeadLamp :: Item -> Creature -> World -> World
-createHeadLamp _ cr =
+createHeadLamp _ cr w = w &
     cWorld
         . lWorld
         . lights
         .:~ LSParam
-            (_crPos cr + rotate3z (_crDir cr) (translateToES cr OnHead (V3 5 0 3)))
+            (_crPos cr + rotate3z (_crDir cr) (translateToES w cr OnHead (V3 5 0 3)))
             200
             0.7
 
@@ -122,7 +122,7 @@ setWristShieldPos itm cr esite w = w & moveWallIDUnsafe i wlline
         . itLocation
         . ilEquipSite
         . _Just of
-        Just x -> translateToES cr x -- . g
+        Just x -> translateToES w cr x -- . g
         _ -> undefined
     --    g
     --        | twists cr = (+.+.+ V3 (-5) 10 0)

src/Dodge/Flame.hs

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

src/Dodge/FloorItem.hs

@@ -14,10 +14,12 @@ import System.Random
 copyItemToFloor :: Point2 -> Item -> World -> World
 copyItemToFloor p it w =
     w'
-        & cWorld . lWorld . floorItems . at (it ^. itID . unNInt) ?~ FlIt q r
-        & cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor)
+        & cWorld . lWorld . floorItems . at i ?~ FlIt q r
+        & cWorld . lWorld . items . at i ?~ (it & itLocation .~ OnFloor)
         & hud . closeItems .:~ _itID it -- puts item at top of close items
+        & cWorld . highlightItems . at i ?~ 20
   where
+    i = it ^. itID . unNInt
     (q, w') = findWallFreeDropPoint (_dimRad $ itDim it) p w
     r = fst . randomR (- pi, pi) $ _randGen w
 

src/Dodge/Gas.hs

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

src/Dodge/HeldUse.hs

@@ -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
@@ -454,8 +454,7 @@ itemSidePush = \case
 
 applyInvLock :: Item -> Creature -> World -> World
 applyInvLock itm cr = case itemInvLock itm of
-    i
-        | i > 0 && cid == 0 ->
+    i | i > 0 && cid == 0 ->
             (cWorld . lWorld . delayedEvents .:~ (i, UnlockInv)) . lockInv
     _ -> id
   where
@@ -470,7 +469,7 @@ heldItemInvLock :: HeldItemType -> Int
 heldItemInvLock = \case
     FLAMESPITTER -> 10
     VOLLEYGUN i -> i + 1
-    BURSTRIFLE -> 70
+    BURSTRIFLE -> 8
     _ -> 0
 
 applySoundCME :: Item -> Creature -> World -> World
@@ -484,12 +483,12 @@ applySoundCME itm cr = fromMaybe id $ do
     cid = _crID cr
 
 applyRecoil :: LocationDT OItem -> Creature -> World -> World
-applyRecoil loc cr =
+applyRecoil loc cr w = w &
     cWorld . lWorld . creatures . ix (_crID cr) . crPos . _xy
         +~ rotateV (_crDir cr + Q.qToAng q) (V2 ((- recoilAmount itm) / crMass (_crType cr)) 0)
   where
     itm = loc ^. locDT . dtValue . _1
-    (_, q) = locOrient loc cr
+    (_, q) = locOrient w loc cr
 
 recoilAmount :: Item -> Float
 recoilAmount itm
@@ -743,11 +742,11 @@ useLoadedAmmo
 useLoadedAmmo loc cr mz m w =
     makeMuzzleFlare pq loc (mz ^. mzFlareType) $ case _mzEffect mz of
         MuzzleShootBullet -> shootBullets loc cr (mz, x, magtree) w
-        MuzzleLaser -> creatureShootLaser pq' loc (w & randGen .~ g)
+        MuzzleLaser -> creatureShootLaser (CrWeaponO (cr ^. crID)) pq' loc (w & randGen .~ g)
         MuzzlePulseLaser -> creatureShootPulseLaser pq' cr (w & randGen .~ g)
-        MuzzlePulseBall -> shootPulseBall pq' (w & randGen .~ g)
-        MuzzlePlasmaBall -> shootPlasmaBall pq' (w & randGen .~ g)
-        MuzzleTesla -> shootTeslaArc pq' loc (w & randGen .~ g)
+        MuzzlePulseBall -> shootPulseBall o pq' (w & randGen .~ g)
+        MuzzlePlasmaBall -> shootPlasmaBall o pq' (w & randGen .~ g)
+        MuzzleTesla -> shootTeslaArc o pq' loc (w & randGen .~ g)
         MuzzleTractor -> shootTractorBeam cr w
         MuzzleRLauncher -> createProjectileR pq loc magtree cr w
         MuzzleGLauncher ->
@@ -776,29 +775,30 @@ useLoadedAmmo loc cr mz m w =
         MuzzleStopper -> useStopWatch itm cr w
         MuzzleScroller -> useTimeScrollGun itm cr w
   where
-    pq = muzzlePos loc cr mz
-    (pq', g) = muzzleRandPos loc cr mz `runState` (w ^. randGen)
+    o = CrWeaponO $ cr ^. crID
+    pq = muzzlePos w loc cr mz
+    (pq', g) = muzzleRandPos w loc cr mz `runState` (w ^. randGen)
     itmtree = loc ^. locDT
     mitid = magtree ^. dtValue . _1 . itID
     itm = itmtree ^. dtValue . _1
     (x, magtree) = fromJust m
 
-muzzlePos :: LocationDT OItem -> Creature -> Muzzle -> Point3Q
-muzzlePos m cr muz = (p1, q1) `Q.comp` pq `Q.comp` (p3, q3)
+muzzlePos :: World -> LocationDT OItem -> Creature -> Muzzle -> Point3Q
+muzzlePos w m cr muz = (p1, q1) `Q.comp` pq `Q.comp` (p3, q3)
   where
-    pq = locOrient m cr
+    pq = locOrient w m cr
     p1 = cr ^. crPos
     q1 = Q.qz $ cr ^. crDir
     p3 = addZ 0 $ muz ^. mzPos
     q3 = Q.qz $ muz ^. mzRot
 
-muzzleRandPos :: LocationDT OItem -> Creature -> Muzzle -> State StdGen Point3Q
-muzzleRandPos m cr muz = do
+muzzleRandPos :: World -> LocationDT OItem -> Creature -> Muzzle -> State StdGen Point3Q
+muzzleRandPos w m cr muz = do
     a <- state $ randomR (- inacc, inacc)
     y <- case muz ^. mzRandomOffset of
         0 -> return 0
         i -> state $ randomR (- i, i)
-    return $ muzzlePos m cr muz `Q.comp` (V3 0 y 0, Q.qz a)
+    return $ muzzlePos w m cr muz `Q.comp` (V3 0 y 0, Q.qz a)
   where
     inacc = _mzInaccuracy muz
 
@@ -856,9 +856,10 @@ tractorBeamAt pos outpos dir power =
         , _tbTime = 10
         }
 
-creatureShootLaser :: Point3Q -> LocationDT OItem -> World -> World
-creatureShootLaser (p, q) loc =
+creatureShootLaser :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
+creatureShootLaser o (p, q) loc =
     shootLaser
+        o
         (ItemSound (loc ^. locDT . dtValue . _1 . itID . unNInt) 0)
         (getLaserDamage loc)
         (getLaserPhaseV loc)
@@ -866,6 +867,7 @@ creatureShootLaser (p, q) loc =
         (Q.qToAng q)
 
 shootLaser ::
+    DamageOrigin ->
     SoundOrigin ->
     LaserType ->
     Float ->
@@ -873,13 +875,14 @@ shootLaser ::
     Float ->
     World ->
     World
-shootLaser so lt pv p dir =
+shootLaser o so lt pv p dir =
     ( cWorld . lWorld . lasers
         .:~ Laser
             { _lpType = lt
             , _lpPhaseV = pv
             , _lpPos = p
             , _lpDir = dir
+            , _lpOrigin = o
             }
     )
         . soundContinue so p tone440sawtoothquietS (Just 2)
@@ -887,12 +890,13 @@ shootLaser so lt pv p dir =
 creatureShootPulseLaser :: Point3Q -> Creature -> World -> World
 creatureShootPulseLaser (p, q) cr =
     shootPulseLaser
+        (CrWeaponO $ cr ^. crID)
         (CrWeaponSound (_crID cr) 0)
         (p ^. _xy)
         (Q.qToAng q)
 
-shootPulseLaser :: SoundOrigin -> Point2 -> Float -> World -> World
-shootPulseLaser so p dir w =
+shootPulseLaser :: DamageOrigin -> SoundOrigin -> Point2 -> Float -> World -> World
+shootPulseLaser o so p dir w =
     w
         & cWorld . lWorld . pulseLasers
             .:~ PulseLaser
@@ -901,23 +905,25 @@ shootPulseLaser so p dir w =
                 , _pzDir = dir
                 , _pzDamage = 101
                 , _pzTimer = 5
+                , _pzOrigin = o
                 }
         & soundStart so p lasPulseS Nothing
 
-shootPlasmaBall :: Point3Q -> World -> World
-shootPlasmaBall (p, q) w =
+shootPlasmaBall :: DamageOrigin -> Point3Q -> World -> World
+shootPlasmaBall o (p, q) w =
     w
         & cWorld . lWorld . plasmaBalls .:~
             PBall
                 { _pbPos = p ^. _xy
                 , _pbVel = 6 * unitVectorAtAngle (Q.qToAng q)
                 , _pbType = DefaultPlasma
+                , _pbOrigin = o
                 }
 --        & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
 
 
-shootPulseBall :: Point3Q -> World -> World
-shootPulseBall (p, q) w =
+shootPulseBall :: DamageOrigin -> Point3Q -> World -> World
+shootPulseBall o (p, q) w =
     w
         & cWorld . lWorld . pulseBalls . at i
             ?~ PulseBall
@@ -925,6 +931,7 @@ shootPulseBall (p, q) w =
                 , _pzbVel = 3.5 * unitVectorAtAngle (Q.qToAng q)
                 , _pzbTimer = 200
                 , _pzbID = i
+                , _pzbOrigin = o
                 }
         & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
   where
@@ -990,12 +997,13 @@ shootBullets
     :: LocationDT OItem -> Creature -> (Muzzle, Int, DTree OItem) -> World -> World
 shootBullets loc cr (mz, x, magtree) w = fromMaybe w $ do
     thebullet <- getBulletType magtree
-    return $ foldl' (&) w (replicate x (shootBullet thebullet loc cr mz))
+    let bu = thebullet & buOrigin .~ CrWeaponO (cr ^. crID)
+    return $ foldl' (&) w (replicate x (shootBullet bu loc cr mz))
 
 shootBullet :: Bullet -> LocationDT OItem -> Creature -> Muzzle -> World -> World
 shootBullet bu loc cr mz w = makeBullet bu itm pq . (randGen .~ g) $ w
   where
-    (pq, g) = muzzleRandPos loc cr mz `runState` (w ^. randGen)
+    (pq, g) = muzzleRandPos w loc cr mz `runState` (w ^. randGen)
     itm = loc ^. locDT . dtValue . _1
 
 makeBullet :: Bullet -> Item -> Point3Q -> World -> World
@@ -1005,7 +1013,7 @@ makeBullet thebullet itm (p, q) w =
             .:~ ( thebullet
                     & buPos .~ bulpos
                     & buOldPos .~ bulpos
-                    & buVel %~ (rotateV dir . (muzvel *.*))
+                    & buVel %~ (rotateV dir . (muzvel *^))
                     & buDrag *~ drag
                 )
   where
@@ -1180,7 +1188,7 @@ doGenFloat (UniRandFloat x y) g = randomR (x, y) g
 
 mcShootLaser :: Item -> Machine -> World -> World
 mcShootLaser _ mc =
-    shootLaser (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir
+    shootLaser (McWeaponO (mc ^. mcID)) (MachinePrimarySound (_mcID mc)) (DamageLaser 11) 1 pos dir
   where
     pos = _mcPos mc +.+ 20 *.* unitVectorAtAngle dir
     dir = (mc ^?! mcType . mctTurret . tuDir)
@@ -1203,14 +1211,14 @@ mcShootAuto itm mc w
 --    dir = mc ^?! mcType . _McTurret . tuDir
 
 -- | assumes that the item is held
-shootTeslaArc :: Point3Q -> LocationDT OItem -> World -> World
-shootTeslaArc (p, q) loc w =
+shootTeslaArc :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
+shootTeslaArc o (p, q) loc w =
     w' & cWorld . lWorld . items . ix itid . itParams .~ ip
         & soundContinue (ItemSound itid 0) pos elecCrackleS (Just 2)
   where
     itm = loc ^. locDT . dtValue . _1
     itid = itm ^. itID . unNInt
-    (w', ip) = makeTeslaArc (itm ^. itParams) pos (Q.qToAng q) w
+    (w', ip) = makeTeslaArc o (itm ^. itParams) pos (Q.qToAng q) w
     pos = p ^. _xy
 
 determineProjectileTracking :: DTree OItem -> DTree OItem -> RocketHoming
@@ -1375,10 +1383,10 @@ dropInventoryPath ::
     Creature ->
     World ->
     World
-dropInventoryPath i ip loc cr = fromMaybe id $ do
+dropInventoryPath i ip loc cr w = fromMaybe w $ do
     invid <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
-    j <- getInventoryPath i ip invid cr
-    return $ dropItem cr j
+    j <- getInventoryPath w i ip invid cr
+    return $ dropItem cr j w
 
 --dropInventoryPath i ip loc cr w = case ip of
 --    ABSOLUTE -> fromMaybe w $ do
@@ -1407,18 +1415,23 @@ useInventoryPath ::
     Creature ->
     World ->
     World
-useInventoryPath pt i ip loc cr w = case ip of
-    ABSOLUTE -> fromMaybe w $ do
-        guard $ i `IM.member` (cr ^. crInv . unNIntMap)
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem i pt)
-    RELCURS -> fromMaybe w $ do
-        j <- cr ^? crManipulation . manObject . imSelectedItem . unNInt
-        guard $ (i + j) `IM.member` (cr ^. crInv . unNIntMap)
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem (i + j) pt)
-    RELITEM -> fromMaybe w $ do
-        j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
-        guard $ (i + j) `IM.member` (cr ^. crInv . unNIntMap)
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem (i + j) pt)
+useInventoryPath pt i ip loc cr w = fromMaybe w $ do
+    invid <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
+    j <- getInventoryPath w i ip invid cr
+    return $ w & cWorld . lWorld . delayedEvents .:~ (1,UseInvItem j pt)
+-- = case ip of
+--    ABSOLUTE -> fromMaybe w $ useat i
+--    RELCURS -> fromMaybe w $ do
+--        Sel 0 j <- w ^? hud .diSelection._Just
+--        useat $ i + j
+--    RELITEM -> fromMaybe w $ do
+--        j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
+--        useat $ i + j
+--  where
+--    useat k = do
+--        guard $ k `IM.member` (cr ^. crInv . unNIntMap)
+--        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem k pt)
+        
 
 --useRewindGun _ _ w = case w ^. cwTime . rewindWorlds of
 --    [w'] -> w & cwTime . maybeWorld .~ Just' w'

src/Dodge/Humanoid.hs

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

src/Dodge/Inventory.hs

@@ -12,7 +12,6 @@ module Dodge.Inventory (
     swapInvItems,
     scrollAugNextInSection,
     swapItemWith,
-    destroyItem,
     destroyAllInvItems,
     multiSelScroll,
     changeSwapSelSet,
@@ -68,19 +67,9 @@ destroyAllInvItems cr w =
         . _unNIntMap
         $ cr ^. crInv
 
-destroyItem :: Int -> World -> World
-destroyItem itid w = case w ^? cWorld . lWorld . items . ix itid . itLocation of
-    Nothing -> error $ "Tried to destroy item that does not exist; item id: " ++ show itid
-    Just InInv{_ilCrID = cid, _ilInvID = invid} -> destroyInvItem cid invid w
-    Just OnTurret{} -> error "need to write code for destroying items on turrets"
-    Just OnFloor ->
-        w
-            & cWorld . lWorld . items . at itid .~ Nothing
-            & cWorld . lWorld . floorItems . at itid .~ Nothing
-    Just InVoid -> w & cWorld . lWorld . items . at itid .~ Nothing
-
 -- note rmInvItem does not fully destroy the item, other updates to the item
 -- location are required
+-- note if this gets called ssInvPosFromSS might be necessary elsewhere
 rmInvItem :: Int -> NewInt InvInt -> World -> World
 rmInvItem cid invid w =
     w
@@ -89,39 +78,23 @@ rmInvItem cid invid w =
         & removeAnySlotEquipment
         & cWorld . lWorld . items . ix itid . itLocation . ilEquipSite .~ Nothing
         & updateselection
-        & updateselectionextra
-        & pointcid %~ updateRootItemID (w ^. cWorld . lWorld . items)
         & worldEventFlags . at InventoryChange ?~ ()
   where
     pointcid = cWorld . lWorld . creatures . ix cid
-    updateselectionextra
-        | cid == 0 = hud . diSelection . _Just . slSet %~ const mempty
-        | otherwise = id
     updateselection
-        | cid == 0 && cr ^? crManipulation . manObject . imSelectedItem == Just invid =
+        | cid == 0 && (w ^? hud .diSelection._Just) == Just (Sel 0 (invid^.unNInt)) =
             scrollAugInvSel (-1) . scrollAugInvSel 1
-        | otherwise =
-            pointcid . crManipulation . manObject . imSelectedItem %~ g
+        | otherwise = id
     cr = w ^?! cWorld . lWorld . creatures . ix cid
-    itid = _crInv cr ^?! ix invid
+    itid = cr ^?! crInv . ix invid
     itm = w ^?! cWorld . lWorld . items . ix itid
     dounequipfunction = effectOnRemove itm cr
     removeAnySlotEquipment = fromMaybe id $ do
-        epos <-
-            itm
-                ^? itLocation
-                . ilEquipSite
-                . _Just
+        epos <- itm ^? itLocation . ilEquipSite . _Just
         return $ pointcid . crEquipment . at epos .~ Nothing
-    --        return $ pointcid . crEquipment .~ mempty
-    maxk = fmap fst $ IM.lookupMax $ _unNIntMap $ cr ^. crInv
     f inv =
         let (xs, ys) = IM.split (_unNInt invid) $ _unNIntMap inv
          in NIntMap $ xs `IM.union` IM.mapKeysMonotonic (subtract 1) ys
-    -- the following might not work if a non-player creature drops their last item
-    g x
-        | x > invid || Just x == fmap NInt maxk = max 0 $ x - 1
-        | otherwise = x
 
 updateCloseObjects :: World -> World
 updateCloseObjects w =
@@ -156,7 +129,8 @@ changeSwapSelSet yi w
 
 swapSelSet :: (Int -> IS.IntSet -> World -> World) -> World -> World
 swapSelSet f w = fromMaybe w $ do
-    Sel j i is' <- w ^. hud . diSelection
+    Sel j i <- w ^. hud . diSelection
+    is' <- w ^? hud . diSections . ix j . ssSet
     let is = if IS.null is' 
         then IS.singleton i
         else is'
@@ -204,13 +178,14 @@ concurrentIS = go . IS.minView
 
 collectInvItems :: Int -> IS.IntSet -> World -> World
 collectInvItems secid is w = fromMaybe w $ do
-    guard $ secid == 0
+    guard $ secid == 0 || secid == 3
     (j, js) <- IS.minView is
     return $ h j js w
   where
     h j js w' = fromMaybe w' $ do
         (k, ks) <- IS.minView js
-        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
+--        return . h (j + 1) ks $ swapInvItems (\_ _ -> Just (j + 1)) k w'
+        return . h (j + 1) ks $ swapItemWith (\_ _ -> Just (j + 1)) (secid,k) w'
 
 changeSwapSel :: Int -> World -> World
 changeSwapSel yi w
@@ -228,7 +203,8 @@ multiSelScroll yi w
 
 multiSelScroll' :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
 multiSelScroll' f w = fromMaybe w $ do
-    Sel j i is <- w ^. hud . diSelection
+    Sel j i <- w ^. hud . diSelection
+    is <- w ^? hud . diSections . ix j . ssSet
     ss <- w ^? hud . diSections . ix j . ssItems
     k <- f i ss
     let insertordelete 
@@ -237,17 +213,16 @@ multiSelScroll' f w = fromMaybe w $ do
             | otherwise = IS.insert i . IS.insert k
     return $
         w
-            & hud . diSelection . _Just . slSet %~ insertordelete
+            & hud . diSections . ix j . ssSet %~ insertordelete
             & hud . diSelection . _Just . slInt .~ k
 
 changeSwapOther ::
-    ((Int -> Identity Int) -> ManipulatedObject -> Identity ManipulatedObject) ->
     Int ->
     (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
     Int ->
     World ->
     World
-changeSwapOther manlens n f i w = fromMaybe w $ do
+changeSwapOther n f i w = fromMaybe w $ do
     ss <- w ^? hud . diSections . ix n . ssItems
     k <- f i ss
     let doswap j
@@ -256,15 +231,7 @@ changeSwapOther manlens n f i w = fromMaybe w $ do
             | otherwise = j
     return $
         w
-            & swapAnyExtraSelection i k
-            & cWorld
-                . lWorld
-                . creatures
-                . ix 0
-                . crManipulation
-                . manObject
-                . manlens
-                %~ doswap
+            & hud . diSections . ix 3 . ssSet %~ swapInIntSet i k
             & hud . closeItems %~ swapIndices i k
             & hud . diSelection . _Just . slInt %~ doswap
             & worldEventFlags . at InventoryChange ?~ ()
@@ -276,13 +243,13 @@ swapItemWith ::
     World
 swapItemWith f (j, i) = case j of
     0 -> swapInvItems f i
-    3 -> changeSwapOther ispCloseItem 3 f i
-    5 -> changeSwapOther ispCloseButton 5 f i
+    3 -> changeSwapOther 3 f i
+    5 -> changeSwapOther 5 f i
     _ -> id
 
 changeSwapWith :: (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) -> World -> World
 changeSwapWith f w
-    | Just (Sel j i _) <- w ^. hud . diSelection = swapItemWith f (j, i) w
+    | Just (Sel j i) <- w ^. hud . diSelection = swapItemWith f (j, i) w
     | otherwise = w
 
 invSetSelection :: Selection -> World -> World
@@ -290,11 +257,12 @@ invSetSelection sel w =
     w
         & hud . diSelection ?~ sel
         & worldEventFlags . at InventoryChange ?~ ()
-        & setInvPosFromSS
-        & cWorld . lWorld %~ crUpdateItemLocations 0
+--        & crUpdateItemLocations
+        & setInvPosFromSS -- is this necessary here?
+        & crUpdateItemLocations
 
 invSetSelectionPos :: Int -> Int -> World -> World
-invSetSelectionPos i j = invSetSelection (Sel i j mempty)
+invSetSelectionPos i j = invSetSelection (Sel i j)
 
 scrollAugInvSel :: Int -> World -> World
 scrollAugInvSel yi w
@@ -303,8 +271,9 @@ scrollAugInvSel yi w
         w
             & hud %~ doscroll
             & worldEventFlags . at InventoryChange ?~ ()
+            & crUpdateItemLocations
             & setInvPosFromSS
-            & cWorld . lWorld %~ crUpdateItemLocations 0
+            & crUpdateItemLocations
   where
     doscroll he = fromMaybe he $ do
         sss <- he ^? diSections
@@ -315,8 +284,9 @@ scrollAugNextInSection w =
     w
         & hud %~ doscroll
         & worldEventFlags . at InventoryChange ?~ ()
+        & crUpdateItemLocations
         & setInvPosFromSS
-        & cWorld . lWorld %~ crUpdateItemLocations 0
+        & crUpdateItemLocations
   where
     doscroll he = fromMaybe he $ do
         sss <- he ^? diSections

src/Dodge/Inventory/Add.hs

@@ -6,8 +6,9 @@ module Dodge.Inventory.Add (
     pickUpItemAt,
 ) where
 
+import qualified IntSetHelp as IS
+import Dodge.Data.SelectionList
 import Linear
-import qualified Data.IntSet as IS
 import Control.Lens
 import Control.Monad
 import Data.Maybe
@@ -21,46 +22,55 @@ import qualified IntMapHelp as IM
 import NewInt
 
 -- this assumes that this item is currently on the floor
-tryPutItemInInv :: Int -> Int -> World -> Maybe (NewInt InvInt, World)
-tryPutItemInInv cid itid w = do
+tryPutItemInInv :: Maybe Int -> Int -> World -> Maybe (NewInt InvInt, World)
+tryPutItemInInv mcipos itid w = do
     itm <- w ^? cWorld . lWorld . items . ix itid
     invid <- checkInvSlotsYou itm w
     let itloc = InInv
-            { _ilCrID = cid
+            { _ilCrID = 0
             , _ilInvID = invid
-            , _ilIsRoot = False
-            , _ilIsSelected = False
-            , _ilIsAttached = False
             , _ilEquipSite = Nothing
             }
     return $ (invid,) $
             w
-                & cWorld . lWorld %~ crUpdateItemLocations cid
                 -- not sure about the order of these...
-                & cWorld . lWorld . creatures . ix cid . crInv . at invid ?~ itid
+                & cWorld . lWorld . creatures . ix 0 . crInv . at invid ?~ itid
                 & cWorld . lWorld . items . ix itid . itLocation .~ itloc
                 & cWorld . lWorld . floorItems . at itid .~ Nothing
                 & updateselectionextra invid
+                & updateselection (invid ^. unNInt)
+                & updatecloseitemset
+                & maybeselect invid
                 & cWorld . highlightItems . at itid ?~ 20
+                & setInvPosFromSS
+                & crUpdateItemLocations
+                & setInvPosFromSS
   where
-    updateselectionextra i
-        | cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
-            . (hud . diSelection . _Just . slInt %~ f i)
-        | otherwise = id
+    maybeselect invid = fromMaybe id $ do
+        i <- mcipos
+        is <- w ^? hud . diSections . ix 3 . ssSet
+        guard $ i `IS.member` is
+        return $ hud . diSections . ix 0 . ssSet %~ IS.insert (invid ^. unNInt)
+    updatecloseitemset = fromMaybe id $ do
+        i <- mcipos
+        return $ hud . diSections . ix 3 . ssSet %~ IS.deleteShift i
+    updateselectionextra i = hud . diSections . ix 0 . ssSet %~ IS.map (f i)
+    updateselection i = case w ^. hud . diSelection of
+        Just (Sel 0 j) | j >= i -> hud . diSelection . _Just . slInt +~ 1
+        _ -> id
     f j i | i >= _unNInt j = i + 1
           | otherwise = i
 
--- not sure why we have the cid here, this will probably only work for cid == 0
-tryPutItemInInvAt :: Int -> Int -> Int -> World -> Maybe World
-tryPutItemInInvAt i cid itid w = do
-    (j, w') <- tryPutItemInInv cid itid w
+tryPutItemInInvAt :: Maybe Int -> Int -> Int -> World -> Maybe World
+tryPutItemInInvAt mcipos i itid w = do
+    (j, w') <- tryPutItemInInv mcipos itid w
     guard (i <= _unNInt j)
     return $ foldr f w' [i + 1 .. _unNInt j]
   where
     f j = swapInvItems (\_ _ -> Just (j -1)) j
 
 createItemYou :: Item -> World -> World
-createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
+createItemYou itm w = maybe w' snd $ tryPutItemInInv Nothing itid w'
   where
     itid = IM.newKey $ w ^. cWorld . lWorld . items
     pos = w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy
@@ -68,11 +78,11 @@ createItemYou itm w = maybe w' snd $ tryPutItemInInv 0 itid w'
 
 -- the duplication is annoying...
 pickUpItem :: Int -> Int -> World -> World
-pickUpItem cid itid w = fromMaybe w $ do
+pickUpItem i itid w = fromMaybe w $ do
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    soundStart (CrSound cid) p pickUpS Nothing . snd <$> tryPutItemInInv cid itid w
+    soundStart (CrSound 0) p pickUpS Nothing . snd <$> tryPutItemInInv (Just i) itid w
 
-pickUpItemAt :: Int -> Int -> Int -> World -> World
-pickUpItemAt invid cid itid w = fromMaybe w $ do
+pickUpItemAt :: Int -> (Int,Int) -> World -> World
+pickUpItemAt invid (i,itid) w = fromMaybe w $ do
     p <- w ^? cWorld . lWorld . floorItems . ix itid . flItPos
-    soundStart (CrSound cid) p pickUpS Nothing <$> tryPutItemInInvAt invid cid itid w
+    soundStart (CrSound 0) p pickUpS Nothing <$> tryPutItemInInvAt (Just i) invid itid w