Cleanup

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

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

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

src/Dodge/Base/Collide.hs

@@ -34,8 +34,10 @@ module Dodge.Base.Collide (
     collide3WallsFloor,
     collide3,
     crHeight,
+    crMid,
 ) where
 
+import AesonHelp
 import Control.Applicative
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
@@ -173,31 +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
+    let h = crHeight cr
-    (p, n) <-
+    (p, n) <- fst $ intersectCylSeg (cr ^. crPos) (crRad $ cr ^. crType) h sp ep
-        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
         CrabCrit {} -> 25
         SlinkCrit {} -> 25
-        SlimeCrit {_slimeRad = r} -> min 15 r
+        SlimeCrit {_slimeSlime = r} -> min 25 $ 2 * slimeToRad r
         BeeCrit {} -> 10
         HiveCrit {} -> 25
-        _ -> error "Need to define crHeight for this crType"
+        BarrelCrit{} -> 20
-    CrIsCorpse{} -> Just 5
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
-    CrDestroyed{} -> Nothing
+    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))])
@@ -269,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
@@ -280,14 +292,11 @@ collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
             . _wlLine
             $ wl
     shiftbyrad (a, b) =
-        bimap
+            ( f $ a + rad *^ normalizeV (a - b)
-            f
+            , f $ b + rad *^ normalizeV (b - a)
-            f
-            ( a +.+ rad *.* normalizeV (a -.- b)
-            , 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
+    Sel 0 i <- w ^? hud . diSelection . _Just
-    j <- _crInv (you w) ^? ix i
+    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
+    i <- w ^? hud . manObject . hiRootSelectedItem
-    j <- _crInv (you w) ^? ix i
+    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 :: World -> IM.IntMap Item -> (Point2, Either Creature Wall) -> Maybe Point2
-bounceDir _ (_, Right wl) = Just $ uncurry (-) (_wlLine wl)
+bounceDir _ _ (_, Right wl) = Just $ uncurry (-) (_wlLine wl)
-bounceDir m (p, Left cr) | crIsArmouredFrom m p cr 
+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)
+    BulGas -> (\p -> makeGasCloud o p (V2 0 0))
-    BulBall ExplosiveBall -> makeMovingEB (_buVel bu) ExplosiveBall
+    BulBall eb@ExplosiveBall{} -> makeMovingEB (_buVel bu) eb o
     BulBall ElectricalBall{} ->
         makeMovingEB
             (_buVel bu)
-            (ElectricalBall (round $ bu ^. buPos . _1))
+            (ElectricalBall (round $ bu ^. buPos . _1)) o
-    BulBall FlashBall -> makeMovingEB (_buVel bu) FlashBall
+    BulBall eb@FlashBall{} -> makeMovingEB (_buVel bu) eb o
-    BulBall (FlameletBall x) -> makeMovingEB (_buVel bu) (FlameletBall x)
+    BulBall eb@FlameletBall{} -> makeMovingEB (_buVel bu) eb o
-    BulBall IncendiaryBall -> makeMovingEB (_buVel bu) IncendiaryBall
+    BulBall eb@IncendiaryBall{} -> makeMovingEB (_buVel bu) eb o
+  where
+    o = bu ^. buOrigin
 
 makeFragBullets :: Point2 -> World -> World
 makeFragBullets p w = w & cWorld . lWorld . bullets .++~ bus
@@ -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
@@ -172,8 +174,8 @@ hitEffFromBul w bu = case _buEffect bu of
 
 getBulHitDams :: Bullet -> Point2 -> [Damage]
 getBulHitDams bu p = case _buPayload bu of
-    BulPlain x -> [Piercing x p v
+    BulPlain x -> [Piercing x p v (bu ^. buOrigin)
-        ,Inertial 0 p v]
+        ,Inertial 0 p v (bu ^. buOrigin)]
     _ -> []
   where
     v = _buVel bu

src/Dodge/Creature.hs

@@ -12,9 +12,7 @@ module Dodge.Creature (
     module Dodge.Creature.Perception,
     module Dodge.Creature.ReaderUpdate,
     module Dodge.Creature.State,
-    module Dodge.Creature.Strategy,
     module Dodge.Creature.Test,
-    module Dodge.Creature.Volition,
     module Dodge.Creature.YourControl,
 ) where
 
@@ -35,9 +33,7 @@ import Dodge.Creature.Perception
 import Dodge.Creature.ReaderUpdate
 import Dodge.Creature.SpreadGunCrit
 import Dodge.Creature.State
-import Dodge.Creature.Strategy
 import Dodge.Creature.Test
-import Dodge.Creature.Volition
 import Dodge.Creature.YourControl
 import Dodge.Data.Creature
 import Dodge.Default

src/Dodge/Creature/Action.hs

@@ -10,6 +10,9 @@ 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
@@ -39,14 +42,16 @@ 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 =
+performActions cid w = fromMaybe w $ do
-    foldl'
+    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) = fromMaybe ([],NoAction) $ performAction cr w <$> cr ^? crActionPlan . apAction
+--    (iss, mayas) = maybe ([],NoAction) (performAction cr w) (cr ^? crActionPlan . apAction)
 
 type ActionUpdate = ([Impulse], Action)
 
@@ -55,6 +60,9 @@ type ActionUpdate = ([Impulse], Action)
 -}
 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)
@@ -65,7 +73,7 @@ performAction cr w ac = case ac of
     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
+--    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, NoAction) -> (imps, DoActionWhilePartial resetAc f resetAc)
@@ -80,11 +88,6 @@ performAction cr w ac = case ac of
     DoActionWhileInterrupt repa f afta
         | doWdCrBl f w cr -> (fst $ performAction cr w repa, DoActionWhileInterrupt repa f afta)
         | otherwise -> performAction cr w afta
---    DoActions [] -> ([], NoAction)
---    DoActions acs ->
---        let (imps, newAcs) = foldMap (performAction cr w) acs
---         in (imps, newAcs)
-    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], NoAction)
     PathTo p a -> performPathTo a cr w p
     EvadeAim -> tryEvadeSideways cr w
     TurnToPoint p -> performTurnToA cr p
@@ -92,8 +95,6 @@ performAction cr w ac = case ac of
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
         return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], NoAction)
-    UseSelf f -> performAction cr w $ doCrAc f cr
-    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
     DoImpulsesAlongside sideImp mainAc -> performAction cr w mainAc & _1 <>~ sideImp
     DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
     DoReplicatePartial _ 0 pac -> performAction cr w pac
@@ -147,6 +148,8 @@ crMoveImpulses cr p = case crMvType cr of
     MvWalking {} -> [MvTurnToward p, MvForward]
     JitMvType {_mvTurnJit = x} -> [MvTurnToward p, MvForward, RandomTurn x]
     StartStopMvType {} -> [MvTurnToward p, MvForward]
+    BeeMvType {} | cr ^?! crType . startStopMv == 0 -> [SetBeeRandomMovement, MvForward, MvTurnToward p]
+    BeeMvType {} -> [MvTurnToward p, MvForward]
 
 performTurnToA :: Creature -> Point2 -> ActionUpdate
 performTurnToA cr p
@@ -158,56 +161,48 @@ performTurnToA cr p
     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' =
+dropItem cr invid w =
-    doanyitemdropeffect
+    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
+        w ^? cWorld . lWorld . items . ix itid
-    maybeshiftseldown w = fromMaybe w $ do
+    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 <-
+    curpos <- mi <|> fmap fst (IM.lookupMax (cr ^. crInv . unNIntMap))
-        cr ^? crManipulation . manObject . imSelectedItem . unNInt
-            <|> 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 =
+--        , _crActionPlan =
-            ActionPlan
+--            ActionPlan
-                { _apAction = NoAction
+--                { _apAction = NoAction
-                , _apStrategy = FollowImpulses
+----                , _apStrategy = FollowImpulses
-                , _apGoal = [Kill 0]
+--                , _apGoal = Kill 0
-                }
+--                }
         , _crGroup = ShieldGroup
 --        , _crMvType = defaultChaseMvType
         }

src/Dodge/Creature/ChaseCrit.hs

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

src/Dodge/Creature/Damage.hs

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

src/Dodge/Creature/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 :: World -> Creature -> EquipSite -> Point3 -> Point3
-translateToES cr es p = fst (equipSitePQ es cr `Q.comp` (p, Q.qid))
+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
+    OnLeftLeg -> const $ legPQ LeftForward
-    OnRightLeg -> legPQ RightForward
+    OnRightLeg -> const $ legPQ RightForward
 
-translatePointToRightHand :: Creature -> Point3 -> Point3
+translatePointToRightHand :: World -> Creature -> Point3 -> Point3
-translatePointToRightHand cr p = fst (rightHandPQ cr `Q.comp` (p, Q.qid))
+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 :: World -> Creature -> Point3Q
-rightHandPQ cr
+rightHandPQ w cr
-    | oneH cr = (V3 11 (-3) 20, Q.qid)
+    | oneH w 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)
+    | twists w 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)
+    | twoFlat w cr = (V3 8 (-8) 12, Q.qid)
-    | Just TwoHandTwist <- cr ^? crManipulation . manObject . imAimStance
+    | 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 :: World -> Creature -> SPic -> SPic
-translateToRightHand = overPosSP . translatePointToRightHand
+translateToRightHand w = overPosSP . translatePointToRightHand w
 
-rightWristPQ :: Creature -> Point3Q
+rightWristPQ :: World -> Creature -> Point3Q
-rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
+rightWristPQ w cr = rightHandPQ w cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
 
-leftHandPQ :: Creature -> Point3Q
+leftHandPQ :: World -> Creature -> Point3Q
-leftHandPQ cr
+leftHandPQ w cr
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
+    | twists w 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)
+    | twoFlat w cr = (V3 8 8 12, Q.qid)
-    | Just TwoHandTwist <- cr ^? crManipulation . manObject . imAimStance
+    | 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 :: World -> Creature -> Point3 -> Point3
-translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p, Q.qid))
+translatePointToLeftHand w cr p = fst (leftHandPQ w cr `Q.comp` (p, Q.qid))
 
-translateToLeftHand :: Creature -> SPic -> SPic
+translateToLeftHand :: World -> Creature -> SPic -> SPic
-translateToLeftHand = overPosSP . translatePointToLeftHand
+translateToLeftHand w = overPosSP . translatePointToLeftHand w
 
-leftWristPQ :: Creature -> Point3Q
+leftWristPQ :: World -> Creature -> Point3Q
-leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qid)
+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 :: World -> Creature -> Point3Q
-headPQ cr
+headPQ w cr
-    | twists cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
+    | twists w 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))
+    | 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 :: World -> Creature -> Point3Q
-chestPQ cr = backPQ cr `Q.comp` (0, Q.qz pi)
+chestPQ w cr = backPQ w cr `Q.comp` (0, Q.qz pi)
 
-backPQ :: Creature -> Point3Q
+backPQ :: World -> Creature -> Point3Q
-backPQ cr
+backPQ w cr
-    | oneH cr = (V3 0 0 10, Q.qz 0.5)
+    | oneH w cr = (V3 0 0 10, Q.qz 0.5)
-    | twists cr = (V3 0 3 10, Q.qz (-1.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,8 +3,9 @@
 
 module Dodge.Creature.Impulse (followImpulse) where
 
+import RandomHelp
 import Control.Applicative
-import Control.Monad.Trans.State.Lazy
+--import Control.Monad.Trans.State.Lazy
 --import Control.Monad.State -- moving from mtl to transformers
 import Data.Maybe
 import Dodge.Creature.Impulse.Movement
@@ -19,12 +20,12 @@ import Dodge.SoundLogic
 import Geometry
 import LensHelp
 import Linear
-import System.Random
+--import System.Random
 
 -- note SwitchToItem doesn't necessarily update the root item correctly
 followImpulse :: Int -> World -> Impulse -> World
 followImpulse cid w = \case
-    UpdateRandGen -> w & randGen %~ (snd . (randomR (0::Int,0)))
+    UpdateRandGen -> w & randGen %~ (snd . randomR (0::Int,1))
     ImpulseNothing -> w
     RandomImpulse rimp ->
         let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w)
@@ -32,21 +33,18 @@ followImpulse cid w = \case
     Bark sid ->
         soundStart (CrMouth cid) cpos sid Nothing $
             w & clens %~ resetCrVocCoolDown w
-    Move p -> crup $ crMvBy p (w ^. cWorld . lWorld)
+    Move p -> crup $ crMvBy p w
-    Walk p -> crup $ crWalk p (w ^. cWorld . lWorld)
+    Walk p -> crup $ crWalk p w
-    MoveForward x -> crup $ crMvForward x (w ^. cWorld . lWorld)
+    MoveForward x -> crup $ crMvForward x w
-    MoveNoStride p -> crup $ crMvByNoStride p (w ^. cWorld . lWorld)
+    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' ->
+    Melee tid ->
-        hitCr cid' $
+        hitCr tid $ crup $ meleeMovement w tid . (crType . meleeCooldown .~ 20)
-            crup
-                ( crMvAbsolute (w ^. cWorld . lWorld) (10 *.* normalizeV (posFromID cid' -.- cpos)) . (crType . meleeCooldown .~ 20)
-                )
     MeleeL cid' ->
         hitCrd (-pi/2) cid' $
             crup
@@ -66,15 +64,16 @@ followImpulse cid w = \case
     MakeSound sid -> soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) sid Nothing w
     DropItem -> undefined
     ChangeStrategy strat -> crup $ crActionPlan . apStrategy .~ strat
-    AddGoal gl -> crup $ crActionPlan . apGoal .:~ gl
+--    AddGoal gl -> crup $ crActionPlan . apGoal .:~ gl
     ImpulseUseTarget f -> fromMaybe w $ do
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
         return $ followImpulse cid w (doCrImp f tcr)
-    MvForward -> crup $ crMvForward' (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
@@ -91,9 +90,30 @@ followImpulse cid w = \case
     rr a = randomR (- a, a) $ _randGen w
     hitCr i =
         cWorld . lWorld . creatures . ix i . crDamage
-            .:~ Blunt 100 (posFromID i) (posFromID i - cpos)
+            .:~ Blunt 100 (posFromID i) (posFromID i - cpos) (CrMeleeO cid)
     hitCrd a i =
         cWorld . lWorld . creatures . ix i . crDamage
-            <>~ [Blunt 100 (posFromID i) (posFromID i - cpos)
+            <>~ [Blunt 100 (posFromID i) (posFromID i - cpos) (CrMeleeO cid)
-                , Inertial 0 (posFromID i) (50 * unitVectorAtAngle (cr ^. crDir + a))
+                , Inertial 0 (posFromID i) (50 * unitVectorAtAngle (cr ^. crDir + a)) (CrMeleeO cid)
                 ]
+
+meleeMovement :: World -> Int -> Creature -> Creature
+meleeMovement w tid cr = case cr ^. crType of
+    HoverCrit {} -> fromMaybe cr $ do
+        txy <- w ^? cWorld . lWorld . creatures . ix tid . crPos . _xy
+        return $ crMvAbsolute w (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

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

src/Dodge/Creature/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/Mass.hs

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

src/Dodge/Creature/MoveType.hs

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

src/Dodge/Creature/Perception.hs

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

src/Dodge/Creature/Picture.hs

@@ -7,30 +7,29 @@ module Dodge.Creature.Picture (
     drawCreature,
 ) where
 
-import Data.Foldable
-import qualified Data.Strict.Tuple as ST
-import RandomHelp
-import Dodge.Base.Collide
-import Control.Monad
-import Data.Maybe
-import Dodge.Data.World
-import Linear
-import Dodge.Data.Equipment.Misc
-import Dodge.Creature.HandPos
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
+import Control.Monad
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.Strict.Tuple as ST
+import Dodge.Base.Collide
+import Dodge.Creature.HandPos
 import Dodge.Creature.Radius
 import Dodge.Creature.Shape
---import Dodge.Creature.Test
+import Dodge.Creature.Slime
 import Dodge.Damage
---import Dodge.Data.Creature
+import Dodge.Data.Equipment.Misc
+import Dodge.Data.World
 import Dodge.Item.Draw
 import Dodge.Item.Grammar
 import Geometry
+import Geometry.Zone
+import Linear
 import Picture
 import qualified Quaternion as Q
+import RandomHelp
 import Shape
---import Shape
 import ShapePicture
 
 drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
@@ -41,9 +40,9 @@ drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
         BarrelCrit{} -> barrelShape
         LampCrit{_lampHeight = h} -> lampCrSPic h
         ChaseCrit{} -> noPic $ drawChaseCrit w cr
-        Avatar {} -> basicCrPict m cr
+        Avatar{} -> basicCrPict w m cr
-        SwarmCrit -> basicCrPict m cr
+        SwarmCrit -> basicCrPict w m cr
-        AutoCrit -> basicCrPict m cr
+        AutoCrit -> basicCrPict w m cr
         CrabCrit{} -> noPic $ drawCrabCrit w cr
         HoverCrit{} -> noPic $ drawHoverCrit cr
         SlinkCrit{} -> noPic $ drawSlinkCrit cr
@@ -56,37 +55,27 @@ drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
         _ -> id
 
 drawSlimeCrit :: Creature -> Shape
-drawSlimeCrit cr = colorSH green 
+drawSlimeCrit cr =
-    $ upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) $ polyCirc 6 r
+    colorSH green $
-    & each %~ scaleAlong d s
+        upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) ps
-    & each %~ scaleAlong (vNormal d) (1 / s)
-    & each %~ rotateV (-cr ^. crDir)
-    & each %~ (((r-cr^?!crType.slimeRadWobble)/r) *^)
   where
-    r = cr ^?! crType . slimeRad
+    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
-    p = cr ^?! crType . slimeCompression
+    so = slimeOutline cr
-    d = normalize p
+    ps = fromMaybe so $ do
-    s = norm p / r
+        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)
 
--- assumes d is a unit vector
+basicCrPict :: World -> IM.IntMap Item -> Creature -> SPic
-scaleAlong :: Point2 -> Float -> Point2 -> Point2
+basicCrPict w m cr = drawEquipment w m cr <> noPic (basicCrShape w cr)
-scaleAlong d s p = ((s - 1) * dot d p) *^ d + p
 
-
+basicCrShape :: World -> Creature -> Shape
-basicCrPict :: IM.IntMap Item -> Creature -> SPic
+basicCrShape w cr =
-basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
-
-crCamouflage :: Creature -> CamouflageStatus
-crCamouflage _ = FullyVisible
-
-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 (_skinHead cskin) . overPosSH (translateToES w cr OnHead) $ scalp
-                , colorSH (_skinUpper cskin) $ upperBody cr
+            , colorSH (_skinUpper cskin) $ upperBody w cr
             , rotmdir $ colorSH (_skinLower cskin) $ feet cr
             ]
   where
@@ -95,11 +84,13 @@ basicCrShape cr
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 drawSlinkCrit :: Creature -> Shape
-drawSlinkCrit cr = snd (foldl' f ((V3 0 0 0,Q.qid), mempty) $ cr ^?! crType . slinkSpine)
+drawSlinkCrit cr =
+    snd (foldl' f ((V3 0 0 0, Q.qid), mempty) $ cr ^?! crType . slinkSpine)
         <> shead
         & each . sfColor .~ cskin ^?! skinUpper
   where
-    shead = polyCirc 6 15
+    shead =
+        polyCirc 6 15
             & upperPrismPoly Medium Important 10
             & each . sfVs . each %~ Q.apply (cr ^?! crType . slinkHeadPos)
     cskin = crShape $ _crType cr
@@ -107,9 +98,12 @@ drawSlinkCrit cr = snd (foldl' f ((V3 0 0 0,Q.qid), mempty) $ cr ^?! crType . sl
     g _ = upperPrismPoly Medium Important 2 $ polyCirc 6 15
 
 drawHoverCrit :: Creature -> Shape
-drawHoverCrit cr = colorSH (_skinHead cskin) 
+drawHoverCrit cr =
+    colorSH
+        (_skinHead cskin)
         (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
-    <> colorSH (_skinUpper cskin)
+        <> 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
@@ -120,18 +114,25 @@ drawHive :: SPic
 drawHive = noPic $ upperPrismPolyHalfMI 25 $ polyCirc 6 20
 
 drawBeeCrit :: Creature -> Shape
-drawBeeCrit cr = colorSH col
+drawBeeCrit cr =
-    (upperPrismPolyHalfMI 3 $ polyCirc 6 r)
+    colorSH
-        <>
+        col
-    colorSH (dark col) (overPosSH (Q.apply (beakpos)) $ upperPrismPolyHalfST 1 $ [V2 0 (-2), V2 4 0,V2 0 2])
+        (f . upperPrismPolyHalfMI 3 $ polyCirc 6 r)
+        <> colorSH (dark col) (overPosSH (Q.apply beakpos) $ upperPrismPolyHalfST 1 [V2 0 (-2), V2 4 0, V2 0 2])
   where
     r = cr ^. crType . to crRad
     beakpos = (V3 (r - 1) 0 0, Q.qid)
     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 
+drawCrabCrit w cr =
+    mconcat
         [ crabUpperBody w cr
         , colorSH (_skinLower cskin) $ crabFeet w cr
         ]
@@ -139,7 +140,8 @@ drawCrabCrit w cr = mconcat
     cskin = crShape $ _crType cr
 
 drawChaseCrit :: World -> Creature -> Shape
-drawChaseCrit w cr = mconcat 
+drawChaseCrit w cr =
+    mconcat
         [ chaseUpperBody w cr
         , rotmdir $ colorSH (_skinLower cskin) $ feet cr
         ]
@@ -148,14 +150,20 @@ drawChaseCrit w cr = mconcat
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 crabUpperBody :: World -> Creature -> Shape
-crabUpperBody _ cr =  colorSH (_skinUpper cskin)
+crabUpperBody _ cr =
-    (
+    colorSH
-    overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
+        (_skinUpper cskin)
-        & each . _x *~ 0.6) 
+        ( overPosSH
+            (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)
+        <> colorSH
+            (_skinHead cskin)
             (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
   where
     torsoq = (V3 0 0 10, Q.qid)
@@ -170,24 +178,47 @@ crabUpperBody _ cr =  colorSH (_skinUpper cskin)
     rcool = 1 - min 10 (fromIntegral . _meleeCooldownR $ _crType cr) / 10
     headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
 
-
 chaseUpperBody :: World -> Creature -> Shape
-chaseUpperBody w cr =  colorSH (_skinUpper cskin)
+chaseUpperBody w cr =
-    (overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI tz $ polyCirc 3 12 
+--    colorSH
+--        (_skinUpper cskin)
+        ( overPosSH
+            (Q.apply torsoq)
+            ( upperPrismPolyHalfMI tz $
+                polyCirc 3 12
                     & each %~ vNormal
-        & each . _y *~ 0.6) 
+                    & each . _y *~ 0.6
-    <> overPosSH (Q.apply neckq) (upperPrismPolyHalfMI 3 $ (+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
             )
-    <> colorSH (_skinHead cskin)
+           <> overPosSH (Q.apply neckq) lneckshape
-        (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+        <> 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))
+--    (qy1,qy2,qy3)  
-    headq = neckq `Q.comp` (V3 16 0 0, Q.axisAngle (V3 0 1 0) (2*mcool+vocaltilt) * Q.qz aimrot )
+----        | 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
@@ -206,6 +237,29 @@ chaseUpperBody w cr =  colorSH (_skinUpper cskin)
         guard $ hasLOSIndirect cxy tcxy w
         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)
 
@@ -229,19 +283,23 @@ 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)
+                & 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)
+                & 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)
+                & 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)
+                & each . sfVs . each +~ V3 0 (-2) 5
+           )
   where
     rpos = rot (cr ^?! crType . rFootPos - cxy)
     rot = rotateV cdir
@@ -259,8 +317,9 @@ crabFeet _ cr =
 
 spiderJoint :: Point3 -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
 spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a + b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
---spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
   where
+    -- 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
@@ -275,8 +334,8 @@ spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (
 --    c = argV $ (p-q) ^. _xy
 --    f x = Q.qz c * x
 
-makeCorpse :: StdGen -> Creature -> SPic
+makeCorpse :: World -> StdGen -> Creature -> SPic
-makeCorpse g cr = case cr ^. crType of
+makeCorpse w g cr = case cr ^. crType of
     HoverCrit{} -> noPic $ drawHoverCrit cr
     ChaseCrit{} -> noPic $ chaseCorpse g cr
     CrabCrit{} -> noPic $ crabCorpse g cr
@@ -286,7 +345,7 @@ makeCorpse g cr = case cr ^. crType of
             . scaleSH (V3 crsize crsize crsize)
             $ mconcat
                 [ colorSH (_skinHead cskin) $ deadScalp cr
-                , colorSH (_skinUpper cskin) $ deadUpperBody cr
+                , colorSH (_skinUpper cskin) $ deadUpperBody w cr
                 , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
                 ]
   where
@@ -295,13 +354,16 @@ makeCorpse g cr = case cr ^. crType of
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
 chaseCorpse :: StdGen -> Creature -> Shape
-chaseCorpse g cr = mconcat
+chaseCorpse g cr =
-            [colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $ polyCirc 3 12 
+    mconcat
+        [ colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $
+            polyCirc 3 12
                 & each %~ vNormal
                 & each . _y *~ 0.6
         , colorSH (_skinUpper cskin) . overPosSH (Q.apply neckq) $
             upperPrismPolyHalfMI 3 ((+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
-    , colorSH (_skinHead cskin)
+        , 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
         ]
@@ -314,15 +376,23 @@ chaseCorpse g cr = mconcat
     headq = neckq `Q.comp` (V3 16 0 0, Q.qz b)
 
 crabCorpse :: StdGen -> Creature -> Shape
-crabCorpse g cr = mconcat
+crabCorpse g cr =
-    [ colorSH (_skinUpper cskin) $ overPosSH (Q.apply torsoq) (upperPrismPolyHalfMI 5 $ polyCirc 4 10 
+    mconcat
-        & each . _x *~ 0.6) 
+        [ colorSH (_skinUpper cskin) $
-    , colorSH (_skinUpper cskin) $ overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+            overPosSH
+                (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)
+        , colorSH
+            (_skinHead cskin)
             (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
         ]
   where
@@ -345,12 +415,12 @@ 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
+        translateToRightHand w cr aHand
-            <> translateToLeftHand cr aHand
+            <> translateToLeftHand w cr aHand
   where
     aHand = noPic $ translateSHz (-2) . upperPrismPolyHalfST 2 $ polyCirc 3 4
 
@@ -370,31 +440,32 @@ 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 :: World -> Creature -> Shape
-deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
+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 = 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)
@@ -405,4 +476,3 @@ lampCrSPic :: Float -> SPic
 lampCrSPic h =
     colorSH blue (upperBox Small Undesired h $ rectWH 5 5)
         ST.:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-

src/Dodge/Creature/Radius.hs

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

src/Dodge/Creature/ReaderUpdate.hs

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

src/Dodge/Creature/Slime.hs

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

src/Dodge/Creature/State.hs

@@ -4,6 +4,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
+crPainEffect :: Creature -> World -> World
-applyPastDamages cr w
+crPainEffect cr = case cr ^. crType of
-    | HoverCrit {} <- cr ^. crType 
+    HoverCrit {} -> hoverPainEffect cr
-    , _crPain cr > 50 = w
+    HiveCrit{} -> hivePainEffect cr
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50
+    _ -> jitterPain cr
-                & cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1
+
-    | HoverCrit {} <- cr ^. crType  = w
+
+hoverPainEffect :: Creature -> World -> World
+hoverPainEffect cr
+    | _crPain cr > 50 =
+                (cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50)
+                . (cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1)
+    | otherwise = id
+
+
+hivePainEffect :: Creature -> World -> World
+hivePainEffect cr w
+    | _crPain cr > 0 = w & cWorld . lWorld . creatures . ix (cr ^. crID) . crPain %~ (max 0 . subtract 5)
+        & cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos & _xy +~ p & _z .~ 20) v 200
+        & randGen .~ g
+    | otherwise = w
+  where
+    (a,g') = randomR (0,2*pi) $ w ^. randGen
+    (b,g) = runState randOnUnitSphere g'
+    p = (crRad (cr ^. crType) + 5) *^ unitVectorAtAngle a
+    v = 3 *^ b
+
+jitterPain :: Creature -> World -> World
+jitterPain cr w
     | _crPain cr > 200 = dojitter 3 100
     | _crPain cr > 20 = dojitter 2 10
     | _crPain cr > 0 = dojitter 1 1
@@ -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 $
+    return $ w
-        (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
+       & (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
-           . (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
+       &     (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
-            . (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
+       &      (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,9 @@
 {-# LANGUAGE LambdaCase #-}
 
 module Dodge.Creature.State.WalkCycle (updateCarriage
-    ,compressionScale) where
+    ,compressionScale
+    , flyInertia
+    ) where
 
 import qualified Quaternion as Q
 import Dodge.Creature.Radius
@@ -55,9 +57,10 @@ updateCarriage' cid cr w = \case
         mcr <- w ^? cWorld . lWorld . creatures . ix mid
         mp <- mcr ^? crPos
         d <- mcr ^? crType . slimeCompression
-        r <- mcr ^? crType . slimeRad
+        return $ w & tocr . crPos .~ mp + (oxyrot (mcr ^. crDir) 
-        return $ w & tocr . crPos .~ mp + (p & _xy %~ compressionScale ((1/r) *^ d))
+            (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
@@ -78,14 +81,13 @@ pushAgainst x y
     | 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
@@ -136,9 +138,14 @@ chasmTestCliffPush f' cr w
   where
     cxy = cr ^. crPos . _xy
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
-    g = uncurry $ crOnSeg cr
+    --g = uncurry $ crOnSeg cr
+    g = uncurry $ crOnSeg' cr
     f = pointInPoly cxy
 
+crOnSeg' :: Creature -> Point2 -> Point2 -> Bool
+{-# INLINE crOnSeg' #-}
+crOnSeg' cr = circOnSeg (cr ^. crPos . _xy) (min 10 (cr ^. crType . to crRad))
+
 chasmRotate :: Creature -> Point2 -> World -> World
 chasmRotate cr v w
     | t = rotateTo8 (argV v) w

src/Dodge/Creature/Statistics.hs

@@ -6,10 +6,10 @@ module Dodge.Creature.Statistics (
 --    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
@@ -53,8 +53,8 @@ crStrength cr = case cr ^. crType of
 --    BeeCrit{} -> 20
     
 
-getCrMoveSpeed :: LWorld -> Creature -> Int
+getCrMoveSpeed :: World -> Creature -> Int
-getCrMoveSpeed lw cr = strFromHeldItem lw cr + strFromEquipment lw cr + crStrength cr
+getCrMoveSpeed w cr = strFromHeldItem w cr + strFromEquipment (w^.cWorld.lWorld) cr + crStrength cr
 
 strFromEquipment :: LWorld -> Creature -> Int
 strFromEquipment lw = sum . fmap equipmentStrValue . crCurrentEquipment lw
@@ -70,12 +70,12 @@ crCurrentEquipment lw = fmap f . _crEquipment
   where
     f i = lw ^?! items . ix (_unNInt i)
 
-strFromHeldItem :: LWorld -> Creature -> Int
+strFromHeldItem :: World -> Creature -> Int
-strFromHeldItem lw cr = fromMaybe 0 $ do
+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
+crAwayFromPost cr = case _apGoal $ _crActionPlan cr of
-    Just (SentinelAt p _) -> dist p (cr ^. crPos . _xy) > 15
+    SentinelAt p _ -> dist p (cr ^. crPos . _xy) > 15
     _ -> False
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
 
-crInAimStance :: AimStance -> Creature -> Bool
+crInAimStance :: AimStance -> World -> Creature -> Bool
-crInAimStance as cr = cr ^? crStance . posture == Just Aiming
+crInAimStance as w cr = cr ^? crStance . posture == Just Aiming
-    && cr ^? crManipulation . manObject . imAimStance == Just as
+    && 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 :: IM.IntMap Item -> Point2 -> World -> Creature -> Bool
-crIsArmouredFrom m p cr = fromMaybe False $ do
+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 OneHand w cr = 0.5
-        | crInAimStance TwoHandTwist cr = negate 1
+        | crInAimStance TwoHandTwist w cr = negate 1
         | otherwise = 0
 
 --crOnSeg :: Point2 -> Point2 -> Creature -> Bool
@@ -133,12 +129,19 @@ isAnimate :: Creature -> Bool
 {-# INLINE isAnimate #-}
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
-    SlimeIntelligence -> False
+    SlimeIntelligence -> True
     ActionPlan{} -> True
 
 hasAutoDoorBody :: Creature -> Bool
-hasAutoDoorBody cr = case cr ^. crHP of
+hasAutoDoorBody cr = crittype && notdestroyed
+  where
+    notdestroyed = case cr ^. crHP of
         HP {} -> True
         CrIsCorpse {} -> True
-    CrDestroyed {} -> False
+        AvatarDestroyed {} -> False
+    crittype = case cr ^. crType of
+        SlimeCrit {} -> False
+        BeeCrit {} -> False
+        HiveCrit {} -> False
+        _ -> True
     

src/Dodge/Creature/Update.hs

@@ -2,10 +2,16 @@
 
 module Dodge.Creature.Update (updateCreature) where
 
---import Dodge.WorldEvent.ThingsHit
+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.Creature.Radius
 import Dodge.Zoning.Creature
 import Dodge.Creature.ChaseCrit
 import Dodge.Creature.Damage
@@ -15,7 +21,6 @@ import qualified IntMapHelp as IM
 import Data.Maybe
 import Dodge.Barreloid
 import Dodge.Base.You
--- import Dodge.Base.NewID
 import Dodge.Creature.Action
 import Dodge.Creature.Picture
 import Dodge.Creature.State
@@ -25,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
@@ -45,17 +49,14 @@ import qualified Data.IntSet as IS
 -- allow for knockbacks etc to be determined as well as intended movements
 updateCreature :: Creature -> World -> World
 updateCreature cr
-    | cr ^. crPos . _z < negate 300 = (tocr . crHP .~ CrDestroyed Pitted) . destroyAllInvItems cr
+    | cr ^. crPos . _z < negate 300 = (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature) 
+        . destroyAllInvItems cr
     | otherwise = case cr ^. crHP of
-        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . damageCorpse (_crID cr) cr
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . applyCreatureDamage (_crID cr) cr
-        CrDestroyed{} -> id
+        AvatarDestroyed{} -> id
         HP{} -> cleardamage . updateLivingCreature cr
   where
-    cleardamage = tocr . crDamage .~ mempty
+    cleardamage = cWorld . lWorld . creatures . ix (cr^.crID) . crDamage .~ mempty
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
-
-damageCorpse :: Int -> Creature -> World -> World
-damageCorpse _ cr w = w & applyCreatureDamage (cr ^. crDamage) cr
 
 updateLivingCreature :: Creature -> World -> World
 updateLivingCreature cr = case cr ^. crType of
@@ -65,18 +66,14 @@ updateLivingCreature cr = case cr ^. crType of
             . yourControl
     LampCrit{} -> updateLampoid cr
     BarrelCrit bt -> updateBarreloid bt cr
-    ChaseCrit{} -> \w ->
+    ChaseCrit{} -> crUpdate cid . performActions cid . setChaseCritKinematics cid . updateChaseCrit cid cr
-        crUpdate cid . performActions cid $
+    CrabCrit{} -> crUpdate cid . performActions cid . crabCritInternal cid
-            over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
-    CrabCrit{} ->
-        crUpdate cid . performActions cid . crabCritInternal cid
     AutoCrit{} -> crUpdate cid
     SwarmCrit{} -> crUpdate cid
-    HoverCrit{} -> \w ->
+    HoverCrit{} -> crUpdate cid . performActions cid . hoverCritHoverSound cr .
-        crUpdate cid . performActions cid . hoverCritHoverSound cr $
+            updateHoverCrit cid
-            over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
     SlinkCrit{} -> slinkCritUpdate cid
-    SlimeCrit{} -> slimeCritUpdate cid
+    SlimeCrit{} -> updateSlimeCrit cid
     BeeCrit{} -> crUpdate cid . performActions cid . updateBeeFromPheremones cr cid . updateBeeCrit cr cid
     HiveCrit{} -> crUpdate cid . performActions cid . updateHiveCrit cr cid
   where
@@ -87,16 +84,20 @@ updateHiveCrit cr cid w
     | Just x <- cr ^? crType . hiveChildren . to IS.size
     , x < nbees
     , Just y <- cr ^? crType . hiveGestation
-    , y == 0 = w 
+    , y == 0 
+    , Just z <- cr ^? crType . hiveSlime
+    , z >= 400
+        = w 
         & tocr . crType . hiveChildren %~ IS.insert nid
         & tocr . crType . hiveGestation .~ 50
         & cWorld . lWorld . creatures . at nid ?~ ncr
+        & tocr . crType . hiveSlime -~ 400
     | Just x <- cr ^? crType . hiveChildren . to IS.size
     , x < nbees = w
         & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
     | otherwise = w
   where
-    nbees = 10
+    nbees = 15
     tocr = cWorld . lWorld . creatures . ix cid
     nid = IM.newKey $ w ^. cWorld . lWorld . creatures
     ncr = beeCrit & crPos .~ (cr ^. crPos + (0 & _xy +~ 25))
@@ -105,78 +106,139 @@ updateHiveCrit cr cid w
 
 updateBeeFromPheremones :: Creature -> Int -> World -> World
 updateBeeFromPheremones cr cid w
-    | any f (w ^. cWorld . lWorld . beePheremones) = w & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
+    | any f (w ^. cWorld . lWorld . beePheremones) = w 
+        & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
     | otherwise = w
   where
-    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos) < 20
+    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos . _xy) < 20
 
 updateBeeCrit :: Creature -> Int -> World -> World
-updateBeeCrit cr
+updateBeeCrit cr cid
-    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr cid
-    | otherwise = updateCalmBee cr
+    | otherwise = beeLifespanCheck cr cid . updateCalmBee cr cid
+
+beeLifespanCheck :: Creature -> Int -> World -> World
+beeLifespanCheck cr cid
+    | Just ls <- cr ^? crType . beeLifespan
+    , Just x <- cr ^? crType . beeSlime
+    , ls < 1
+    , x < 5
+        = cWorld . lWorld . creatures . ix cid . crHP . _HP -~ 1
+    | otherwise = id
 
 updateAggroBee :: Creature -> Int -> World -> World
 updateAggroBee cr cid w
-    | Just tcr <- listToMaybe . sortOn (distance cxy . (^. crPos . _xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
+    | Mounted{} <- cr ^. crStance . carriage = w & tocr . crStance . carriage .~ Flying 0 
+    | Just tcr <- atarget
+    , distance (tcr ^. crPos . _xy) (cr ^. crPos . _xy) < crRad (cr ^. crType) + crRad (tcr ^. crType) + 1
+    , nearZeroAngle (argV (tcr ^. crPos . _xy - cr ^. crPos . _xy) - cr ^. crDir) < pi / 2
+    , 0 <- cr ^?! crType . meleeCooldown
+        = w & tocr . crPos .~ (cr ^. crOldPos & _xy -~ 5 *^ unitVectorAtAngle (cr ^. crDir))
+            & tocr . crType . startStopMv .~ (cr ^?! to crMvType . mvPulseTime)
+            & cWorld . lWorld . creatures . ix (tcr ^. crID) . crDamage 
+                .:~ Blunt 50 (cxy + crRad (cr ^. crType) *^ vdir) vdir (CrMeleeO (cr ^. crID))
+            & tocr . crType . meleeCooldown .~ 20
+    | Just tcr <- atarget = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
         & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w & tocr . crType . beeAggro -~ 1
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
     | otherwise = w & tocr . crType . beeAggro -~ 1
-        & tocr . crActionPlan . apStrategy .~ Search
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+        & randGen .~ g 
   where
+    (p,g) = runState (randOnCirc 150) (w ^. randGen)
+    atarget = listToMaybe . sortOn (distance cxy . (^.crPos._xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w
+    vdir = unitVectorAtAngle (cr ^. crDir)
     cxy = cr ^. crPos . _xy
     tocr = cWorld . lWorld . creatures . ix cid
-    istarget tcr = tcr ^. crID == 0
+    istarget tcr = t (tcr ^. crType)
+        && isJust (tcr ^? crHP . _HP)
         && hasLOS cxy (tcr ^. crPos . _xy) w
+    t = \case
+        Avatar{} -> True
+        ChaseCrit{} -> True
+        CrabCrit{} -> True
+        _ -> False
 
 -- do bees need to be able to see slime targets?
 -- if no path can be made, reset harvest action
+-- this should all be simplified
+-- should count how many are mounted on an individual slime, try for a different
+-- slime if too many
 updateCalmBee :: Creature -> Int -> World -> World
 updateCalmBee cr cid w 
     | Just hcr <- gethive
     , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
     , Just x <- cr ^? crType . beeSlime 
-    , x >= 0.5
+    , x >= 50 = w 
-        = w & tocr . crType . beeSlime -~ 0.5
+        & tocr . crType . beeSlime -~ 50
-    | Just hcr <- gethive
+        & cWorld . lWorld . creatures . ix (hcr ^. crID) . crType . hiveSlime +~ 50
-    , Just _ <- cr ^? crStance . carriage . mountID
+    | Just x <- cr ^? crType . beeSlime 
-    , Just x <- cr ^? crType . beeSlime 
+    , x < 50
-    , x >= 15
+    , Just hcr <- gethive
-        = w & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
-            & tocr . crStance . carriage .~ Flying 0
+    , Just ReturnToHive <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just ReturnToHive <- cr ^? crActionPlan . apStrategy = w 
+    | Just x <- cr ^? crType . beeSlime 
+    , x >= 1500 = starthivereturn
+        & randGen .~ gsa
+        & tocr . crType . beeLifespan %~ max 0 . subtract sa
     | Just mid <- cr ^? crStance . carriage . mountID
-    , mountshakeoff mid = w & tocr . crActionPlan . apStrategy .~ Search
+    , mountshakeoff mid = startsearch
-            & tocr . crStance . carriage .~ Flying 0
-    | Just hcr <- gethive
-    , Just x <- cr ^? crType . beeSlime 
-    , x >= 15
-        = w & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
     | Nothing <- cr ^? crActionPlan . apStrategy . harvestTarget 
-    ,  Just tcr <- listToMaybe . sortOn (distance cxy . (^. crPos . _xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w =
+    ,  xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g') <- runState (takeOne xs) (w ^. randGen) =
          w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+            & randGen .~ g'
     | Just tid <- cr ^? crStance . carriage . mountID
     , Just SlimeCrit{} <- w ^? cWorld . lWorld . creatures . ix tid . crType = w
         & tocr . crType . beeSlime +~ sspeed
-        & cWorld . lWorld . creatures . ix tid . crType . slimeRad %~ (sqrt . subtract sspeed . (^(2::Int)))
+        & cWorld . lWorld . creatures . ix tid . crType . slimeSlime -~ sspeed
     | Just (tcr,ti) <- gettarg
-    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.9*crRad (tcr ^. crType) 
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.8*crRad (tcr ^. crType) 
-    , Just r <- tcr ^? crType . slimeRad
     , Just d <- tcr ^? crType . slimeCompression
         = w
-        & tocr . crStance . carriage .~ Mounted ti (cr ^. crPos - tcr ^. crPos & _xy %~ compressionScale (vNormal ((1/r) *^d)))
+        & tocr . crStance . carriage .~ Mounted ti 
+            (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
-    | otherwise = w & tocr . crActionPlan . apStrategy .~ Search
+    | Just (HarvestFrom{}) <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just (SearchTimed 0) <- cr ^? crActionPlan . apStrategy = starthivereturn
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w
+        & tocr . crActionPlan . apStrategy . searchTimer %~ (max 0 . subtract 1)
+    | otherwise = startsearch
   where
+    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 True $ do
+    mountshakeoff mid = fromMaybe False $ do
         mcr <- w ^? cWorld . lWorld . creatures . ix mid
-        SlimeCrit {_slimeSplitTimer = x} <- mcr ^? crType
+        x <- mcr ^? crType . slimeDistortion . sdTime
-        return $ x > 0
+        return $ x > 8
-    sspeed = 0.05
+    sspeed = 5
     gettarg = do
         i <- cr ^? crActionPlan . apStrategy . harvestTarget 
         tcr <-  w ^? cWorld . lWorld . creatures . ix i
-        x <- tcr ^? crType . slimeRad
+        x <- tcr ^? crType . slimeSlime . to slimeToRad
         guard $ x > 12
         return (tcr,i)
     gethive = do
@@ -184,42 +246,38 @@ updateCalmBee cr cid w
         w ^? cWorld . lWorld . creatures . ix i
     tocr = cWorld . lWorld . creatures . ix cid
     istarget tcr = fromMaybe False $ do
-        r <- tcr ^? crType . slimeRad
+        r <- tcr ^? crType . slimeSlime . to slimeToRad
         return $ r > 12
 
-slimeCritUpdate :: Int -> World -> World
+updateSlimeCrit :: Int -> World -> World
-slimeCritUpdate cid w 
+updateSlimeCrit cid w 
-    | r < 5 = w & cWorld . lWorld . creatures . ix cid . crHP .~ CrDestroyed Gibbed
+    | 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 (cr1,cr2) <- splitSlimeCrit hitp hitv cr
---            = 
---        let cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
---        in w & cWorld . lWorld . creatures . ix cid .~ cr1
---            & cWorld . lWorld . creatures . at cid' ?~ (cr2 & crID .~ cid')
         , Just w' <- splitSlimeCrit' hitp hitv cid cr w = w'
-    | (cr ^?! crType . slimeIsCompressing) && r > norm p
+    | (cr ^?! crType . slimeIsCompressing) && 1 > p
-        = let (w',g) = runState (setSlimeDir cid (cr & crDamage .~ []) w) (w ^. randGen)
+        = 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 %~ mvslime
         & cWorld . lWorld . creatures . ix cid . crDamage .~ []
         & tocr %~ doSlimeRadChange
-        & tocr . crType . slimeSplitTimer %~ (max 0 . subtract 1)
+        & 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
-    v = 0.1 *^ normalize p 
+    mvslime cr' = cr' & crType . slimeCompression +~ f (0.1/r)
-    mvslime = cr & crType . slimeCompression +~ f v
+        & crPos . _xy +~ 0.1 *^ unitVectorAtAngle (cr' ^. crDir)
-        & crPos . _xy +~ v
         & crType . slimeIsCompressing %~ f'
-    f | t = negate
+    f | cr ^?! crType . slimeIsCompressing = negate
       | otherwise = id
-    f'  | norm p > 3*r/2 = const True
+    f'  | p > 1.5 = const True
         | otherwise = id
-    t = cr ^?! crType . slimeIsCompressing
+    r = cr ^?! crType . slimeSlime . to slimeToRad
-    r = cr ^?! crType . slimeRad
     p = cr ^?! crType . slimeCompression
 
 setSlimeDir :: Int -> Creature -> World -> State StdGen World
@@ -230,24 +288,19 @@ setSlimeDir cid cr w = do
         then do
             x <- randInCirc 1
             return $ fromMaybe w $ splitSlimeCrit' (x + cxy) (unitVectorAtAngle d) cid cr w
---            let (cr1,cr2) = splitSlimeCrit (x + cxy) (unitVectorAtAngle d) cr ^?! _Just
+        else return $ w & tocr . crDir .~ d
---                cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
---            return $ w & tocr .~ cr1
---                & tocr' cid' ?~ (cr2 & crID .~ cid')
-        else return $ w & tocr . crType . slimeCompression .~ r *^ unitVectorAtAngle d
                 & tocr . crType . slimeIsCompressing .~ False
+                & tocr . crDamage .~ mempty
   where
     tocr = cWorld . lWorld . creatures . ix cid
---    tocr' i = cWorld . lWorld . creatures . at i
     cxy = cr ^. crPos . _xy
-    r = cr ^?! crType . slimeRad
+    r = cr ^?! crType . slimeSlime . to slimeToRad
-    
 
 doSlimeRadChange :: Creature -> Creature
-doSlimeRadChange = crType . slimeRadWobble %~ f
+doSlimeRadChange = crType . slimeSlimeChange %~ f
   where
-    f x | x > 1 = x - 1
+    f x | x > 1000 = x - 1000
-        | x < -1 = x + 1
+        | x < -1000 = x + 1000
         | otherwise = 0
 
 splitSlimeCrit' :: Point2 -> Point2 -> Int -> Creature -> World -> Maybe World
@@ -272,23 +325,31 @@ splitSlimeCrit p v cr = do
         mvdir 
             | isLHS p (p+v) cxy = normalize (vNormal v)
             | otherwise = - normalize (vNormal v)
-    return (cr' & crPos . _xy .~ mp + (r1 + 0.51) *^ mvdir
+        (ps',qs') 
-                & crType . slimeRad .~ r1
+            | isLHS p (p+v) cxy = (ps,qs)
-                & crType . slimeCompression .~ rotateV (argV mvdir) (V2 r1 0)
+            | otherwise = (qs,ps)
+        c1 = cr' & crPos . _xy .~ mp + r1 *^ mvdir
+                & crType . slimeSlime .~ round (r1 ^ (2 :: Int) * 100)
                 & crDir .~ argV mvdir
-        ,cr' & crPos . _xy .~ mp - (r2 + 0.51) *^ mvdir
+        c2 = cr' & crPos . _xy .~ mp - r2 *^ mvdir
-                & crType . slimeRad .~ r2
+                & crType . slimeSlime .~ round (r2^(2::Int) * 100)
-                & crType . slimeCompression .~ rotateV (argV (-mvdir)) (V2 r2 0)
                 & crDir .~ argV (-mvdir)
-                & crType . slimeEngulfProgress .~ 0
+        c1ps = qs' & each +~ cxy - (mp + r1 *^ mvdir) & each %~ rotateV (- c1 ^. crDir)
+        c2ps = ps' & each +~ cxy - (mp - r2 *^ mvdir) & each %~ rotateV (- c2 ^. crDir)
+    return (c1 & crType . 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 . slimeRad
+    r = cr ^?! crType . slimeSlime . to slimeToRad
     cr' = cr & crDamage .~ []
-        & crType . slimeRadWobble .~ 0
+        & crType . slimeSlimeChange .~ 0
-        & crType . slimeSplitTimer .~ 10
+        & 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
@@ -307,20 +368,146 @@ slinkCritUpdate cid w =
         . _2
         *~ Q.axisAngle (V3 0 1 0) (pi / 1000)
 
--- spineWalk :: [Point3Q]
+setChaseCritKinematics :: Int -> World -> World
--- spineWalk = replicate 15 (V3
+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
+hoverCritHoverSound cr w
-    guard $ d < 100
+    | d < 100 
-    return $
+        = soundContinueVol (0.5 * (1 - 0.01 * d)) (CrSound cid) cxy buzz1S (Just 2) w
-        soundContinueVol
+    | otherwise = w
-            (0.5 * (1 - 0.01 * d))
-            (CrSound cid)
-            cxy
-            buzz1S
-            (Just 2)
-            w
   where
     cxy = cr ^. crPos . _xy
     d = max 0 (dist (you w ^. crPos . _xy) cxy - 100)
@@ -346,9 +533,7 @@ checkDeath cid w = maybe id checkDeath' (w ^? cWorld . lWorld . creatures . ix c
 checkDeath' :: Creature -> World -> World
 checkDeath' cr w = case cr ^. crHP of
     HP x | x > 0 -> w
-    HP x
+    HP x | x > -200 && null (cr ^. crDeathTimer) -> w & tocr %~ startDeathTimer
-        | x > -200 && null (cr ^. crDeathTimer) ->
-            w & tocr %~ startDeathTimer
     HP x
         | x > -200
         , Just y <- cr ^. crDeathTimer
@@ -371,11 +556,15 @@ crDeathEffects cr w = case cr ^. crType of
         return $ w & cWorld . lWorld . creatures . ix hid . crType . hiveChildren %~ IS.delete (cr ^. crID)
     _ -> w
   where
-    beepheremone = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos . _xy) 200
+    beepheremone 
+        | Just x <- cr ^? crType . beeLifespan
+        ,   x < 1 = id
+        | otherwise = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos) (cr ^. crPos - cr ^. crOldPos) 200
 
 startDeathTimer :: Creature -> Creature
 startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
             HoverCrit{} -> 0
+            BeeCrit{} -> 0
             _ -> 5
 
 toDeathCarriage :: Carriage -> Carriage
@@ -397,7 +586,7 @@ corpseOrGib cr w =
         Just PhysicalDamage
             | _crPain cr > 300 ->
                 makeCrGibs cr
-                    . sethp (CrDestroyed Gibbed)
+                    . (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature)
                     . dodeathsound GibsDeath
         _ ->
             sethp (CrIsCorpse thecorpse)
@@ -414,7 +603,7 @@ corpseOrGib cr w =
                 .~ g
     cid = cr ^. crID
     sethp x = cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ x
-    thecorpse = makeCorpse (w ^. randGen) cr
+    thecorpse = makeCorpse w (w ^. randGen) cr
 
 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
@@ -426,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/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 (Sel 0 invid) <- w ^. hud .diSelection
-    , Just itid <- lw ^? creatures . ix 0 . crInv . ix invid =
+    , 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 =
+    , AtEase <- cr ^. crStance . posture = setposture Aiming (-twistAmount)
-        setposture Aiming (-twoHandTwistAmount)
+    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn w mousedir cr
-    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn (w ^. cWorld . lWorld) mousedir cr
+    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twistAmount
-    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twoHandTwistAmount
---    | otherwise = creatureTurnTowardDir (_crMvAim cr) 0.2 cr
     | 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
+twistAmount :: Float
-twoHandTwistAmount = 1.6 * pi
+twistAmount = 1.6 * pi
 
-wasdMovement :: LWorld -> Input -> Camera -> Float -> Creature -> Creature
+wasdMovement :: World -> Input -> Camera -> Float -> Creature -> Creature
-wasdMovement lw inp cam speed = theMovement -- . setMvAim
+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
+        itRef <- lw ^? hud . manObject . hiRootSelectedItem
-        fmap itemBulkiness $ cr ^? crInv . ix itRef >>= \k -> lw ^? items . ix k . itType
+        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
+    case w ^.hud.diSelection of
-        ^? cWorld
+        Just (Sel 0 invid) -> useItem invid ltime w
-        . lWorld
+        _ -> interactWithCloseObj <$> getSelectedCloseObj w ?? w
-        . creatures
-        . ix 0
-        . crManipulation
-        . manObject
-        . imSelectedItem
-        . unNInt of
-        Just invid -> useItem invid ltime w
-        Nothing -> 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
+--doCrWdAc :: CrWdAc -> Creature -> World -> Action
-doCrAc ca = case ca of
+--doCrWdAc cw = case cw of
-    CrTurnAround -> \cr -> TurnToPoint 
+--    CrWdBFSThenReturn _ -> const $ const NoAction
-        (cr ^. crPos . _xy -.- 10 *.* unitVectorAtAngle (_crDir cr))
---    CrFleeFromTarget -> fleeFromTarget
-
---fleeFromTarget :: Creature -> Action
---fleeFromTarget cr = fleeFrom cr (_targetCr (_crIntention cr))
-
-doCrWdAc :: CrWdAc -> Creature -> World -> Action
-doCrWdAc cw = case cw of
-    CrWdBFSThenReturn _ -> const $ const NoAction
 --    CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
 --        n <- walkableNodeNear w (cr ^. crPos . _xy)
 --        let as = take 20 $ map PathTo $ bfsNodePoints n w
@@ -56,7 +47,7 @@ doCrWdAc cw = case cw of
 --            DoReplicate t $
 --                foldr DoActionThen NoAction as
 --    ChooseMovementSpreadGun -> chooseMovementSpreadGun
-    ChooseMovementLtAuto -> chooseMovementLtAuto
+--    ChooseMovementLtAuto -> chooseMovementLtAuto
 
 --chooseMovementSpreadGun :: Creature -> World -> Action
 --chooseMovementSpreadGun cr w

src/Dodge/Data/ActionPlan.hs

@@ -17,8 +17,8 @@ data ActionPlan
     | ActionPlan
         { -- _apImpulse :: [Impulse] -- done per frame
          _apAction :: Action -- updated per frame, likely persist across frames
-        , _apStrategy :: Strategy -- current strategy
+        , _apStrategy :: Strategy
-        , _apGoal :: [Goal] -- particular ordered goals
+        , _apGoal :: Goal
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     deriving (Eq, Ord, Show) --Generic, Flat)
@@ -45,10 +45,11 @@ data Impulse
     | ChangePosture Posture
     | MakeSound SoundID
     | ChangeStrategy Strategy
-    | AddGoal Goal
+--    | AddGoal Goal
     | ImpulseUseTarget { _impulseUseTarget :: CrImp }
     | ImpulseNothing
     | UpdateRandGen
+    | SetBeeRandomMovement
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data RandImpulse
@@ -61,7 +62,7 @@ infixr 9 `WaitThen`
 
 infixr 9 `DoActionThen`
 
-infixr 9 `DoActionWhile`
+--infixr 9 `DoActionWhile`
 
 infixr 9 `DoReplicate`
 
@@ -73,6 +74,7 @@ data Action
         , _targetSeenAt :: Point2
         }
     | PathTo { _pathToPoint :: Point2, _pathFailAction :: Action }
+    | Eat {_targetID :: Int, _acTimer :: Int}
     | EvadeAim
     | TurnToPoint { _turnToPoint :: Point2 }
     | ImpulsesList { _impulsesListList :: [[Impulse]], _acAction :: Action }
@@ -81,10 +83,6 @@ data Action
         { _waitThenTimer :: Int
         , _waitThenAction :: Action
         }
-    | DoActionWhile
-        { _doActionWhileCondition :: WdCrBl
-        , _doActionWhileAction :: Action
-        }
     | DoActionWhilePartial
         { _doActionWhilePartial :: Action
         , _doActionWhileCondition :: WdCrBl
@@ -120,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]
@@ -137,25 +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,6 +37,7 @@ data Gas = Gas
     , _gsVel :: Point3
     , _gsTimer :: Int
     , _gsType :: GasType
+    , _gsOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
@@ -43,7 +45,8 @@ data GasType = PoisonGas
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BeePheremone = BPheremone
-    { _bpPos :: Point2
+    { _bpPos :: Point3
+    , _bpVel :: Point3
     , _bpTimer :: Int
     }
 

src/Dodge/Data/Config.hs

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

src/Dodge/Data/Creature.hs

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

src/Dodge/Data/Creature/Misc.hs

@@ -1,17 +1,13 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Dodge.Data.Creature.Misc (
+module Dodge.Data.Creature.Misc (module Dodge.Data.Creature.Misc) where
-    module Dodge.Data.Creature.Misc,
-    module Dodge.Data.CamouflageStatus,
-) where
 
 import Dodge.Data.Creature.Stance
 import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import Dodge.Data.CamouflageStatus
 import Dodge.Data.FloatFunction
 import Dodge.Data.Material
 import Geometry.Data
@@ -36,6 +32,11 @@ data CrMvType
         , _mvTurnSpeed :: Float
         , _mvPulseTime :: Int
         }
+    | BeeMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Pulse = PulseStatus
@@ -58,6 +59,13 @@ 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
@@ -73,28 +81,50 @@ data CreatureType
         , _slinkHeadPos :: Point3Q
         }
     | SlimeCrit
-        { _slimeRad :: Float
+        { _slimeSlime :: Int -- note multiplied by 100
-        , _slimeRadWobble :: Float
+        , _slimeSlimeChange :: Int
-        , _slimeSplitTimer :: Int
+--        , _slimeRadWobble :: Float
-        , _slimeCompression :: Point2
+        --, _slimeSplitTimer :: Int
+        , _slimeDistortion :: SlimeShapeDistortion
+        , _slimeCompression :: Float
         , _slimeIsCompressing :: Bool
         , _slimeEngulfProgress :: Float
         } 
     | BeeCrit
-        { _beeSlime :: Float
+        { _beeSlime :: Int
         , _beeHive :: Maybe Int
         , _startStopMv :: Int
         , _beeAggro :: Int
+        , _meleeCooldown :: Int
+        , _beeRandomMovement :: Maybe FootForward
+        , _beeLifespan :: Int
         }
     | HiveCrit
         { _hiveChildren :: IS.IntSet
         , _hiveGestation :: Int
+        , _hiveSlime :: Int
         }
     | SwarmCrit
     | AutoCrit
     | BarrelCrit {_barrelType :: BarrelType}
     | LampCrit {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int}
 
+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
@@ -118,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/CreatureEffect.hs

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

src/Dodge/Data/Damage.hs

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

src/Dodge/Data/EnergyBall.hs

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

src/Dodge/Data/EnergyBall/Type.hs

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

src/Dodge/Data/Flame.hs

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

src/Dodge/Data/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
@@ -15,8 +16,8 @@ data MouseContext
     | MouseAiming
     | MouseInGame
     | MouseMenu {_mcoMenuClick :: Maybe Int}
-    | OverInvDrag {_mcoDragSection :: Int , _mcoMaybeSelect :: Maybe (Int,Int) }
+    | OverInvDrag {_mcoDragSection :: Int }
-    | OverInvDragSelect { _mcoSecSelStart :: Maybe (Int,Int), _mcoSelEnd :: Maybe Int }
+    | OverInvDragSelect { _mcoSecSelStart :: XInfinity (Int,Int) }
     | OverInvSelect { _mcoInvSelect :: (Int,Int)}
     | OverCombFiltInv { _mcoInvFilt :: (Int,Int)}
     | OverCombSelect { _mcoCombSelect :: (Int,Int)}

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"
+            <> "esite"
-            <> shortShow rootb
-            <> "sel"
-            <> shortShow selb
-            <> "att"
-            <> shortShow attb
             <> 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
+    = HeldItem
-    | SelectedItem
+        { _hiRootSelectedItem :: NewInt InvInt
-        { _imSelectedItem :: NewInt InvInt
+        , _hiAimStance :: AimStance
-        , _imRootSelectedItem :: NewInt InvInt
+        , _hiAttachedItems :: IS.IntSet -- this should probably be NewIntSet InvInt also
-        , _imAimStance :: AimStance
-        , _imAttachedItems :: IS.IntSet -- this should probably be NewIntSet InvInt also
         }    
-    | SelNothing
+    | HandsFree
-    | SortCloseItem
-    | SelCloseItem {_ispCloseItem :: Int}
-    | SortCloseButton
-    | SelCloseButton {_ispCloseButton :: Int}
-     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''ManipulatedObject
-makeLenses ''Manipulation
 deriveJSON defaultOptions ''ManipulatedObject
-deriveJSON defaultOptions ''Manipulation

src/Dodge/Data/LWorld.hs

@@ -146,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 (module Dodge.Data.PlasmaBall) where
-    module Dodge.Data.PlasmaBall
-) where
 
+import Dodge.Data.Damage
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -14,6 +13,7 @@ data PlasmaBall = PBall
     { _pbType :: PlasmaBallType
     , _pbVel :: Point2
     , _pbPos :: Point2
+    , _pbOrigin :: DamageOrigin
     }
     deriving (Show, Eq, Ord, Read) --Generic, Flat)
 

src/Dodge/Data/Projectile.hs

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

src/Dodge/Data/PulseLaser.hs

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

src/Dodge/Data/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/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/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,6 +5,7 @@ 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
@@ -15,42 +16,40 @@ 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
+        , _crType =
---        , _crRad = 10
+            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 NoAction (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper]
+        , _crActionPlan = ActionPlan NoAction WatchAndWait LiveLongAndProsper
         , _crPerception = defaultPerceptionState
         , _crMemory = defaultCreatureMemory
         , _crFaction = NoFaction
         , _crIntention = defaultIntention
         , _crGroup = LoneWolf
         , _crName = "DEFAULTCRNAME"
---        , _crStatistics = CreatureStatistics 50 50 50
         , _crDeathTimer = Nothing
         , _crWallTouch = mempty
         }
@@ -102,7 +101,6 @@ defaultIntention =
         , _viewPoint = Nothing
         }
 
-
 defaultAimingCrit :: Creature
 defaultAimingCrit = defaultCreature
 

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
@@ -177,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
+        si & ciSelection ?~ Sel 0 (-1)
-            & ciSelection
+            & ciSelection %~ scrollSelectionSections (-1) sss
-            %~ 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 :: Int -> Maybe Int -> IMSI a -> Int -> (Int,IS.IntSet) -> SelSection a
-updateSection indent mcsel sis availablelines oldoffset =
+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
+        & hud . diInvFilter .~ Nothing
-        .~ Nothing

src/Dodge/EnergyBall.hs

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

src/Dodge/EnergyBall/Draw.hs

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

src/Dodge/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 :: Point2 -> Point2 -> DamageOrigin -> World -> World
-makeFlame pos vel w =
+makeFlame pos vel d w =
     w
-        & cWorld . lWorld . flames .:~ Flame t pos vel
+        & cWorld . lWorld . flames .:~ Flame t pos vel d
         & randGen .~ g
   where
     (t, g) = randomR (99, 102) (_randGen w)

src/Dodge/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 . floorItems . at i ?~ FlIt q r
-        & cWorld . lWorld . items . at (it ^. itID . unNInt) ?~ (it & itLocation .~ OnFloor)
+        & 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

@@ -454,8 +454,7 @@ itemSidePush = \case
 
 applyInvLock :: Item -> Creature -> World -> World
 applyInvLock itm cr = case itemInvLock itm of
-    i
+    i | i > 0 && cid == 0 ->
-        | 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)
+        MuzzlePulseBall -> shootPulseBall o pq' (w & randGen .~ g)
-        MuzzlePlasmaBall -> shootPlasmaBall pq' (w & randGen .~ g)
+        MuzzlePlasmaBall -> shootPlasmaBall o pq' (w & randGen .~ g)
-        MuzzleTesla -> shootTeslaArc pq' loc (w & randGen .~ g)
+        MuzzleTesla -> shootTeslaArc o pq' loc (w & randGen .~ g)
         MuzzleTractor -> shootTractorBeam cr w
         MuzzleRLauncher -> createProjectileR pq loc magtree cr w
         MuzzleGLauncher ->
@@ -776,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
+    o = CrWeaponO $ cr ^. crID
-    (pq', g) = muzzleRandPos loc cr mz `runState` (w ^. randGen)
+    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 :: World -> LocationDT OItem -> Creature -> Muzzle -> Point3Q
-muzzlePos m cr muz = (p1, q1) `Q.comp` pq `Q.comp` (p3, q3)
+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 :: World -> LocationDT OItem -> Creature -> Muzzle -> State StdGen Point3Q
-muzzleRandPos m cr muz = do
+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 :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
-creatureShootLaser (p, q) loc =
+creatureShootLaser o (p, q) loc =
     shootLaser
+        o
         (ItemSound (loc ^. locDT . dtValue . _1 . itID . unNInt) 0)
         (getLaserDamage loc)
         (getLaserPhaseV loc)
@@ -866,6 +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 :: DamageOrigin -> SoundOrigin -> Point2 -> Float -> World -> World
-shootPulseLaser so p dir w =
+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 :: DamageOrigin -> Point3Q -> World -> World
-shootPlasmaBall (p, q) w =
+shootPlasmaBall o (p, q) w =
     w
         & cWorld . lWorld . plasmaBalls .:~
             PBall
                 { _pbPos = p ^. _xy
                 , _pbVel = 6 * unitVectorAtAngle (Q.qToAng q)
                 , _pbType = DefaultPlasma
+                , _pbOrigin = o
                 }
 --        & soundStart (PBSound i) (p ^. _xy) energyReleaseS Nothing
 
 
-shootPulseBall :: Point3Q -> World -> World
+shootPulseBall :: DamageOrigin -> Point3Q -> World -> World
-shootPulseBall (p, q) w =
+shootPulseBall o (p, q) w =
     w
         & cWorld . lWorld . pulseBalls . at i
             ?~ PulseBall
@@ -925,6 +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
@@ -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 :: DamageOrigin -> Point3Q -> LocationDT OItem -> World -> World
-shootTeslaArc (p, q) loc w =
+shootTeslaArc o (p, q) loc w =
     w' & cWorld . lWorld . items . ix itid . itParams .~ ip
         & soundContinue (ItemSound itid 0) pos elecCrackleS (Just 2)
   where
     itm = loc ^. locDT . dtValue . _1
     itid = itm ^. itID . unNInt
-    (w', ip) = makeTeslaArc (itm ^. itParams) pos (Q.qToAng q) w
+    (w', ip) = makeTeslaArc o (itm ^. itParams) pos (Q.qToAng q) w
     pos = p ^. _xy
 
 determineProjectileTracking :: DTree OItem -> DTree OItem -> RocketHoming
@@ -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
+    j <- getInventoryPath w i ip invid cr
-    return $ dropItem cr j
+    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
+useInventoryPath pt i ip loc cr w = fromMaybe w $ do
-    ABSOLUTE -> fromMaybe w $ do
+    invid <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
-        guard $ i `IM.member` (cr ^. crInv . unNIntMap)
+    j <- getInventoryPath w i ip invid cr
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem i pt)
+    return $ w & cWorld . lWorld . delayedEvents .:~ (1,UseInvItem j pt)
-    RELCURS -> fromMaybe w $ do
+-- = case ip of
-        j <- cr ^? crManipulation . manObject . imSelectedItem . unNInt
+--    ABSOLUTE -> fromMaybe w $ useat i
-        guard $ (i + j) `IM.member` (cr ^. crInv . unNIntMap)
+--    RELCURS -> fromMaybe w $ do
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem (i + j) pt)
+--        Sel 0 j <- w ^? hud .diSelection._Just
-    RELITEM -> fromMaybe w $ do
+--        useat $ i + j
-        j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
+--    RELITEM -> fromMaybe w $ do
-        guard $ (i + j) `IM.member` (cr ^. crInv . unNIntMap)
+--        j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
-        return $ w & cWorld . lWorld . delayedEvents .:~ (1, UseInvItem (i + j) pt)
+--        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,64 +1,40 @@
 module Dodge.Humanoid (
-    chaseCritInternal,
     crabCritInternal,
-    hoverCritInternal,
+    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
-        , setMvPosToTargetCr
-        , chaseCritMv
-        , perceptionUpdate [0]
-        , targetYouWhenCognizant
-        , const searchIfDamaged
-        , const (crType . meleeCooldown %~ max 0 . subtract 1)
-        , const (crVocalization %~ updateVocTimer)
-        ]
-
 crabCritInternal :: Int -> World -> World
-crabCritInternal cid w =
+crabCritInternal cid w = w
---    (crVocalization %~ updateVocTimer)
+    & tocr %~ setViewPos w
-        (tocr %~ (crType . meleeCooldownL %~ max 0 . subtract 1))
+    & tocr %~ setMvPosToTargetCr w
-        . (tocr %~ (crType . meleeCooldownR %~ max 0 . subtract 1))
+    & crabActionUpdate cid
-        . (tocr %~ (crType . dodgeCooldown %~ max 0 . subtract 1))
+    & tocr %~ perceptionUpdate [0] w
-        . (tocr %~ searchIfDamaged)
+    & tocr %~ targetYouWhenCognizant w
-        . (tocr %~ targetYouWhenCognizant w)
+    & tocr %~ searchIfDamaged
-        . (tocr %~ perceptionUpdate [0] w)
+    & tocr . crType . dodgeCooldown %~ max 0 . subtract 1
-        . crabActionUpdate cid
+    & tocr . crType . meleeCooldownR %~ max 0 . subtract 1
-        . (tocr %~ setMvPosToTargetCr w)
+    & tocr . crType . meleeCooldownL %~ max 0 . subtract 1
-        . (tocr %~ setViewPos w)
---        . overrideMeleeCloseTarget w
-        $ (tocr %~ doStrategyActions) w
   where
     tocr = cWorld . lWorld . creatures . ix cid
 
-hoverCritInternal :: World -> Creature -> Creature
+updateHoverCrit :: Int -> World -> World
-hoverCritInternal w cr =
+updateHoverCrit cid w = w
-    foldl'
+        & tocr %~ overrideMeleeCloseTarget w
-        (\c f -> f w c)
+        & tocr %~ setViewPos w
-        cr
+        & tocr %~ setMvPosToTargetCr w
-        [ const doStrategyActions
+        & tocr %~ hoverCritMv w
-        , overrideMeleeCloseTarget
+        & tocr %~ perceptionUpdate [0] w
-        , setViewPos
+        & tocr %~ targetYouWhenCognizant w
-        , setMvPosToTargetCr
+        & tocr %~ searchIfDamaged
-        , hoverCritMv
+        & tocr . crType . meleeCooldown %~ max 0 . subtract 1
-        , perceptionUpdate [0]
+        & tocr . crVocalization %~ updateVocTimer
-        , targetYouWhenCognizant
+  where
-        , const searchIfDamaged
+    tocr = cWorld . lWorld . creatures . ix cid
-        , const (crType . meleeCooldown %~ max 0 . subtract 1)
-        , const (crVocalization %~ updateVocTimer)
-        ]
 
 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 =
+        | otherwise = id
-            pointcid . crManipulation . manObject . imSelectedItem %~ g
     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 <-
+        epos <- itm ^? itLocation . ilEquipSite . _Just
-            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
+            & hud . diSections . ix 3 . ssSet %~ swapInIntSet i k
-            & cWorld
-                . lWorld
-                . creatures
-                . ix 0
-                . crManipulation
-                . manObject
-                . manlens
-                %~ doswap
             & 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
+    3 -> changeSwapOther 3 f i
-    5 -> changeSwapOther ispCloseButton 5 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
+--        & crUpdateItemLocations
-        & cWorld . lWorld %~ crUpdateItemLocations 0
+        & 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 :: Maybe Int -> Int -> World -> Maybe (NewInt InvInt, World)
-tryPutItemInInv cid itid w = do
+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
+    maybeselect invid = fromMaybe id $ do
-        | cid == 0 = (hud . diSelection . _Just . slSet %~ IS.map (f i))
+        i <- mcipos
-            . (hud . diSelection . _Just . slInt %~ f i)
+        is <- w ^? hud . diSections . ix 3 . ssSet
-        | otherwise = id
+        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 :: Maybe Int -> Int -> Int -> World -> Maybe World
-tryPutItemInInvAt :: Int -> Int -> Int -> World -> Maybe World
+tryPutItemInInvAt mcipos i itid w = do
-tryPutItemInInvAt i cid itid w = do
+    (j, w') <- tryPutItemInInv mcipos itid w
-    (j, w') <- tryPutItemInInv cid 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 :: Int -> (Int,Int) -> World -> World
-pickUpItemAt invid cid itid w = fromMaybe w $ do
+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

src/Dodge/Inventory/Location.hs

@@ -1,20 +1,15 @@
 module Dodge.Inventory.Location (
-    updateRootItemID,
     crUpdateItemLocations,
     setInvPosFromSS,
 ) where
 
-import Dodge.Item.AimStance
 import Control.Lens
-import Data.Foldable
---import Data.IntMap.Merge.Strict
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Base.You
-import Dodge.Data.ComposedItem
-import Dodge.Data.DoubleTree
 import Dodge.Data.Item.Use.Consumption.LoadAction
 import Dodge.Data.World
+import Dodge.Item.AimStance
 import Dodge.Item.Grammar
 import qualified IntMapHelp as IM
 import NewInt
@@ -30,93 +25,39 @@ tryGetRootAttachedFromInvID (NInt invid) im = do
     t <- imroots ^? ix theroot . _2
     return (theroot, foldMap (IS.singleton . (^?! itLocation . ilInvID . unNInt)) t)
 
--- this assumes the creature inventory is well formed, specifically the
+crUpdateItemLocations :: World -> World
--- location ids
+crUpdateItemLocations lw = fromMaybe lw $ do
--- note the item intmap is all items
+    cinv <- lw ^? cWorld . lWorld . creatures . ix 0 . crInv
-getRootItemInvID :: IM.IntMap Item -> Int -> Creature -> Int
+    let crinv = fmap (\k -> lw ^?! cWorld . lWorld . items . ix k) cinv
-getRootItemInvID m i cr = fromMaybe i $ do
+    return $ IM.foldlWithKey' crUpdateInvidLocations lw $ _unNIntMap crinv
-    let adj = invAdj $ fmap (\k -> m ^?! ix k) (_crInv cr)
-    theroot <- adj ^? ix i
-    theroot ^? _1 . _Just . _1
 
-updateRootItemID :: IM.IntMap Item -> Creature -> Creature
+crUpdateInvidLocations :: World -> Int -> Item -> World
-updateRootItemID m cr = fromMaybe cr $ do
+crUpdateInvidLocations w invid itm =
-    i <- cr ^? crManipulation . manObject . imSelectedItem . unNInt
+    w
-    let j = getRootItemInvID m i cr
+        & cWorld . lWorld . creatures . ix 0 . crInv . ix (NInt invid) .~ itid
-    return $ cr & crManipulation . manObject . imRootSelectedItem .~ NInt j
+        & cWorld . lWorld . items . ix itid .~ (itm & itLocation .~ newloc)
-
--- the following assumes that the crManipulation is correct
-crUpdateItemLocations :: Int -> LWorld -> LWorld
-crUpdateItemLocations crid lw = fromMaybe lw $ do
-    mo <- lw ^? creatures . ix crid . crManipulation . manObject
-    cinv <- lw ^? creatures . ix crid . crInv
-    let crinv = fmap (\k -> lw ^?! items . ix k) cinv
-    return $ crSetRoots crid $ IM.foldlWithKey' (crUpdateInvidLocations mo crid) lw $ _unNIntMap crinv
-
-crSetRoots :: Int -> LWorld -> LWorld
-crSetRoots cid w = fromMaybe w $ do
-    inv <- w ^? creatures . ix cid . crInv
-    let cinv = invIMDT $ fmap (\i -> w ^?! items . ix i) inv
-    return $ foldl' f (foldl' g w inv) cinv
-  where
-    g w' i = w' & items . ix i . itLocation . ilIsRoot .~ False
-    f :: LWorld -> DTree OItem -> LWorld
-    f w' x =
-        w' & items . ix (x ^. dtValue . _1 . itID . unNInt) . itLocation . ilIsRoot .~ True
-
-crUpdateInvidLocations ::
-    ManipulatedObject ->
-    Int ->
-    LWorld ->
-    Int ->
-    Item ->
-    LWorld
-crUpdateInvidLocations mo crid lw invid itm =
-    lw
-        & creatures . ix crid . crInv . ix (NInt invid) .~ itid
-        & items . ix itid .~ (itm & itLocation .~ newloc)
   where
     itid = itm ^. itID . unNInt
     newloc =
         InInv
-            { _ilCrID = crid
+            { _ilCrID = 0
             , _ilInvID = NInt invid
-            , _ilIsRoot = Just (NInt invid) == mo ^? imRootSelectedItem
+            , _ilEquipSite = w ^? cWorld . lWorld . items . ix itid . itLocation . ilEquipSite . _Just
-            , _ilIsSelected = Just (NInt invid) == mo ^? imSelectedItem
-            , _ilIsAttached = invid `IS.member` (mo ^. imAttachedItems)
-            , _ilEquipSite = lw ^? items . ix itid . itLocation . ilEquipSite . _Just
             }
 
--- this should be looked at, as it is sometimes used in functions that need not
--- concern the player creature
--- this might not work if the selpos is in the inventory but too large
 setInvPosFromSS :: World -> World
-setInvPosFromSS w = w
+setInvPosFromSS w = w & hud . manObject .~ thesel
-        & cWorld . lWorld . creatures . ix 0 . crManipulation . manObject .~ thesel
   where
-    thesel = fromMaybe SelNothing $ do
+    invitemmap =
-        Sel i j _ <- w ^? hud . diSelection . _Just
+        (\k -> w ^?! cWorld . lWorld . items . ix k)
-        case i of
+            <$> you w ^. crInv
-            (-1) -> Just SortInventory
+    thesel = fromMaybe HandsFree $ do
-            0 -> do
+        Sel 0 j <- w ^? hud . diSelection . _Just
-                (rootid, aset) <-
+        (rootid, aset) <- tryGetRootAttachedFromInvID (NInt j) invitemmap
-                    tryGetRootAttachedFromInvID
+        dt <- invIMDT invitemmap ^? ix rootid
-                        (NInt j)
-                        ( fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $
-                            you w ^. crInv
-                        )
-                dt <- invIMDT ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> you w ^. crInv) ^? ix rootid
-                -- there is redundancy above
         return
-                    SelectedItem
+            HeldItem
-                        { _imSelectedItem = NInt j
+                { _hiRootSelectedItem = NInt rootid
-                        , _imRootSelectedItem = NInt rootid
+                , _hiAimStance = itemAimStance ((\(x, y, _) -> (x, y)) <$> dt)
-                        , _imAimStance = itemAimStance ((\(x,y,_) -> (x,y)) <$> dt)
+                , _hiAttachedItems = aset
-                        , _imAttachedItems = aset
                 }
-            1 -> Just SelNothing
-            2 -> Just SortCloseItem
-            3 -> Just $ SelCloseItem j
-            4 -> Just SortCloseButton
-            5 -> Just $ SelCloseButton j
-            _ -> error "selection out of bounds"

src/Dodge/Inventory/Path.hs

@@ -1,18 +1,18 @@
 module Dodge.Inventory.Path (getInventoryPath) where
 
+import Dodge.Data.World
 import NewInt
-import Dodge.Data.Creature
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
 
-getInventoryPath :: Int -> InventoryPathing -> Int -> Creature -> Maybe Int
+getInventoryPath :: World -> Int -> InventoryPathing -> Int -> Creature -> Maybe Int
-getInventoryPath x ip itid cr = case ip of
+getInventoryPath w x ip invid cr = case ip of
     ABSOLUTE -> checkinvid x
     RELCURS -> do
-        selid <- cr ^? crManipulation . manObject . imSelectedItem . unNInt
+        Sel 0 selid <- w ^? hud .diSelection._Just
         checkinvid (x + selid)
-    RELITEM -> checkinvid (itid + x)
+    RELITEM -> checkinvid (invid + x)
   where
     checkinvid y = do
         guard $ y `IM.member` (cr ^. crInv . unNIntMap)

src/Dodge/Inventory/RBList.hs

@@ -24,8 +24,9 @@ updateRBList w = case w ^. rbState of
     _ | norightclick -> w & rbState .~ NoRightButtonState
     EquipOptions{} -> w
     _ -> fromMaybe (w & rbState .~ NoRightButtonState) $ do
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud .diSelection._Just
-        itid <- cr ^? crInv . ix i
+--revise2        i <- w^?hud . manObject . imSelectedItem
+        itid <- cr ^? crInv . ix (NInt i)
         itm <- w ^? cWorld . lWorld . items . ix itid
         etype <- equipType itm
         return $

src/Dodge/Inventory/SelectionList.hs

@@ -33,9 +33,9 @@ import Picture.Base
 invSelectionItem :: World -> Int -> LocationDT OItem -> SelectionItem ()
 invSelectionItem w indent loc =
     SelItem
-        { _siPictures = itemDisplay w cr ci
+        { _siPictures = itemDisplay w (Just cr) $ ci ^. _1
         , _siHeight = itInvHeight $ ci ^. _1
-        , _siWidth = maximum (15 : (length <$> itemDisplay w cr ci))
+        , _siWidth = maximum (15 : (length <$> itemDisplay w (Just cr) (ci^._1)))
         , _siIsSelectable = True
         , _siColor = itemInvColor ci
         , _siOffX = indent
@@ -51,10 +51,9 @@ invSelectionItem w indent loc =
 
 -- note the convoluted display of the hotkey/equipment, this was done to avoid a
 -- space leak
-itemDisplay :: World -> Creature -> CItem -> [String]
+itemDisplay :: World -> Maybe Creature -> Item -> [String]
-itemDisplay w cr ci = basicItemDisplay itm `g` anyextra
+itemDisplay w mcr itm = basicItemDisplay itm `g` anyextra
   where
-    itm = ci ^. _1
     NInt itid = itm ^. itID
     g (x:xs) (Just y) = (x <> y) : xs
     g xs _ = xs
@@ -62,11 +61,11 @@ itemDisplay w cr ci = basicItemDisplay itm `g` anyextra
     anyhotkey = fmap hotkeyToString
         (w ^? cWorld . lWorld . imHotkeys . unNIntMap . ix itid)
     anyequippos = do
-        _ <- ci ^? _1 . itType . ibtEquip
+        _ <- itm ^? itType . ibtEquip
-        epText <$> ci ^? _1 . itLocation . ilEquipSite
+        epText <$> itm ^? itLocation . ilEquipSite
-    anyscroll = fmap absurround $ itemScrollDisplay =<< (ci ^? _1)
+    anyscroll = fmap absurround $ itemScrollDisplay =<< Just itm
     absurround str = " <" ++ str ++ ">"
-    anyexternal = fae <$> itemExternalValue itm w cr
+    anyexternal = fae <$> (itemExternalValue itm w =<< mcr)
     -- will probably want to remote the !
     fae (Left i) = " !"++shortShow i
     fae (Right s) = " !" ++ s
@@ -220,8 +219,9 @@ hotkeyToChar = \case
 
 closeItemToSelectionItem :: World -> Int -> Maybe (SelectionItem ())
 closeItemToSelectionItem w i = do
-    e <- w ^? cWorld . lWorld . items . ix i
+    itm <- w ^? cWorld . lWorld . items . ix i
-    let (pics, col) = closeItemToTextPictures e
+    let pics = itemDisplay w Nothing itm
+        col = itemInvColor (baseCI itm)
     return
         SelItem
             { _siPictures = pics
@@ -231,8 +231,12 @@ closeItemToSelectionItem w i = do
             , _siColor = col
             , _siOffX = 0
             , _siPayload = Nothing
-            , _siDisplayMod = DropShadowSI
+            , _siDisplayMod = dmod
             }
+  where
+    dmod = maybe DropShadowSI (const HighlightSI) 
+        $ w ^? cWorld . highlightItems . ix i
+    
 
 closeButtonToSelectionItem :: World -> Int -> Maybe (SelectionItem ())
 closeButtonToSelectionItem w i = do
@@ -256,6 +260,3 @@ btText bt = case _btEvent bt of
     ButtonSwitch {} -> "SWITCH"
     ButtonDumbSwitch {} -> "SWITCH"  -- do we want to show switch status?
     ButtonAccessTerminal i -> "TERMINAL " ++ show i
-
-closeItemToTextPictures :: Item -> ([String], Color)
-closeItemToTextPictures it = (basicItemDisplay it, itemInvColor $ baseCI it)

src/Dodge/Inventory/Swap.hs

@@ -1,6 +1,6 @@
 module Dodge.Inventory.Swap (
     swapInvItems,
-    swapAnyExtraSelection
+    swapInIntSet,
 ) where
 
 import Linear
@@ -11,13 +11,14 @@ import Dodge.Base.You
 import Dodge.Inventory.Location
 import Dodge.Data.DoubleTree
 import Sound.Data
-import qualified Data.IntSet as IS
+--import qualified Data.IntSet as IS
 import Data.Maybe
 import Control.Lens
 import Dodge.Data.SelectionList
 import qualified IntMapHelp as IM
 import Dodge.Data.World
 import Control.Monad
+import qualified Data.IntSet as IS
 
 swapInvItems ::
     (Int -> IM.IntMap (SelectionItem ()) -> Maybe Int) ->
@@ -28,25 +29,24 @@ swapInvItems f i w = fromMaybe w $ do
     ss <- w ^? hud . diSections . ix 0 . ssItems
     k <- f i ss
     let updateselection = case w ^? hud . diSelection . _Just of
-            Just (Sel 0 j _) | j == k -> hud . diSelection . _Just . slInt .~ i
+            Just (Sel 0 j) | j == k -> hud . diSelection . _Just . slInt .~ i
-            Just (Sel 0 j _) | j == i -> hud . diSelection . _Just . slInt .~ k
+            Just (Sel 0 j) | j == i -> hud . diSelection . _Just . slInt .~ k
             _ -> id
     return $
         w
-            & swapAnyExtraSelection i k
+            & hud . diSections . ix 0 . ssSet %~ swapInIntSet i k
             & checkConnection InventorySound disconnectItemS i k
             & cWorld . lWorld . creatures . ix 0 %~ updatecreature k
             & updateselection
             & worldEventFlags . at InventoryChange ?~ ()
-            & cWorld . lWorld %~ crUpdateItemLocations 0
+            & crUpdateItemLocations
             & setInvPosFromSS
-            & cWorld . lWorld %~ crUpdateItemLocations 0 -- the double application is inefficient, but necessary without further changes
+            & crUpdateItemLocations
             -- a rethink is maybe in order
             & checkConnection InventoryConnectSound connectItemS i k
   where
     updatecreature k =
         (crInv . unNIntMap %~ IM.safeSwapKeys i k)
-            . (crManipulation . manObject . imSelectedItem .~ NInt k)
             . swapSite i k
             . swapSite k i
     cr = you w
@@ -54,14 +54,11 @@ swapInvItems f i w = fromMaybe w $ do
         Just epos -> crEquipment . ix epos .~ NInt b
         Nothing -> id
 
-swapAnyExtraSelection :: Int -> Int -> World -> World
+swapInIntSet :: Int -> Int -> IS.IntSet -> IS.IntSet
-swapAnyExtraSelection i k w = fromMaybe w $ do
+swapInIntSet i k is
-    is <- w ^? hud . diSelection . _Just . slSet
+        | i `IS.member` is && not (k `IS.member` is) = IS.insert k $ IS.delete i is
-    let f = if i `IS.member` is then IS.insert k else id
+        | k `IS.member` is && not (i `IS.member` is) = IS.insert i $ IS.delete k is
-        g = if k `IS.member` is then IS.insert i else id
+        | otherwise = is
-    return $
-        w & hud . diSelection . _Just . slSet
-            %~ (f . g . IS.delete i . IS.delete k)
 
 checkConnection :: SoundOrigin -> SoundID -> Int -> Int -> World -> World
 checkConnection so s i j w = fromMaybe w $ do

src/Dodge/Item/BackgroundEffect.hs

@@ -7,6 +7,7 @@ module Dodge.Item.BackgroundEffect (
     removeShieldWall,
 ) where
 
+import NewInt
 import Linear
 import Control.Lens
 import Dodge.Creature.Radius
@@ -19,6 +20,8 @@ import Dodge.Wall.Create
 import Dodge.Wall.Delete
 import Dodge.Wall.Move
 import Geometry.Vector
+import qualified Data.IntSet as IS
+import Data.Maybe
 
 cancelExamineInventory :: World -> World
 cancelExamineInventory = hud . subInventory %~ f
@@ -33,9 +36,14 @@ rootNotrootEff ::
     Creature ->
     World ->
     World
-rootNotrootEff f g it
+rootNotrootEff f g it cr w
-    | it ^? itLocation . ilIsRoot == Just True = f it
+    | isroot = f it cr w
-    | otherwise = g it
+    | otherwise = g it cr w
+  where
+    isroot = fromMaybe False $ do
+        i <- it ^? itLocation . ilInvID
+        j <- w ^? hud . manObject . hiRootSelectedItem
+        return $ i == j
 
 rootAndAttNotEff ::
     (Item -> Creature -> World -> World) ->
@@ -44,11 +52,19 @@ rootAndAttNotEff ::
     Creature ->
     World ->
     World
-rootAndAttNotEff f g it
+rootAndAttNotEff f g it cr w
-    | it ^? itLocation . ilIsRoot == Just True 
+    | isroot && isattached
-        && it ^? itLocation . ilIsAttached == Just True
+        = f it cr w
-        = f it
+    | otherwise = g it cr w
-    | otherwise = g it
+  where
+    isattached = fromMaybe False $ do
+        i <- it ^? itLocation . ilInvID . unNInt
+        is <- w ^? hud . manObject . hiAttachedItems
+        return $ i `IS.member` is
+    isroot = fromMaybe False $ do
+        i <- it ^? itLocation . ilInvID
+        j <- w ^? hud . manObject . hiRootSelectedItem
+        return $ i == j
 
 createShieldWall :: Item -> Creature -> World -> World
 createShieldWall it cr w = case it ^? itParams . flatShieldWlMIX . _Just of

src/Dodge/Item/Draw.hs

@@ -2,11 +2,11 @@
 
 module Dodge.Item.Draw (itemEquipPict) where
 
+import Dodge.Data.World
 import Dodge.Item.Draw.SPicTree
 import Control.Lens
 import Dodge.Creature.HandPos
 import Dodge.Data.ComposedItem
-import Dodge.Data.Creature
 import Dodge.Data.DoubleTree
 import Dodge.Data.Equipment.Misc
 import Dodge.Item.Draw.SPic
@@ -15,13 +15,13 @@ import Geometry.Data
 import qualified Quaternion as Q
 import ShapePicture
 
-itemEquipPict :: Creature -> DTree CItem -> SPic
+itemEquipPict :: World -> Creature -> DTree CItem -> SPic
-itemEquipPict cr itmtree
+itemEquipPict w cr itmtree
     | Just esite <- itm ^? itLocation . ilEquipSite . _Just
       , Just attachpos <- equipAttachPos <$> itm ^? itType . ibtEquip =
-        equipPosition esite cr attachpos (itemSPic itm)
+        equipPosition esite w cr attachpos (itemSPic itm)
-    | itm ^? itLocation . ilInvID == cr ^? crManipulation . manObject . imRootSelectedItem =
+    | itm ^? itLocation . ilInvID == w ^? hud . manObject . hiRootSelectedItem =
-        overPosSP (Q.apply $ handHandleOrient loc cr) (itemTreeSPic itmtree)
+        overPosSP (Q.apply $ handHandleOrient w loc cr) (itemTreeSPic itmtree)
     | otherwise = mempty
   where
     itm = itmtree ^. dtValue . _1
@@ -35,7 +35,7 @@ equipAttachPos = \case
     BULLETBELTBRACER -> (V3 (-9) 0 10, Q.qid)
     _ -> (0, Q.qid)
 
-equipPosition :: EquipSite -> Creature -> Point3Q -> SPic -> SPic
+equipPosition :: EquipSite -> World -> Creature -> Point3Q -> SPic -> SPic
-equipPosition es cr q =
+equipPosition es w cr q =
     overPosSP
-        (\x -> fst $ equipSitePQ es cr `Q.comp` q `Q.comp` (x, Q.qid))
+        (\x -> fst $ equipSitePQ es w cr `Q.comp` q `Q.comp` (x, Q.qid))

src/Dodge/Item/HeldOffset.hs

@@ -7,13 +7,11 @@ module Dodge.Item.HeldOffset (
     handHandleOrient,
 ) where
 
+import Dodge.Data.World
 import Dodge.Creature.HandPos
 import Linear
-import Dodge.Data.AimStance
 import Dodge.Data.ComposedItem
-import Dodge.Data.Creature
 import Dodge.Data.DoubleTree
-import Dodge.Data.Machine
 import Dodge.DoubleTree
 import Dodge.Item.AimStance
 import Geometry
@@ -49,28 +47,28 @@ handleOrient loc = case loc ^. locDT . dtValue . _1 . itType of
 --        TwoHandUnder -> (V3 7 (-8) 15, Q.axisAngle (V3 0 0 1) (strideRot cr + 1.2))
 --        TwoHandOver -> (V3 10 0 15, Q.axisAngle (V3 0 0 1) (strideRot cr + 1.2))
 
-handOrient :: Creature -> AimStance -> Point3Q
+handOrient :: World -> Creature -> AimStance -> Point3Q
-handOrient cr = \case
+handOrient w cr = \case
     TwoHandTwist -> 
-        let (rp,_) = rightHandPQ cr
+        let (rp,_) = rightHandPQ w cr
-            (lp,_) = leftHandPQ cr
+            (lp,_) = leftHandPQ w cr
 --        in (rp,Q.qz (argV $ (lp - rp) ^. _xy))
         in (rp,Q.qNoRoll (lp - rp))
-    OneHand -> rightHandPQ cr
+    OneHand -> rightHandPQ w cr
     TwoHandFlat -> 
-        let (rp,_) = rightHandPQ cr
+        let (rp,_) = rightHandPQ w cr
-            (lp,_) = leftHandPQ cr
+            (lp,_) = leftHandPQ w cr
         in (0.5 *^ (rp + lp),Q.qz (argV (vNormal ((lp - rp) ^. _xy))))
 
 
-locOrient :: LocationDT OItem -> Creature -> Point3Q
+locOrient :: World -> LocationDT OItem -> Creature -> Point3Q
-locOrient loc cr =
+locOrient w loc cr =
-    handHandleOrient ((\(x, y, _) -> (x, y)) <$> locToTop loc) cr
+    handHandleOrient w ((\(x, y, _) -> (x, y)) <$> locToTop loc) cr
         `Q.comp` (loc ^. locDT . dtValue . _3)
 
-handHandleOrient :: LocationDT CItem -> Creature -> Point3Q
+handHandleOrient :: World -> LocationDT CItem -> Creature -> Point3Q
-handHandleOrient loc cr =
+handHandleOrient w loc cr =
-    handOrient cr (itemAimStance (l ^. locDT)) `Q.comp` handleOrient l
+    handOrient w cr (itemAimStance (l ^. locDT)) `Q.comp` handleOrient l
   where
     l = locToTop loc
 

src/Dodge/Item/Location.hs

@@ -2,13 +2,11 @@ module Dodge.Item.Location (
     pointerToItemID,
     --pointerToItemLocation,
     pointerToItem,
-    pointerYourSelectedItem,
-    pointerYourRootItem,
 ) where
 
 import NewInt
 import Control.Lens
-import Data.Maybe
+--import Data.Maybe
 import Dodge.Data.World
 
 --pointerToItemLocation ::
@@ -23,18 +21,17 @@ import Dodge.Data.World
 ----    cWorld . lWorld . floorItems . ix (_unNInt flid) . flIt
 --pointerToItemLocation _ = const pure
 
-pointerYourSelectedItem :: Applicative a => (Item -> a Item) -> World -> a World
+--pointerYourSelectedItem :: Applicative a => (Item -> a Item) -> World -> a World
-pointerYourSelectedItem f w = fromMaybe (pure w) $ do
+--pointerYourSelectedItem f w = fromMaybe (pure w) $ do
-    itinvid <- w ^? cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . imSelectedItem
+--    Sel 0 itinvid <- w ^? hud.diSelection._Just
-    itid <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix itinvid
+--    itid <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix (NInt itinvid)
-    Just $ (cWorld . lWorld . items . ix itid) f w
+--    Just $ (cWorld . lWorld . items . ix itid) f w
-    -- note the ilIsRoot/Selected/Attached booleans are irrelevant
+--
-
+--pointerYourRootItem :: Applicative a => (Item -> a Item) -> World -> a World
-pointerYourRootItem :: Applicative a => (Item -> a Item) -> World -> a World
+--pointerYourRootItem f w = fromMaybe (pure w) $ do
-pointerYourRootItem f w = fromMaybe (pure w) $ do
+--    itinvid <- w ^? hud. manObject . hiRootSelectedItem
-    itinvid <- w ^? cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . imRootSelectedItem
+--    itid <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix itinvid
-    itid <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix itinvid
+--    Just $ (cWorld . lWorld . items . ix itid) f w
-    Just $ (cWorld . lWorld . items . ix itid) f w
 
 pointerToItem :: Applicative f => Item -> (Item -> f Item) -> World -> f World
 pointerToItem x = cWorld . lWorld . items . ix (x ^. itID . unNInt)

src/Dodge/Item/Weapon/Bullet.hs

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

src/Dodge/Laser/Update.hs

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

src/Dodge/Machine/Destroy.hs

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

src/Dodge/Material/Damage.hs

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

src/Dodge/Payload.hs

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

src/Dodge/Projectile/Create.hs

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

src/Dodge/Projectile/Update.hs

@@ -1,7 +1,8 @@
 -- {-# LANGUAGE LambdaCase #-}
 -- {-# OPTIONS_GHC -Wno-unused-imports #-}
-module Dodge.Projectile.Update (updateProjectile) where
+module Dodge.Projectile.Update (updateProjectile,slimeEatSound) where
 
+import Dodge.Creature.Slime
 import Control.Monad
 import Data.List (delete)
 import Data.Maybe
@@ -81,8 +82,19 @@ stickHitSound pj =
         [slapS, slap1S, slap2S, slap3S, slap4S, slap5S, slap6S, slap7S]
         (pj ^. pjPos . _xy)
 
+slimeEatSound :: Int -> Point2 -> World -> World
+slimeEatSound i p w = w & soundStart (CrSound i) p s Nothing
+        & randGen .~ g
+      where
+        (s,g) = runState (takeOne [slurp1S,slurp2S,slurp3S,slurp4S,slurp5S]) (w ^. randGen)
+    
 shellHitCreature :: Point3 -> Creature -> Projectile -> World -> World
 shellHitCreature p cr pj
+    | SlimeCrit{} <- cr ^. crType = (cWorld . lWorld . projectiles . at (pj ^. pjID) .~ Nothing)
+        . (cWorld . lWorld . creatures . ix (cr ^. crID) . crType . slimeSlime +~ 100)
+        . (cWorld . lWorld . creatures . ix (cr ^. crID) . crType . slimeSlimeChange +~ 100)
+        . (cWorld . lWorld . creatures . ix (cr ^. crID) %~ slimeBulge (pj ^. pjPos))
+        . slimeEatSound (cr ^. crID) (cr ^. crPos . _xy)
     | Just GStick <- pj ^? pjType . gnHitEffect =
         (pjlens . pjType .~ Grenade gren)
             . stickHitSound pj
@@ -95,6 +107,13 @@ shellHitCreature p cr pj
             (rotate3z (-cr ^. crDir) (p - cr ^. crPos))
             (pj ^. pjDir - cr ^. crDir)
 
+slimeBulge :: Point3 -> Creature -> Creature
+slimeBulge p cr = cr
+    & crType . slimeDistortion .~ SlimeDistortion 10 (f <$>slimeOutline cr) False
+  where
+    v = rotateV (-cr ^. crDir) (normalize $ p ^. _xy - cr ^. crPos . _xy)
+    f x = x + (10 * max 0 (dot v (normalize x))) *^ v
+
 shellHitFloor :: Point3 -> Projectile -> World -> World
 shellHitFloor p pj =
     (topj . pjPos .~ (p & _z .~ 0.1))
@@ -143,6 +162,7 @@ doThrust pj smoke w =
         %~ (\v -> accel + frict *^ v)
         & soundContinue (ShellSound i) (ep ^. _xy) missileLaunchS (Just 1)
         & makeFlamelet
+            (pj ^. pjOrigin)
             (sp - 0.5 *^ vel)
             (vel + rotateV (pi + sparkD) accel `v2z` 0)
             3
@@ -196,26 +216,16 @@ doBarrelSpin cid i pj w =
 pjRemoteSetDirection :: RocketHoming -> Projectile -> World -> World
 pjRemoteSetDirection ph pj w = case ph of
     HomeUsingRemoteScreen screenid
-        | lw ^? creatures . ix 0 . crManipulation . manObject . imSelectedItem
+        | w ^. hud .diSelection
-            == lw ^? items . ix (_unNInt screenid) . itLocation . ilInvID ->
+            == fmap (\i -> Sel 0 (i^.unNInt)) (lw ^? items . ix (_unNInt screenid) . itLocation . ilInvID) ->
             w
-                & pjlens
+                & pjlens . pjDir .~ mousedir
-                . pjDir
+                & pjlens . pjSpin .~ 0.5 * diffAngles mousedir pjdir
-                .~ mousedir
-                & pjlens
-                . pjSpin
-                .~ 0.5
-                * diffAngles mousedir pjdir
     HomeUsingTargeting itid
         | Just tp <- w ^? pointerToItemID itid . itTargeting . itTgPos . _Just ->
             w
-                & pjlens
+                & pjlens . pjDir %~ turnTo 0.2 (pj ^. pjPos . _xy) tp
-                . pjDir
+                & pjlens . pjSpin .~ 0.5 * diffAngles
-                %~ turnTo 0.2 (pj ^. pjPos . _xy) tp
-                & pjlens
-                . pjSpin
-                .~ 0.5
-                * diffAngles
                     (turnTo 0.2 (pj ^. pjPos . _xy) tp pjdir)
                     pjdir
     _ -> w
@@ -258,15 +268,9 @@ moveProjectile pj w
         (_, Just (_, OChasmWall)) -> w & pjlens . pjTimer .~ 0 -- no stick or bounce for now
         _ ->
             w
-                & pjlens
+                & pjlens . pjSpin *~ 0.99
-                . pjSpin
+                & pjlens . pjPos +~ _pjVel pj
-                *~ 0.99
+                & pjlens . pjDir +~ _pjSpin pj
-                & pjlens
-                . pjPos
-                +~ _pjVel pj
-                & pjlens
-                . pjDir
-                +~ _pjSpin pj
   where
     pjlens = cWorld . lWorld . projectiles . ix (pj ^. pjID)
     sp = _pjPos pj
@@ -283,7 +287,7 @@ explodeShell pj w =
         & pjlens
         . pjTimer
         .~ 30
-        & usePayload (_pjPayload pj) (pj ^. pjPos) (pj ^. pjVel)
+        & usePayload (_pjPayload pj) (pj ^. pjOrigin) (pj ^. pjPos) (pj ^. pjVel)
         & stopSoundFrom (ShellSound pjid)
         & updatedetonator
   where

src/Dodge/Render.hs

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

src/Dodge/Render/HUD.hs

@@ -24,7 +24,7 @@ import Dodge.Data.DoubleTree
 import Dodge.Data.EquipType
 import Dodge.Data.SelectionList
 import Dodge.Data.Terminal.Status
-import Dodge.Data.World
+import Dodge.Data.Universe
 import Dodge.DoubleTree
 import Dodge.Equipment.Text
 import Dodge.Inventory
@@ -50,27 +50,29 @@ import NewInt
 import Picture
 import SDL (MouseButton (..))
 
-drawHUD :: Config -> World -> Picture
+drawHUD :: Universe -> Picture
-drawHUD cfig w =
+drawHUD u =
-    drawInventory sections w cfig subinv
+    drawInventory (w ^. hud . diSections) u cfig subinv
         <> drawSubInventory subinv cfig w
   where
-    sections = w ^. hud . diSections
+    w = u ^. uvWorld
+    cfig = u ^. uvConfig
     subinv = w ^. hud . subInventory
 
-drawInventory :: IMSS () -> World -> Config -> SubInventory -> Picture
+drawInventory :: IMSS () -> Universe -> Config -> SubInventory -> Picture
-drawInventory sss w cfig = \case
+drawInventory sss u cfig = \case
     DisplayTerminal{} ->
         drawSelectionSections sss invDP cfig
             <> itemconnections
-            <> drawMouseOver cfig w
+            <> drawMouseOver u
     _ ->
         drawSelectionSections sss invDP cfig
             <> foldMap (drawSSCursor sss invDP curs cfig) (w ^. hud . diSelection)
             <> drawRootCursor w sss (w ^. hud . diSelection) invDP cfig
             <> itemconnections
-            <> drawMouseOver cfig w
+            <> drawMouseOver u
   where
+    w = u ^. uvWorld
     curs = invCursorParams w
     itemconnections = fromMaybe mempty $ do
         inv' <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
@@ -94,14 +96,7 @@ drawRootCursor w sss msel ldp cfig = fromMaybe mempty $ do
             if null (w ^? rbState . opSel)
                 then BoundCurs [minBound ..]
                 else BoundCurs [North, South, West]
-    return $
+    return $ drawSSMultiCursor sss (0, x) (y - x) ldp curs cfig
-        drawSSMultiCursor
-            sss
-            (0, x)
-            (y - x)
-            ldp
-            curs
-            cfig
 
 getRootItemBounds :: Int -> IM.IntMap Item -> Maybe (Int, Int)
 getRootItemBounds i inv = do
@@ -112,63 +107,67 @@ getRootItemBounds i inv = do
     y <- locDTLeftmost root ^? locDT . dtValue . _1 . itLocation . ilInvID . unNInt
     return (x, y)
 
-drawMouseOver :: Config -> World -> Picture
+drawMouseOver :: Universe -> Picture
-drawMouseOver cfig w =
+drawMouseOver u =
     concat
-        (invsel <|> combinvsel <|> drawDragSelecting cfig w)
+        (invsel <|> combinvsel <|> drawDragSelecting u)
         <> concat (drawDragSelected cfig w)
   where
+    w = u ^. uvWorld
+    cfig = u ^. uvConfig
     invsel = do
         (j, i) <-
             w ^? input . mouseContext . mcoInvSelect
                 <|> w ^? input . mouseContext . mcoInvFilt
         sss <- w ^? hud . diSections
-        return
+        drawcursor invDP sss j i
-            . translateScreenPos cfig (invDP ^. ldpPos)
-            . color (0.3 *^ white)
-            --            . color white
-            $ selSecDrawCursor invDP curs sss (Sel j i mempty)
-    --    curs = BoundaryCursor [West]
-    curs = BackdropCurs
     combinvsel = do
         (j, i) <-
             (w ^? input . mouseContext . mcoCombSelect)
                 <|> (w ^? input . mouseContext . mcoCombCombine)
         sss <- w ^? hud . subInventory . ciSections
-        let idp = secondColumnLDP
+        drawcursor secondColumnLDP sss j i
+    drawcursor idp sss j i = 
         return
             . translateScreenPos cfig (idp ^. ldpPos)
             . color (0.3 * white)
-            $ selSecDrawCursor idp curs sss (Sel j i mempty)
+            $ selSecDrawCursor idp BackdropCurs sss (Sel j i)
 
 drawDragSelected :: Config -> World -> Maybe Picture
 drawDragSelected cfig w = do
-    ys <- w ^? hud . diSelection . _Just . slSet
+    ys0 <- w ^? hud . diSections . ix 0 . ssSet
-    guard $
+    ys3 <- w ^? hud . diSections . ix 3 . ssSet
-        not (IS.null ys)
+    ys5 <- w ^? hud . diSections . ix 5 . ssSet
-            && ( case w ^? hud . subInventory of
+    guard $ case w ^? hud . subInventory of
                     Just NoSubInventory -> True
                     _ -> False
-               )
-    Sel i _ _ <- w ^? hud . diSelection . _Just
     sss <- w ^? hud . diSections
-    let f x = (selSecDrawCursor invDP BackdropCurs sss (Sel i x mempty) <>)
+    let f i x = (selSecDrawCursor invDP BackdropCurs sss (Sel i x) <>)
     return
         . translateScreenPos cfig (invDP ^. ldpPos)
         . color (0.2 *^ white)
-        . IS.foldr f mempty
+        $ IS.foldr (f 0) mempty ys0
-        $ ys
+        <> IS.foldr (f 3) mempty ys3
+        <> IS.foldr (f 5) mempty ys5
 
-drawDragSelecting :: Config -> World -> Maybe Picture
+drawDragSelecting :: Universe -> Maybe Picture
-drawDragSelecting cfig w = do
+drawDragSelecting u = do
-    OverInvDragSelect (Just (i, j)) (Just b) <- w ^? input . mouseContext
+    x <- w ^? input . mouseContext . mcoSecSelStart
-    sss <- w ^? hud . diSections
+    y <- mouseInvPosFixWidth u
-    let f x = selSecDrawCursor invDP BackdropCurs sss (Sel i x mempty)
     return
         . translateScreenPos cfig (invDP ^. ldpPos)
         . color (0.2 *^ white)
-        . foldMap f
+        . IM.foldMapWithKey f
-        $ [min j b .. max j b]
+        $ sssSelectionSlice sss x y
+  where
+    f i ss 
+        | i ==0 || i == 3 = IM.foldMapWithKey 
+            (\j _ -> selSecDrawCursorFixWidth invDP BackdropCurs sss (Sel i j))
+            (ss ^. ssItems)
+        | otherwise = mempty
+    sss = w ^. hud . diSections
+    w = u ^. uvWorld
+    cfig = u ^. uvConfig
 
 drawSubInventory :: SubInventory -> Config -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of
@@ -226,7 +225,7 @@ drawExamineInventory cfig w =
             }
 
 closeObjectInfo :: Int -> Either Item Button -> String
-closeObjectInfo n x = case x of
+closeObjectInfo n = \case
     Left itm -> itemInfo itm ++ " It is on the floor" ++ floorItemPickupInfo n itm
     Right _ -> "Some sort of switch or button."
 
@@ -238,22 +237,34 @@ floorItemPickupInfo n itm
 -- note the use of ^?!
 -- it is probably desirable for this to crash hard for now
 yourAugmentedItem :: (Item -> a) -> a -> (Either Item Button -> a) -> World -> a
-yourAugmentedItem f x g w = case you w ^? crManipulation . manObject of
+yourAugmentedItem f x g w = case w ^. hud .diSelection of
-    Just (SelectedItem i _ _ _) -> f $ yourInv w ^?! ix i
+    Just (Sel 0 i) -> f $ yourInv w ^?! ix (NInt i)
-    Just (SelCloseItem i) -> fromMaybe x $ do
+    Just (Sel 3 i) -> fromMaybe x $ do
         j <- w ^? hud . closeItems . ix i . unNInt
         flit <- w ^? cWorld . lWorld . items . ix j
         return . g $ Left flit
-    Just (SelCloseButton i) -> fromMaybe x $ do
+    Just (Sel 5 i) -> fromMaybe x $ do
         j <- w ^? hud . closeButtons . ix i
         but <- w ^? cWorld . lWorld . buttons . ix j
         return . g $ Right but
     _ -> x
+--revise2 yourAugmentedItem f x g w = case w ^? hud . manObject of
+--revise2     Just (SelectedItem i _ _ _) -> f $ yourInv w ^?! ix i
+--revise2     Just (SelCloseItem i) -> fromMaybe x $ do
+--revise2         j <- w ^? hud . closeItems . ix i . unNInt
+--revise2         flit <- w ^? cWorld . lWorld . items . ix j
+--revise2         return . g $ Left flit
+--revise2     Just (SelCloseButton i) -> fromMaybe x $ do
+--revise2         j <- w ^? hud . closeButtons . ix i
+--revise2         but <- w ^? cWorld . lWorld . buttons . ix j
+--revise2         return . g $ Right but
+--revise2     _ -> x
 
 drawRBOptions :: Config -> World -> Picture
 drawRBOptions cfig w = fold $ do
     guard $ ButtonRight `M.member` _mouseButtons (_input w)
-    invid <- you w ^? crManipulation . manObject . imSelectedItem
+    Sel 0 invid' <- w^.hud.diSelection
+    let invid = NInt invid'
     itid <- you w ^? crInv . ix invid
     eslist <-
         fmap eqTypeToSites $
@@ -261,7 +272,7 @@ drawRBOptions cfig w = fold $ do
     i <- w ^? rbState . opSel
     let ae = equipmentDesignation invid w
     sss <- w ^? hud . diSections
-    Sel i' j _ <- w ^? hud . diSelection . _Just
+    Sel i' j <- w ^? hud . diSelection . _Just
     curpos <- selSecYint i' j sss
     itext <- sss ^? ix i' . ssItems . ix j . siPictures . ix 0
     ind <- sss ^? ix i' . ssItems . ix j . siOffX
@@ -280,16 +291,7 @@ drawRBOptions cfig w = fold $ do
             <> translate
                 (120 - xt)
                 0
-                ( listCursor
+                ( listCursor 0 1 (BoundCurs [North, South]) curpos 0 white 25 1)
-                    0
-                    1
-                    (BoundCurs [North, South])
-                    curpos
-                    0
-                    white
-                    25
-                    1
-                )
             <> translate
                 (380 - xt)
                 0
@@ -330,10 +332,9 @@ drawItemConnections sss cfig =
         . fmap (\(_, a, b) -> a <> b)
 
 drawItemChildrenConnect :: IMSS () -> Config -> Int -> [Int] -> Picture
-drawItemChildrenConnect sss cfig i is = fromMaybe mempty $ do
+drawItemChildrenConnect sss cfig i is = fold $ do
     p <- snum i
-    let ps = mapMaybe snum is
+    return $ color white $ lConnectMulti (mapMaybe snum is) p
-    return $ color white $ lConnectMulti ps p
   where
     snum = selNumPos cfig invDP sss 0
 
@@ -352,7 +353,7 @@ combineInventoryExtra sss msel cfig w = fold $ do
                 invDP
                 (BoundCurs [North, South, East, West])
                 (w ^. hud . diSections)
-                (Sel 0 i mempty)
+                (Sel 0 i)
 
 drawTerminalDisplay :: World -> Config -> Int -> Picture
 drawTerminalDisplay w cfig tid = fold $ do
@@ -407,7 +408,7 @@ drawTerminalCursorLink w cfig tm = fold $ do
                 invDP
                 (BoundCurs [North, South, East, West])
                 (w ^. hud . diSections)
-                (Sel 5 j mempty)
+                (Sel 5 j)
             )
             <> 
             lConnectCol (lp + V2 155 0) rp lcol white white

src/Dodge/Render/List.hs

@@ -12,6 +12,7 @@ module Dodge.Render.List (
     toTopLeft,
     listCursor,
     selSecDrawCursor,
+    selSecDrawCursorFixWidth,
     drawTitleBackground, -- should be renamed, made sensible
     drawCursorAt,
     drawLabelledList,
@@ -116,6 +117,26 @@ selSecDrawCursor ldp curs sss sel = fold $ do
             (_siWidth si)
             (_siHeight si)
 
+selSecDrawCursorFixWidth :: LDParams -> CursorDisplay -> IMSS a -> Selection -> Picture
+selSecDrawCursorFixWidth ldp curs sss sel = fold $ do
+    let i = sel ^. slSec
+        j = sel ^. slInt
+    yint <- selSecYint i j sss
+    sindent <- sss ^? ix i . ssIndent
+    si <- sss ^? ix i . ssItems . ix j
+    return $
+        listCursor
+            (ldp ^. ldpVerticalGap)
+            (ldp ^. ldpScale)
+            curs
+            yint
+            --(_siOffX si)
+            sindent
+            (_siColor si)
+            --(_siWidth si + sindent)
+            16
+            (_siHeight si)
+
 -- displays a cursor that should match up to list text pictures
 listCursor ::
     Float ->

src/Dodge/Render/Picture.hs

@@ -2,6 +2,9 @@
 
 module Dodge.Render.Picture (fixedCoordPictures) where
 
+import Dodge.ListDisplayParams
+import Dodge.SelectionSections
+import Dodge.Data.CardinalPoint
 import Linear hiding (rotate)
 import qualified SDL
 import Control.Lens
@@ -20,7 +23,7 @@ import Picture
 fixedCoordPictures :: Universe -> Picture
 fixedCoordPictures u =
     aimDelaySweep u
-        <> drawMenuOrHUD cfig u
+        <> drawMenuOrHUD u
         <> drawConcurrentMessage u
         <> toTopLeft cfig (translate (hw - 100) 0 $ drawList (map text (_uvTestString u u)))
         <> toTopLeft cfig
@@ -64,10 +67,11 @@ fpsText x = scale 0.2 0.2 . color col . text $ "ms/frame " ++ show x
         | x < 50 = orange
         | otherwise = red
 
-drawMenuOrHUD :: Config -> Universe -> Picture
+-- why config and universe here?
-drawMenuOrHUD cf u = case u ^. uvScreenLayers of
+drawMenuOrHUD :: Universe -> Picture
-    [] -> drawHUD (u ^. uvConfig) (u ^. uvWorld)
+drawMenuOrHUD u = case u ^. uvScreenLayers of
-    (x : _) -> drawMenuScreen (u ^? uvWorld . input . mouseContext . mcoMenuClick . _Just) x cf
+    [] -> drawHUD u
+    (x : _) -> drawMenuScreen (u ^? uvWorld . input . mouseContext . mcoMenuClick . _Just) x (u ^. uvConfig)
 
 drawConcurrentMessage :: Universe -> Picture
 drawConcurrentMessage u =
@@ -95,15 +99,15 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
     MouseMenu{} -> drawMenuClick 5
 --    MouseMenuCursor -> drawMenuCursor 5
     MouseInGame -> drawPlus 5
-    OverInvDrag 0 (Just (3, _)) -> drawDragDrop 5
+    OverInvDrag 0 | Just 3 <- mover ^? _Just.nonInf._1 -> drawDragDrop 5
-    OverInvDrag 0 Nothing -> drawDragDrop 5
+    OverInvDrag 0 | Nothing <- mover ^?_Just.nonInf -> drawDragDrop 5
-    OverInvDrag 0 (Just (0, _)) -> drawDrag 5
+    OverInvDrag 0 | Just 0 <- mover ^? _Just.nonInf._1 -> drawDrag 5
-    OverInvDrag 0 _ -> drawEmptySet 5
+    OverInvDrag 0 -> drawEmptySet 5
-    OverInvDrag 3 (Just (3, _)) -> drawDrag 5
+    OverInvDrag 3 | Just 3 <- mover ^?_Just.nonInf._1 -> drawDrag 5
-    OverInvDrag 3 (Just (0, _)) -> drawDragPickup 5
+    OverInvDrag 3 | Just 0 <- mover ^?_Just.nonInf._1 -> drawDragPickup 5
-    OverInvDrag 3 (Just (1, _)) -> drawDragPickup 5
+    OverInvDrag 3 | Just 1 <- mover ^?_Just.nonInf._1 -> drawDragPickup 5
-    OverInvDrag 3 Nothing -> drawDragPickup 5
+    OverInvDrag 3 | Nothing <-mover^?_Just.nonInf -> drawDragPickup 5
-    OverInvDrag 3 _ -> drawEmptySet 5
+    OverInvDrag 3 -> drawEmptySet 5
     OverInvDrag{} -> drawEmptySet 5
     OverInvDragSelect{} -> drawDragSelect 5
     OverInvSelect (-1, _) | selsec == Just (-1) -> drawJumpDown 5
@@ -128,6 +132,7 @@ mouseCursorType u = case u ^. uvWorld . input . mouseContext of
         return . toClosestMultiple (pi / 32) $
             argV (w ^. cWorld . lWorld . lAimPos -.- cpos)
                 - w ^. wCam . camRot
+    mover = inverseSelNumPos (u^.uvConfig) invDP (w^.input.mousePos) (w^.hud.diSections)
 
 drawAnySelectionBox :: Universe -> Picture
 drawAnySelectionBox  u = case u ^. uvWorld . input . mouseContext of

src/Dodge/Room/Tutorial.hs

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

src/Dodge/SelectedClose.hs

@@ -1,19 +1,31 @@
 module Dodge.SelectedClose (getSelectedCloseObj, interactWithCloseObj) where
 
+import Dodge.Inventory
 import Control.Lens
 import Dodge.Button.Event
 import Dodge.Data.World
 import Dodge.Inventory.Add
 import NewInt
+import Data.Maybe
+import qualified Data.Map.Strict as M
+import qualified SDL
 
 interactWithCloseObj :: Either (NewInt ItmInt) Button -> World -> World
 interactWithCloseObj e w = worldEventFlags . at InventoryChange ?~ () $ case e of
-    (Left flit) -> pickUpItem 0 (_unNInt flit) w
+    (Left flit) 
+        | SDL.ScancodeCapsLock `M.member` (w ^. input . pressedKeys)
+        , Just (Sel 0 j) <- w ^. hud . diSelection
+            -> scrollAugInvSel 1 $ pickUpItemAt j (i,_unNInt flit) w
+    (Left flit) -> pickUpItem i (_unNInt flit) w
     (Right but) -> doButtonEvent (but ^. btEvent) but w
+  where
+    i = fromMaybe 0 $ do
+        Sel 3 j <- w ^. hud . diSelection
+        return j
 
 getSelectedCloseObj :: World -> Maybe (Either (NewInt ItmInt) Button)
 getSelectedCloseObj w = do
-    Sel i j _ <- w ^? hud . diSelection . _Just
+    Sel i j <- w ^? hud . diSelection . _Just
     case i of
         3 -> Left <$> w ^? hud . closeItems . ix j
         5 -> do

src/Dodge/SelectionSections.hs

@@ -8,20 +8,26 @@ module Dodge.SelectionSections (
     inverseSelSecYint,
     posSelSecYint,
     inverseSelNumPos,
+    inverseSelNumPosFixedWidth,
+    mouseInvPosFixWidth,
+    ssLookupGE,
+    ssLookupLE,
+    sssSelectionSlice,
+    ssScrollUsing,
+    ssLookupSecGTLoop,
+    ssLookupSecLTLoop,
 ) where
 
+import Dodge.ListDisplayParams
+import Dodge.Data.Universe
 import Control.Applicative
 import qualified Control.Foldl as L
 import Control.Lens
 import Control.Monad
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Data.CardinalPoint
-import Dodge.Data.Config
-import Dodge.Data.HUD
-import Dodge.Data.SelectionList
 import Dodge.ScreenPos
 import Geometry.Data
 
@@ -41,35 +47,17 @@ ssScrollUsing ::
     Maybe Selection
 ssScrollUsing g = ssScrollMinOnFail g . fmap (ssItems %~ IM.filter _siIsSelectable)
 
--- 
 ssScrollMinOnFail ::
     (Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
     IMSS a ->
     Maybe Selection ->
     Maybe Selection
-ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j q) $ l <|> ssLookupMin sss
+ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j) $ l <|> ssLookupMin sss
   where
-    q = fold (msel ^? _Just . slSet)
     l = do
-        Sel i j _ <- msel
+        Sel i j <- msel
         f i j sss
 
----- this version removes the selected set when scrolling outside it
---ssScrollMinOnFail' ::
---    (Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
---    IMSS a ->
---    Maybe Selection ->
---    Maybe Selection
---ssScrollMinOnFail' f sss msel = fmap (\(i, j, _) -> Sel i j (q i j)) $ l <|> ssLookupMin sss
---  where
---    q i j = fromMaybe mempty $ do
---        Sel k _ xs <- msel ^? _Just
---        guard $ j `IS.member` xs && i == k
---        return xs
---    l = do
---        Sel i j _ <- msel
---        f i j sss
-
 ssSetCursor ::
     (IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
     IMSS a ->
@@ -77,11 +65,7 @@ ssSetCursor ::
     Maybe Selection
 ssSetCursor f sss msel = fromMaybe msel $ do
     (i,j,_) <- f sss
-    let newxs = fromMaybe mempty $ do
+    return $ Just (Sel i j)
-            Sel k _ xs <- msel
-            guard $ k == i && j `IS.member` xs
-            return xs
-    return $ Just (Sel i j newxs)
 
 ssLookupMax :: IMSS a -> Maybe (Int, Int, SelectionItem a)
 ssLookupMax sss = do
@@ -110,24 +94,27 @@ ssLookupMaxInSection i sss = do
     return (i, j, s)
 
 ssLookupLT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
-ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
+ssLookupLT i j sss = fromMaybe (ssLookupSecLT i sss) $ do
     ss <- sss ^? ix i
     (j', si) <- IM.lookupLT j (ss ^. ssItems)
     return $ Just (i, j', si)
 
-ssLookupLT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
+ssLookupSecLTLoop :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
-ssLookupLT' i sss = do
+ssLookupSecLTLoop i sss = ssLookupSecLT i sss <|> ssLookupMax sss
+
+ssLookupSecLT :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
+ssLookupSecLT i sss = do
     (i', ss) <- IM.lookupLT i sss
     case IM.lookupMax (ss ^. ssItems) of
         Just (j', si) -> return (i', j', si)
-        Nothing -> ssLookupLT' i' sss
+        Nothing -> ssLookupSecLT i' sss
 
 ssLookupLE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
 ssLookupLE' i sss = do
     (i', ss) <- IM.lookupLE i sss
     case IM.lookupMax (ss ^. ssItems) of
         Just (j', si) -> return (i', j', si)
-        Nothing -> ssLookupLT' i' sss
+        Nothing -> ssLookupSecLT i' sss
 
 ssLookupMin :: IMSS a -> Maybe (Int, Int, SelectionItem a)
 ssLookupMin sss = do
@@ -135,24 +122,43 @@ ssLookupMin sss = do
     ssLookupGE' i sss
 
 ssLookupGT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
-ssLookupGT i j sss = fromMaybe (ssLookupGT' i sss) $ do
+ssLookupGT i j sss = fromMaybe (ssLookupSecGT i sss) $ do
     ss <- sss ^? ix i
     (j', si) <- IM.lookupGT j (ss ^. ssItems)
     return $ Just (i, j', si)
 
-ssLookupGT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
+ssLookupSecGT :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
-ssLookupGT' i sss = do
+ssLookupSecGT i sss = do
     (i', ss) <- IM.lookupGT i sss
     case IM.lookupMin (ss ^. ssItems) of
         Just (j', si) -> return (i', j', si)
-        Nothing -> ssLookupGT' i' sss
+        Nothing -> ssLookupSecGT i' sss
+
+ssLookupSecGTLoop :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
+ssLookupSecGTLoop i sss = ssLookupSecGT i sss <|> ssLookupMin sss
+
+ssLookupGE :: XInfinity (Int,Int) -> IMSS a -> Maybe (Int,Int,SelectionItem a)
+ssLookupGE x sss = case x of
+    NegInf -> ssLookupMin sss
+    PosInf -> Nothing
+    NonInf (i,j) -> case sss ^? ix i . ssItems . ix j of
+        Nothing -> ssLookupGT i j sss
+        Just s -> Just (i,j,s)
+
+ssLookupLE :: XInfinity (Int,Int) -> IMSS a -> Maybe (Int,Int,SelectionItem a)
+ssLookupLE x sss = case x of
+    NegInf -> Nothing
+    PosInf -> ssLookupMax sss
+    NonInf (i,j) -> case sss ^? ix i . ssItems . ix j of
+        Nothing -> ssLookupLT i j sss
+        Just s -> Just (i,j,s)
 
 ssLookupGE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
 ssLookupGE' i sss = do
     (i', ss) <- IM.lookupGE i sss
     case IM.lookupMin (ss ^. ssItems) of
         Just (j', si) -> return (i', j', si)
-        Nothing -> ssLookupGT' i' sss
+        Nothing -> ssLookupSecGT i' sss
 
 selSecSelSize :: Int -> Int -> IMSS a -> Maybe Int
 selSecSelSize i j = (^? ix i . ssItems . ix j . siHeight)
@@ -168,7 +174,7 @@ selSecYint i j sss = do
     ss <- sss ^? ix i
     return
         . (secpos +)
-        . subtract (ss ^. ssOffset)
+        . subtract (ss ^. ssYOffset)
         . sum
         . fmap _siHeight
         . fst
@@ -186,7 +192,7 @@ inverseSelSecYint yint sss
             then return $ inverseSelSecYint (yint - l) othersss
             else do
                 let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
-                (j, _) <- L.fold (L.find (\(_, x) -> x - _ssOffset ss > yint)) $ IM.toList ls
+                (j, _) <- L.fold (L.find (\(_, x) -> x - _ssYOffset ss > yint)) $ IM.toList ls
                 return $ NonInf (i, j)
 
 inverseSelSecYintXPosCheck ::
@@ -208,6 +214,49 @@ inverseSelSecYintXPosCheck cfig ldp x yint sss = do
     guard $ x - x1 < 160 && x > x1
     return sel
 
+inverseSelSecYintXPosCheckFixedWidth ::
+    Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (XInfinity (Int, Int))
+inverseSelSecYintXPosCheckFixedWidth cfig ldp x yint sss = do
+    let sel = inverseSelSecYint yint sss
+    (i,_) <- case sel of
+        NonInf v -> Just v
+        NegInf -> do 
+            (i',j',_) <- ssLookupMin sss
+            return (i',j')
+        PosInf -> do
+            (i',j',_) <- ssLookupMax sss
+            return (i',j')
+    let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
+    sindent <- sss ^? ix i . ssIndent
+--    itindent <- sss ^? ix i . ssItems . ix j . siOffX
+    --let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent + itindent) - 0.5)
+    let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent) - 0.5)
+    guard $ x - x1 < 170 && x > x1
+    return sel
+
+mouseInvPosFixWidth :: Universe -> Maybe (XInfinity (Int,Int))
+mouseInvPosFixWidth u = inverseSelNumPosFixedWidth
+    (u^.uvConfig) 
+    invDP 
+    (u^.uvWorld. input . mousePos) 
+    (u ^.uvWorld. hud . diSections)
+
+
 inverseSelNumPos :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
 inverseSelNumPos cfig ldp (V2 x y) =
     inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y)
+
+inverseSelNumPosFixedWidth :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
+inverseSelNumPosFixedWidth cfig ldp (V2 x y) =
+    inverseSelSecYintXPosCheckFixedWidth cfig ldp x (posSelSecYint cfig ldp y)
+
+sssSelectionSlice :: IMSS a -> XInfinity (Int,Int) -> XInfinity (Int,Int) -> IMSS a
+sssSelectionSlice sss x1 x2 = fromMaybe mempty $ do
+    let (xmin,xmax) | x1 < x2 = (x1,x2)
+            | otherwise = (x2,x1)
+    (mini,minj,_) <- ssLookupGE xmin sss
+    (maxi,maxj,_) <- ssLookupLE xmax sss
+    return $ fst (IM.split (maxi+1) . snd $ IM.split (mini-1) sss)
+            & ix mini . ssItems %~ snd . IM.split (minj-1)
+            & ix maxi . ssItems %~ fst . IM.split (maxj+1)
+

src/Dodge/Shockwave/Update.hs

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

src/Dodge/Spark.hs

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

src/Dodge/Tesla.hs

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

src/Dodge/TestString.hs

@@ -35,17 +35,44 @@ import NewInt
 import RandomHelp
 import qualified SDL
 import ShortShow
+import qualified Data.IntSet as IS
 
 tocrs :: (IM.IntMap Creature
           -> Const (Endo [String]) (IM.IntMap Creature))
          -> Universe -> Const (Endo [String]) Universe
 tocrs = uvWorld . cWorld . lWorld . creatures
 
+isBee :: Creature -> Bool
+isBee cr = case cr ^. crType of
+    BeeCrit{} -> True
+    _ -> False
+
+crslime :: Creature -> Int
+crslime cr = case cr ^. crType of
+    SlimeCrit {_slimeSlime=r} | HP{} <- cr ^. crHP -> r -- r ^ (2::Int)
+    HiveCrit {_hiveSlime=x} -> x
+    BeeCrit {_beeSlime=x} -> 400 + x
+    _ -> 0
+
+crs :: Universe -> [Creature]
+crs u = u ^.. uvWorld . cWorld . lWorld . creatures . each
+
 testStringInit :: Universe -> [String]
-testStringInit u = u ^.. tocrs . ix 2 . crType . hiveChildren . to show
+testStringInit u = [ u ^. uvWorld . testString 
-    <> u ^.. tocrs . ix 3 . crStance . carriage . to show
+    ] 
-    <> u ^.. tocrs . ix 3 . crDir . to show
+    <> fold (u ^? uvWorld . cWorld . lWorld . creatures . ix 5 . crActionPlan . to prettyShort)
-    <> u ^.. tocrs . ix 3 . crActionPlan . apAction . to show
+    -- ] <> u ^.. uvWorld . cWorld . lWorld . creatures . each . crType . to (concat . prettyShort)
+--    <> u ^.. uvWorld . cWorld . lWorld . projectiles . each . pjPos . _z . to show
+--    <> u ^.. uvWorld . cWorld . lWorld . creatures . each . crType . slimeSlime .  to (show . slimeToRad)
+--    , u ^. uvWorld . input . mouseContext . to show
+--    , u ^. uvWorld . hud . diSelection . to show
+--    , u ^. uvWorld . cWorld . lWorld . lInvLock . to show
+--    ] 
+--    <>    u ^. uvWorld . hud . manObject . to prettyShort
+--    <> u ^.. uvWorld . hud . diSections . each . ssSet . to show
+--testStringInit u = u ^. uvWorld . cWorld . lWorld . creatures . ix 5 . crActionPlan . to prettyShort
+    --[show . getSum $ foldMap (Sum . crslime) (crs u)]
+--     u ^.. tocrs . each . crType . slimeSplitTimer . to show
 --    u ^.. tocrs . ix 1 . crPos . _xy . to show
 --    <> u ^.. tocrs . ix 1 . crType . slimeCompression . to show
 --    <> u ^.. tocrs . ix 1 . crType . slimeCompression . to norm . to show
@@ -106,25 +133,24 @@ testStringInit u = u ^.. tocrs . ix 2 . crType . hiveChildren . to show
 
 topTestPart :: Universe -> [String]
 topTestPart u =
-    [ maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+    [ maybe "" showManObj $ u ^? uvWorld . hud . manObject
     ]
 
 showManObj :: ManipulatedObject -> String
-showManObj SortInventory = "SortInventory"
+--showManObj SortInventory = "SortInventory"
-showManObj (SelectedItem x y as z) =
+showManObj (HeldItem y as z) =
-    "SelItem: "
+        " Root: "
-        ++ show x
-        ++ " Root: "
         ++ show y
         ++ " Attached: "
         ++ show z
         ++ " AimStance: "
         ++ show as
-showManObj SelNothing = "SelNothing"
+showManObj HandsFree = "HandsFree"
-showManObj SortCloseItem = "SortCloseItem"
+--showManObj SelNothing = "SelNothing"
-showManObj (SelCloseItem x) = "CloseItem " ++ show x
+--showManObj SortCloseItem = "SortCloseItem"
-showManObj SortCloseButton = "SortCloseButton"
+--showManObj (SelCloseItem x) = "CloseItem " ++ show x
-showManObj (SelCloseButton x) = "CloseButton " ++ show x
+--showManObj SortCloseButton = "SortCloseButton"
+--showManObj (SelCloseButton x) = "CloseButton " ++ show x
 
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of

src/Dodge/Update.hs

@@ -129,6 +129,7 @@ updateWorldEventFlags u =
 updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe
 updateWorldEventFlag wef = case wef of
     InventoryChange -> id -- updateInventoryPositioning
+        -- setInvPosFromSS ?
     -- for now update inventory positioning every tick
     CombineInventoryChange -> updateCombinePositioning
 
@@ -193,10 +194,8 @@ updateUniverseMid u = case _uvScreenLayers u of
             --            . (uvWorld . cWorld . highlightItems . filteredBy . non 0 -~ 1)
             . timeFlowUpdate
             . updateUseInputInGame
-            $ over
+            . updateMouseInGame
-                uvWorld
+            $ over uvWorld (updateCamera (u ^. uvConfig)) u
-                (updateMouseInGame (u ^. uvConfig) . updateCamera (u ^. uvConfig))
-                u
   where
     minusone x
         | x > 0 = Just $ x - 1
@@ -283,7 +282,7 @@ functionalUpdate =
         . over uvWorld updateDistortions
         . over uvWorld updateCreatureSoundPositions
         . over uvWorld updateCreatureStrides
-        . over uvWorld pushYouOutFromWalls
+        . pushYouOutFromWalls
         . colCrsWalls
         . over uvWorld simpleCrSprings
         . over uvWorld updateDoors
@@ -316,8 +315,8 @@ functionalUpdate =
             (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave)
         . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
         . over uvWorld updateClouds
-        . over uvWorld updateBeePheremones
+        . over uvWorld (updateObjMapMaybe beePheremones updateBeePheremone)
-        . over uvWorld updateGasses
+        . over uvWorld (updateObjCatMaybes gasses updateGas)
         . over uvWorld updateDusts
         . over uvWorld updateGusts
         . over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) updateTerminal)
@@ -342,13 +341,15 @@ functionalUpdate =
         . updateAimPos
         . over uvWorld updatePastWorlds -- it might be possible to do this without storing stuff such as the temporary lights/flares etc
 
-pushYouOutFromWalls :: World -> World
+pushYouOutFromWalls :: Universe -> Universe
-pushYouOutFromWalls w = w & cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck w
+pushYouOutFromWalls u
+    | debugOn Noclip (u ^. uvConfig) = u
+    | otherwise = u & uvWorld . cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck (u ^. uvWorld)
 
 -- rotate creature as well? behaviour on ledges?
 muzzleWallCheck :: World -> Creature -> Creature
 muzzleWallCheck w cr = fromMaybe cr $ do
-    invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt
+    invid <- w ^? hud . manObject . hiRootSelectedItem . unNInt
     loc <-
         invIndents ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
             ^? ix invid . _2
@@ -366,7 +367,7 @@ muzzleWallCheck w cr = fromMaybe cr $ do
                     x = dotV v' v
                  in cr & crPos . _xy +~ min 1 x *^ v'
   where
-    f loc = map (muzzlePos loc cr) (itemMuzzles loc)
+    f loc = map (muzzlePos w loc cr) (itemMuzzles loc)
     g cp wls p = case collidePoint cp p wls of
         (ep, Just wl) -> Just (ep - p, wl)
         _ -> Nothing
@@ -423,7 +424,8 @@ updateMouseContext cfig u = case u ^? uvScreenLayers . ix 0 of
 
 updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext
 updateMouseContextGame cfig u = \case
-    OverInvDrag i _ -> OverInvDrag i (inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf)
+    --OverInvDrag i -> OverInvDrag i -- (inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf)
+    x@OverInvDrag{} -> x
     x@OverInvDragSelect{} -> x
     MouseGameRotate x
         | ButtonRight `M.member` (w ^. input . mouseButtons) -> MouseGameRotate x
@@ -448,7 +450,7 @@ updateMouseContextGame cfig u = \case
                 return $ OverInvSelect selpos
     overcomb = do
         sss <- w ^? hud . subInventory . ciSections
-        Sel xl xr _ <- w ^? hud . subInventory . ciSelection . _Just
+        Sel xl xr <- w ^? hud . subInventory . ciSelection . _Just
         let msel = (xl, xr)
         let mpossel = inverseSelNumPos cfig secondColumnLDP (w ^. input . mousePos) sss ^? _Just . nonInf
         return $ case mpossel of
@@ -540,7 +542,7 @@ updatePlasmaBall w pb
     dodam = \case
         Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam
         Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam
-    thedam = Lasering 100 ep (pb ^. pbVel)
+    thedam = Lasering 100 ep (pb ^. pbVel) (pb ^. pbOrigin)
     sp = pb ^. pbPos
     ep = sp + pb ^. pbVel
     thit = thingHit sp ep w
@@ -560,7 +562,7 @@ updatePulseBall pb w
     dodam = \case
         Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam
         Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam
-    thedam = Lasering 100 ep (pb ^. pzbVel)
+    thedam = Lasering 100 ep (pb ^. pzbVel) (pb ^. pzbOrigin)
     sp = pb ^. pzbPos
     ep = sp + pb ^. pzbVel
     thit = listToMaybe $ thingsHitZ 20 sp ep w
@@ -609,13 +611,14 @@ setOldPos cr = cr & crOldPos .~ _crPos cr
 
 zoneCreatures :: World -> World
 zoneCreatures w =
-    w & crZoning .~ foldl' zoneCreature mempty (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures)
+--    w & crZoning .~ foldl' zoneCreature mempty (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures)
+    w & crZoning .~ foldl' zoneCreature mempty (w ^. cWorld . lWorld . creatures)
 
-zonableCreature :: Creature -> Bool
+--zonableCreature :: Creature -> Bool
-zonableCreature cr = case cr ^. crHP of
+--zonableCreature cr = case cr ^. crHP of
-    HP{} -> True
+--    HP{} -> True
-    CrIsCorpse{} -> True
+--    CrIsCorpse{} -> True
-    CrDestroyed{} -> False
+--    AvatarDestroyed{} -> False
 
 updateCreatureSoundPositions :: World -> World
 updateCreatureSoundPositions w =
@@ -718,7 +721,7 @@ updateTeslaArc w pt
             , randWallReflect ld' wl
             )
         | ArcStep lp' ld' _ <- last thearc = (lp', rp ld')
-    damthings (ArcStep _ _ crwl) = damageCrWlID [Electrical 50] crwl
+    damthings (ArcStep _ _ crwl) = damageCrWlID [Electrical 50 (pt ^. taOrigin)] crwl
 
 updatePulseLaser :: PulseLaser -> (Endo World, [PulseLaser])
 updatePulseLaser pz = case pz ^. pzTimer of
@@ -734,14 +737,14 @@ updatePulseLaser pz = case pz ^. pzTimer of
     dodam thit = case thit of
         ((p, OCreature cr) : _) ->
             cWorld . lWorld . creatures . ix (_crID cr) . crDamage
-                .:~ Lasering (pz ^. pzDamage) p (xp - sp)
+                .:~ Lasering (pz ^. pzDamage) p (xp - sp) (pz ^. pzOrigin)
         ((p, OWall wl) : _) ->
             cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty
-                .:~ Lasering (pz ^. pzDamage) p (xp - sp)
+                .:~ Lasering (pz ^. pzDamage) p (xp - sp) (pz ^. pzOrigin)
         ((_, OPulseBall pb) : xs) ->
             dodam xs
                 . (cWorld . lWorld . pulseBalls . ix (_pzbID pb) . pzbTimer .~ 0)
-                . makeExplosionAt (_pzbPos pb `v2z` 20) 0
+                . makeExplosionAt (pb ^. pzbOrigin) (_pzbPos pb `v2z` 20) 0
         _ -> id
     phasev = _pzPhaseV pz
     sp = _pzPos pz
@@ -780,17 +783,13 @@ updateSparks = updateObjCatMaybes sparks updateSpark
 updateClouds :: World -> World
 updateClouds w = updateObjMapMaybe clouds (updateCloud w) w
 
-updateBeePheremones :: World -> World
-updateBeePheremones w = updateObjMapMaybe beePheremones updateBeePheremone w
-
 updateBeePheremone :: BeePheremone -> Maybe BeePheremone
 updateBeePheremone bp 
     | x <- bp ^. bpTimer
     , x <= 0 = Nothing
     | otherwise = Just $ bp & bpTimer -~ 1
-
+        & bpVel *~ 0.90
-updateGasses :: World -> World
+        & bpPos +~ (bp ^. bpVel)
-updateGasses = updateObjCatMaybes gasses updateGas
 
 updateDusts :: World -> World
 updateDusts w = updateObjMapMaybe dusts (updateDust w) w
@@ -1007,7 +1006,7 @@ canSpring cr =
     cr ^. crPos . _z >= 0 && case cr ^. crHP of
         HP{} -> True
         CrIsCorpse{} -> True
-        CrDestroyed{} -> False
+        AvatarDestroyed{} -> False
 
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2
@@ -1015,6 +1014,10 @@ crCrSpring c1 c2
     | vec == V2 0 0 = id
     | diff >= comRad = id
     | diffheight = id
+    | Rooted <- c2 ^. crStance . carriage = id
+    | Rooted <- c1 ^. crStance . carriage 
+        = cWorld . lWorld . creatures . ix id2 . crPos . _xy +~ 
+            (diff - comRad) *^ signorm vec
     | SlimeCrit{} <- c1 ^. crType
     , SlimeCrit{} <- c2 ^. crType
     , id2 > id1 
@@ -1023,19 +1026,16 @@ crCrSpring c1 c2
     , slimeFood c2
     , distance xy1 xy2 < r1 - (r2 + 5)
         = feedSlime c1 c2
-    | Just t <- c1 ^? crType . slimeSplitTimer 
+    | maybe True not (c1 ^? crType . slimeDistortion . sdIsSplit) 
-        , slimeFood c2
+        , SlimeCrit{} <- c1 ^. crType
-        , t <= 0 = slimeSuck c1 c2
+        , slimeFood c2 = slimeSuck c1 c2
     | SlimeCrit{} <- c1 ^. crType = id
     | SlimeCrit{} <- c2 ^. crType = id
     | otherwise = cWorld . lWorld . creatures %~ ( olap c1 c2 . olap' c2 c1)
   where
     z c = c ^. crPos . _z
-    h c = fmap (+ z c) (crHeight c)
+    h c = crHeight c + z c
-    diffheight = fromMaybe True $ do
+    diffheight = z c1 > h c2 || z c2 > h c1
-        h1 <- h c1
-        h2 <- h c2
-        return $ z c1 > h2 || z c2 > h1
     olap a b = ix (a ^. crID) . crPos . _xy +~ overlap b
     olap' a b = ix (a ^. crID) . crPos . _xy -~ overlap b
     id1 = _crID c1
@@ -1056,7 +1056,7 @@ crCrSpring c1 c2
 slimeSuck :: Creature -> Creature -> World -> World
 slimeSuck c1 c2 = cWorld . lWorld . creatures %~ (rolap . rolap')
   where
-    suckx = (min 1 $ 2 * (1 - distance xy1 xy2 / (r1 + r2))) ^ (2:: Int)
+    suckx = min 1 (2 * (1 - distance xy1 xy2 / (r1 + r2))) ^ (2:: Int)
     rolap = ix id1 . crPos . _xy +~ f (suckx * 1.5 * m2 / (m1+m2)) *^ normalize (xy2 - xy1)
     rolap' = ix id2 . crPos . _xy +~ f (suckx * 1.5*m1 / (m1+m2)) *^ normalize (xy1 - xy2)
     f = min (distance xy1 xy2/2)
@@ -1074,51 +1074,38 @@ slimeFood cr = case cr ^. crType of
     Avatar{} -> True
     ChaseCrit{} -> True
     CrabCrit {} -> True
+    BeeCrit{} | CrIsCorpse{} <- cr ^. crHP -> True
     _ -> False
 
 feedSlime :: Creature -> Creature -> World -> World
-feedSlime s c w = fromMaybe w $ do
+feedSlime s c w = if min 10 r1 + s ^?! crType . slimeEngulfProgress < max 15 (ch + 2)
-    ch <- crHeight c
-    return $ if min 10 r1 + s ^?! crType . slimeEngulfProgress < max 15 (ch + 2)
         then w & cWorld.lWorld.creatures.ix (s^.crID).crType.slimeEngulfProgress%~ (min r1.(+0.7))
                 & slimeSuck s c
-        else
+        else w
-             w
+            & cWorld . lWorld . creatures . at (c ^. crID) %~ destroyCreature
-            & cWorld . lWorld . creatures . ix (c ^. crID) . crHP .~ CrDestroyed Swallowed
+            & cWorld . lWorld . creatures . ix (s ^. crID) . crType . slimeSlime +~ x
-            & cWorld . lWorld . creatures . ix (s ^. crID) %~ f
+            & cWorld . lWorld . creatures . ix (s ^. crID) . crType . slimeSlimeChange +~ x
             & slimeEatSound (s ^. crID) (s ^. crPos . _xy)
   where
-    f cr = cr & crType . slimeRad .~ r
+    ch = crHeight c
-            & crType . slimeRadWobble +~ r - r1
+    x = round $ (c^.crType.to crRad)^(2::Int) * 100
-            & crType . slimeCompression %~ ((r/r1) *^)
+    r1 = s ^?! crType . slimeSlime . to slimeToRad
-    r1 = s ^?! crType . slimeRad
-    r2 = c ^. crType . to crRad
-    r = sqrt (r1*r1 + r2*r2)
 
 fuseSlimes :: Creature -> Creature -> World -> World
 fuseSlimes c1 c2 = (cWorld . lWorld . creatures . ix mini .~ c)
     . (cWorld . lWorld . creatures . at maxi .~ Nothing)
-    . slimeEatSound i1 (c ^. crPos . _xy)
+    . slimeEatSound mini (c ^. crPos . _xy)
   where
-    c' | c1 ^?! crType . slimeRad > c2 ^?! crType . slimeRad = c1
+    c' | c1 ^?! crType . slimeSlime > c2 ^?! crType . slimeSlime = c1
        | otherwise = c2
     mini = min i1 i2
     maxi = max i1 i2
     i1 = c1 ^. crID
     i2 = c2 ^. crID
-    c = c' & crType . slimeRad .~ r
+    c = c' & crType . slimeSlime +~ eslime
-            & crType . slimeRadWobble +~ r - max r1 r2
+            & crType . slimeSlimeChange +~ eslime
-            & crType . slimeCompression %~ ((r/max r1 r2) *^)
             & crID .~ mini
-    r1 = c1 ^?! crType . slimeRad
+    eslime = min (c1 ^?! crType . slimeSlime) (c2 ^?! crType . slimeSlime)
-    r2 = c2 ^?! crType . slimeRad
-    r = sqrt (r1*r1 + r2*r2)
-
-slimeEatSound :: Int -> Point2 -> World -> World
-slimeEatSound i p w = w & soundStart (CrSound i) p s Nothing
-        & randGen .~ g
-      where
-        (s,g) = runState (takeOne [slurp1S,slurp2S,slurp3S,slurp4S,slurp5S]) (w ^. randGen)
 
 
 updateDelayedEvents :: World -> World

src/Dodge/Update/Camera.hs

@@ -6,6 +6,7 @@ module Dodge.Update.Camera (
     updateCamera,
 ) where
 
+import NewInt
 import Dodge.Update.Camera.Rotate
 import Linear.V3
 import Dodge.Creature.Radius
@@ -101,33 +102,33 @@ moveZoomCamera cfig theinput cr w campos =
         & camItemZoom .~ newItemZoom
   where
     mremotepos = do
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud .diSelection._Just
-        itid <- cr ^? crInv . ix i
+        itid <- cr ^? crInv . ix (NInt i)
         j <- w ^? cWorld . lWorld . items . ix itid . itUse . uaParams . apProjectiles . ix 0
         guard $ Just REMOTESCREEN == w ^? cWorld . lWorld . items . ix itid . itType . ibtAttach
         w ^? cWorld . lWorld . projectiles . ix j . pjPos . _xy
     docamrot = rotateV (campos ^. camRot)
     offset = fromMaybe noscopeoffset $ do
         guard (SDL.ButtonRight `M.member` _mouseButtons theinput)
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud.diSelection._Just
-        itid <- cr ^? crInv . ix i
+        itid <- cr ^? crInv . ix (NInt i)
         fmap docamrot (w ^? cWorld . lWorld . items . ix itid . itUse . uScope . opticPos)
     noscopeoffset =
         docamrot $
             ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos theinput
     newzoom = fromMaybe (newDefaultZoom * newItemZoom) $ do
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud .diSelection._Just
-        itid <- cr ^? crInv . ix i
+        itid <- cr ^? crInv . ix (NInt i)
         w ^? cWorld . lWorld . items . ix itid . itUse . uScope . opticZoom
     idealDefaultZoom = clipZoom wallZoom
     newDefaultZoom = fromMaybe (changeZoom (campos ^. camDefaultZoom) idealDefaultZoom) $ do
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud .diSelection._Just
-        itid <- cr ^? crInv . ix i
+        itid <- cr ^? crInv . ix (NInt i)
         w ^? cWorld . lWorld . items . ix itid . itUse . uScope . opticZoom
     idealItemZoom = fromMaybe 1 $ do
         guard $ crIsAiming cr
-        i <- cr ^? crManipulation . manObject . imSelectedItem
+        Sel 0 i <- w^?hud .diSelection._Just
-        itid <- cr ^? crInv . ix i
+        itid <- cr ^? crInv . ix (NInt i)
         getAimZoom <$> (w ^? cWorld . lWorld . items . ix itid)
     newItemZoom = changeZoom (campos ^. camItemZoom) idealItemZoom
     changeZoom curZoom idealZoom