Cleanup

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

.ghci

@@ -1 +1,2 @@
 :set prompt ">"
+:load test/Spec.hs

.ghcid

@@ -1 +1 @@
---command "stack ghci --main-is loop:exe:dodge"
+--command "stack ghci --test --main-is loop:test:loop-test --ghci-options=-fobject-code"

.gitignore

@@ -6,5 +6,7 @@ loop.cabal
 keys.json
 log/*
 generated/*
+UntrackedMisc/*
 tags
 ghcidOutput
+.ghcid.bak

.hlint.yaml

@@ -61,6 +61,7 @@
 # - ignore: {name: Use let}
 # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
 
+- ignore: {name: Functor law}
 
 # Define some custom infix operators
 # - fixity: infixr 3 ~^#^~

appDodge/Main.hs

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

src/AesonHelp.hs

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

src/Data/Tile.hs

@@ -17,11 +17,12 @@ data Tile = Tile
     { _tilePoly :: [Point2]
     , -- | point in the world where tile texture is 0,0
       _tileZero :: Point2
-    , -- | world position one along in the X direction, note this also set the scale of the
+    , -- | world position one along in the X direction
-      -- texture
+      -- note this also sets the scale of the texture
       -- this has to be a position because it is shifted
       _tileTangentPos :: Point2
     , _tileArrayZ :: Float
+    , _tileZeroShift :: Maybe Point2A
     }
     deriving (Eq, Ord, Show)
 

src/Dodge/Barreloid.hs

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

src/Dodge/Base/CardinalPoint.hs

@@ -7,13 +7,28 @@ import Geometry
 cardList :: [CardinalPoint]
 cardList = [North, East, South, West]
 
+cardReverse :: CardinalPoint -> CardinalPoint
+cardReverse = \case
+    North -> South
+    South -> North
+    East -> West
+    West -> East
+
 cardVec :: CardinalPoint -> Point2
-cardVec cp = case cp of
+cardVec = \case
     North -> V2 0 1
     South -> V2 0 (-1)
     East -> V2 1 0
     West -> V2 (-1) 0
 
+vecCard :: Point2 -> CardinalPoint
+vecCard 0 = error "vecCard null"
+vecCard (V2 x y)
+    | x > abs y = East
+    | -x > abs y = West
+    | y > 0 = North
+    | otherwise = South
+
 card8Vec :: Cardinal8 -> Point2
 card8Vec cp = case cp of
     North8 -> V2 0 1

src/Dodge/Base/Collide.hs

@@ -18,10 +18,10 @@ module Dodge.Base.Collide (
     collideCircWalls,
     overlapSegWalls,
     overlapSegCrs,
+    overlapSegCrs',
     bouncePoint,
     circOnSomeWall,
     circOnAnyCr,
-    overlapCircWalls,
     overlapCircWallsClosest,
     crsNearPoint,
     allVisibleWalls,
@@ -33,8 +33,14 @@ module Dodge.Base.Collide (
     anythingHitCirc,
     collide3WallsFloor,
     collide3,
+    crHeight,
+    crMid,
 ) where
 
+import AesonHelp
+import Control.Applicative
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Control.Monad
 import qualified Data.IntSet as IS
@@ -49,7 +55,7 @@ import FoldableHelp
 import Geometry
 import Linear
 
-collidePoint :: Point2 -> Point2 -> [Wall] -> (Point2, Maybe Wall)
+collidePoint :: Foldable t => Point2 -> Point2 -> t Wall -> (Point2, Maybe Wall)
 {-# INLINE collidePoint #-}
 collidePoint sp ep = foldl' f (ep, Nothing)
   where
@@ -64,6 +70,15 @@ overlapSegCrs sp ep = mapMaybe f
         (,cr)
             <$> fst (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
 
+overlapSegCrs' :: Point2 -> Point2 -> [Creature] -> [(Point2, Creature)]
+{-# INLINE overlapSegCrs' #-}
+overlapSegCrs' sp ep = mapMaybe f
+  where
+    f cr =
+        (,cr)
+            <$> g (intersectCircSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType) sp ep)
+    g (a,b) = a <|> b
+
 doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
 {-# INLINE doBounce #-}
 doBounce x sp ep (p, mwl) = fmap f mwl
@@ -73,15 +88,15 @@ doBounce x sp ep (p, mwl) = fmap f mwl
         , reflVelWallDamp x wl (ep -.- sp)
         )
 
---bounceBall ::
+-- bounceBall ::
 --    Float ->
 --    Point2 ->
 --    Point2 ->
 --    Float ->
 --    [Wall] ->
 --    Maybe (Point2, Point2)
---{-# INLINE bounceBall #-}
+-- {-# INLINE bounceBall #-}
---bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
+-- bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
 
 bouncePoint ::
     (Wall -> Bool) ->
@@ -106,7 +121,8 @@ collide3Chasms sp w m =
     foldl'
         (flip (collide3Chasm sp))
         m
-        (foldMap loopPairs $ w ^. cWorld . chasms)
+        -- (foldMap loopPairs $ w ^. cWorld . chasms)
+        (w ^. cWorld . cliffs)
 
 collide3Chasm :: Point3 -> (Point2, Point2) -> (Point3, MPO) -> (Point3, MPO)
 collide3Chasm sp ab (ep, m) =
@@ -159,23 +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 25
+    HP{} -> case cr ^. crType of
-    CrIsCorpse{} -> Just 5
+        HoverCrit {} -> 10
-    CrIsGibs -> Nothing
+        ChaseCrit {} -> 25
-    CrIsPitted -> Nothing
+        Avatar {} -> 25
+        CrabCrit {} -> 25
+        SlinkCrit {} -> 25
+        SlimeCrit {_slimeSlime = r} -> min 25 $ 2 * slimeToRad r
+        BeeCrit {} -> 10
+        HiveCrit {} -> 25
+        BarrelCrit{} -> 20
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
+    CrIsCorpse{} -> 5
+    AvatarDestroyed{} -> 0
+
+crMid :: Creature -> Float
+crMid cr = case cr ^. crHP of
+    HP{} -> case cr ^. crType of
+        HoverCrit {} -> 2
+        ChaseCrit {} -> 20
+        Avatar {} -> 20
+        CrabCrit {} -> 20
+        SlinkCrit {} -> 20
+        SlimeCrit {_slimeSlime = r} -> max 3 . min 20 $ 2 * slimeToRad r - 5
+        BeeCrit {} -> 2
+        HiveCrit {} -> 20
+        BarrelCrit{} -> 20
+        _ -> error $ "Need to define crHeight for this crType:\n" <> unlines (prettyShort (cr ^. crType))
+    CrIsCorpse{} -> 2
+    AvatarDestroyed{} -> 0
 
 wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
 wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])
@@ -185,39 +219,40 @@ wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y)
 
 -- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 -- whether this is actually faster
-collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
+collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Bool
 {-# INLINE collidePointTestFilter #-}
 collidePointTestFilter t sp ep =
     any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
-        . filter t
+        . IM.filter t
 
 ---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
 ---- whether this is actually faster
---collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
+-- collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
---{-# INLINE collidePointTestFilter #-}
+-- {-# INLINE collidePointTestFilter #-}
---collidePointTestFilter t sp ep = runIdentity
+-- collidePointTestFilter t sp ep = runIdentity
 --    . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
 --    . S.filter t
 
 collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
 {-# INLINE collidePointWallsFilter #-}
-collidePointWallsFilter t sp ep = collidePoint sp ep . filter t . wlsNearSeg sp ep
+collidePointWallsFilter t sp ep = collidePoint sp ep . IM.filter t . wlsNearSeg sp ep
 
---overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
+-- overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
 --    -> StreamOf (Point2,Wall)
---{-# INLINE overlapSegWalls #-}
+-- {-# INLINE overlapSegWalls #-}
---overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+-- overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
-overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
+overlapSegWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
 {-# INLINE overlapSegWalls #-}
-overlapSegWalls sp ep = mapMaybe 
+overlapSegWalls sp ep = IM.mapMaybe $
-    $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+    \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
 
 visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
 {-# INLINE visibleWalls #-}
 visibleWalls sp ep =
     takeUntil (wlIsOpaque . snd)
         . sortOn (dist sp . fst)
+        . IM.elems
         . overlapSegWalls sp ep
         . wlsNearSeg sp ep
 
@@ -227,16 +262,12 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays
   where
     vPos = w ^. wCam . camViewFrom
 
-overlapCircWalls ::
+overlapCircWalls :: Point2 -> Float -> [Wall] -> [(Point2, Wall)]
-    Point2 ->
-    Float ->
-    [Wall] ->
-    [(Point2, Wall)]
 {-# INLINE overlapCircWalls #-}
-overlapCircWalls p r = mapMaybe dointersect
+overlapCircWalls p r = mapMaybe g
   where
-    dointersect wl = f (_wlLine wl) <&> (,wl)
+    g wl = f (_wlLine wl) <&> (,wl)
-    f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
+    f (a, b) = intersectSegSeg p (p + r *^ vNormal (normalizeV (b - a))) a b
 
 circHitWall :: Point2 -> Point2 -> Float -> World -> Bool
 circHitWall sp ep r w =
@@ -250,35 +281,26 @@ 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
     findPoint (p, mwl) wl =
-        maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
+        maybe (p, mwl) (,Just wl)
+            . uncurry (intersectSegSeg sp p)
             . shiftbyrad
             . _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 #-}
-overlapCircWallsClosest p r =
+overlapCircWallsClosest p r = safeMinimumOn (dist p . fst) . overlapCircWalls p r
-    safeMinimumOn (dist p . fst)
-        . overlapCircWalls p r
-
---overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
---{-# INLINE overlapCircWallsClosest #-}
---overlapCircWallsClosest p r = minStreamOn (dist p . fst)
---    . overlapCircWalls p r
 
 {- | Test if a circle collides with any wall.
  - Note no check on whether the wall is walkable.
@@ -312,7 +334,7 @@ hasButtonLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasButtonLOS #-}
 hasButtonLOS _ _ = const True
 
---hasButtonLOS p1 p2 =
+-- hasButtonLOS p1 p2 =
 --    not
 --        . collidePointTestFilter (not . _wlTouchThrough) p1 p2
 --        . wlsNearSeg p1 p2
@@ -322,9 +344,9 @@ hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
 hasLOSIndirect p1 p2 =
     not
         . collidePointTestFilter wlIsOpaque p1 p2
+--        . IM.elems
         . wlsNearSeg p1 p2
 
-
 canSee :: Int -> Int -> World -> Bool
 {-# INLINE canSee #-}
 canSee i j w = hasLOS p1 p2 w

src/Dodge/Base/Coordinate.hs

@@ -2,13 +2,15 @@ module Dodge.Base.Coordinate (
     worldPosToScreen,
     screenToWorldPos,
     mouseWorldPos,
+    mouseWorldPosW,
     worldPosToResOffset,
 ) where
 
+import Dodge.Data.World
 import Control.Lens
-import Dodge.Data.Camera
+--import Dodge.Data.Camera
 import Dodge.Data.Config
-import Dodge.Data.Input
+--import Dodge.Data.Input
 import Dodge.WindowSize
 import Geometry
 import Linear
@@ -37,6 +39,9 @@ worldPosToResOffset cfig cam p =
 mouseWorldPos :: Input -> Camera -> Point2
 mouseWorldPos inp cam = screenToWorldPos cam (inp ^. mousePos)
 
+mouseWorldPosW :: World -> Point2
+mouseWorldPosW w = mouseWorldPos (w ^. input) (w ^. wCam)
+
 screenToWorldPos :: Camera -> Point2 -> Point2
 screenToWorldPos cam p =
     (cam ^. camCenter) + (1 / (cam ^. camZoom)) *.* rotateV (cam ^. camRot) p

src/Dodge/Base/You.hs

@@ -3,8 +3,12 @@ module Dodge.Base.You
     , yourInv
     , yourSelectedItem
     , yourRootItem
+    , yourRootItemDT
     )where
 
+import Dodge.Item.Grammar
+import Dodge.Data.ComposedItem
+import Dodge.Data.DoubleTree
 import NewInt
 import Dodge.Data.World
 --import qualified IntMapHelp as IM
@@ -15,16 +19,21 @@ 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 <- w^?hud. manObject . hiRootSelectedItem . unNInt
+    invIMDT ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> you w ^. crInv) ^? ix i
+
 yourInv :: World -> NewIntMap InvInt Item
 yourInv w = fmap (\i -> w ^?! cWorld . lWorld . items . ix i) . _crInv . you $ w
 

src/Dodge/BaseTriggerType.hs

@@ -21,7 +21,8 @@ itemTriggerType loc
 baseItemTriggerType :: Item -> TriggerType
 baseItemTriggerType itm = case itm ^. itType of
     HELD hit -> heldTriggerType hit
-    ATTACH CAPACITOR -> AutoTrigger 10
+    ATTACH CAPACITOR -> AutoTrigger 0
+--    ATTACH CAPACITOR -> AutoTrigger 10
     _ -> NoTrigger
 
 heldTriggerType :: HeldItemType -> TriggerType
@@ -54,8 +55,7 @@ heldTriggerType = \case
     FLAMETORRENT -> NoTrigger
     FLAMEWALL -> NoTrigger
     BLOWTORCH -> NoTrigger
-    SPARKGUN -> NoTrigger
+    TESLACOIL -> NoTrigger
-    TESLAGUN -> NoTrigger
     TRACTORGUN -> NoTrigger
     RLAUNCHER -> SemiAutoTrigger 20
     RLAUNCHERX{} -> SemiAutoTrigger 20

src/Dodge/Block/Debris.hs

@@ -1,20 +1,23 @@
 module Dodge.Block.Debris (
     cubeShape,
---    dirtColor,
+    --    dirtColor,
     makeDoorDebris,
     makeBlockDebris,
     makeDebris,
     makeDebrisDirected,
+    makeMachineDebris,
 ) where
 
-import Dodge.Material.Color
+import Control.Monad
-import qualified Data.IntMap.Strict as IM
+import Dodge.Machine.Draw
-import Dodge.ShiftPoint
+import Color
 import Data.Foldable
+import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Data.World
 import Dodge.Material.Sound
+import Dodge.ShiftPoint
 import Dodge.WorldEvent.Sound
 import Geometry
 import Grid
@@ -23,37 +26,81 @@ import qualified Quaternion as Q
 import RandomHelp
 import Shape
 
+makeMachineDebris :: Machine -> World -> World
+makeMachineDebris mc w = foldl' (flip $ makeDebrisZ 20 (MetalDebris $ mcColor mc) mt) w ps
+  where
+    pa = (mc ^. mcPos, mc ^. mcDir)
+    dsize = debrisSize mt
+    ps = fmap (shiftPointBy pa) 
+        . gridInPolygon dsize 
+        . shrinkPolyOnEdges dsize 
+        $ reverse (fst <$> mc ^.. mcFootPrint . each)
+    mt = mc ^. mcSkin
+
+
 makeDoorDebris :: Door -> World -> World
-makeDoorDebris dr w = w & makeDebris mt p
+makeDoorDebris dr w = w & makeDebris (BlockDebris drcol) mt p
   where
     p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp)
     p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
     mt = fromMaybe Stone $ do
         wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
-        ((wlid,_),_) <- IM.minViewWithKey wlids 
+        ((wlid, _), _) <- IM.minViewWithKey wlids
         w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
+    drcol = case dr ^. drTrigger of
+        WdBlCrFilterNearPoint {} -> yellow
+        _ -> red
+
+blColor :: Block -> Color
+blColor _ = orange
 
 makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
+makeBlockDebris bl w = foldl' (flip $ makeDebris (blockDebrisType mwl bl) mt) w ps
   where
     dsize = debrisSize mt
     ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
-    mt = fromMaybe Stone $ do
+    mt = fromMaybe Stone $ mwl ^? _Just . wlMaterial
+    mwl = do
         wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
         (wlid, _) <- IS.minView wlids
-        wl <- w ^? cWorld . lWorld . walls . ix wlid
+        w ^? cWorld . lWorld . walls . ix wlid
-        return $ _wlMaterial wl
 
---makeDebris :: Material -> Color -> Point2 -> World -> World
+blockDebrisType :: Maybe Wall -> Block -> DebrisType
-makeDebris :: Material -> Point2 -> World -> World
+blockDebrisType wl bl = case wl ^? _Just . wlMaterial of
+    Just Glass -> GlassDebris
+    Just Metal -> MetalDebris red
+    _ -> BlockDebris $ blColor bl
+
+-- makeDebris :: Material -> Color -> Point2 -> World -> World
+makeDebris :: DebrisType -> Material -> Point2 -> World -> World
 makeDebris = makeDebrisDirected (2 * pi) 0
 
-makeDebrisDirected :: Float -> Float -> Material ->  Point2 -> World -> World
+makeDebrisZ :: Float -> DebrisType -> Material -> Point2 -> World -> World
---makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
+makeDebrisZ = makeDebrisDirectedZ (2 * pi) 0
---makeDebrisDirected arcrad dir bm col p w =
+
-makeDebrisDirected arcrad dir bm p w =
+makeDebrisDirectedZ :: Float -> Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisDirectedZ arcrad dir z dt bm p w =
+    w
+        & cWorld . lWorld . debris <>~ thedebris
+        & randGen .~ newg
+        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
+  where
+    (thedebris, newg) = replicateM 4 f & runState $ _randGen w
+    f = do
+        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
+        spinspeed <- randomR (-0.2, -0.1) & state
+        return $
+            DebrisChunk
+                { _dbPos = p `v2z` z
+                , _dbType = dt
+                , _dbVel = v `v2z` 0
+                , _dbRot = Q.qid
+                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
+                }
+
+makeDebrisDirected :: Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisDirected arcrad dir dt bm p w =
     w
---        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
         & cWorld . lWorld . debris <>~ thedebris
         & randGen .~ newg
         & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
@@ -62,21 +109,22 @@ makeDebrisDirected arcrad dir bm p w =
     f h = do
         v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
         spinspeed <- randomR (-0.2, -0.1) & state
---        basedebris <- baseDebris bm
+        --        basedebris <- baseDebris bm
-        return $ DebrisChunk
+        return $
-            { _dbPos = p `v2z` h
+            DebrisChunk
---            , _dbType = BlockDebris col
+                { _dbPos = p `v2z` h
-            , _dbType = BlockDebris (materialColor bm)
+                , _dbType = dt
-            , _dbVel = v `v2z` 0
+                , _dbVel = v `v2z` 0
-            , _dbRot = Q.qID
+                , _dbRot = Q.qid
-            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
+                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
-            }
+                }
+
 --            basedebris
 --                & prColor .~ col
 --                & prPos .~ p
 --                & prVel .~ v
 --                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
---                & prQuat .~ Q.qID
+--                & prQuat .~ Q.qid
 --                & prVelZ .~ 0
 --                & prPosZ .~ h
 
@@ -91,9 +139,13 @@ debrisSize mt = case mt of
     Electronics -> 10
     Flesh -> 10
     ForceField -> 10
+    Photovoltaic -> 10
+    LightningRod -> 10
+    Pyroelectric -> 10
+    Piezoelectric -> 10
 
---shardShape :: Float -> Shape
+-- shardShape :: Float -> Shape
---shardShape size =
+-- shardShape size =
 --    translateSHz (- size) $
 --        upperPrismPolySU
 --            size
@@ -102,10 +154,10 @@ debrisSize mt = case mt of
 --            , V2 (- size) (-1)
 --            ]
 --
---jaggedShape :: State StdGen Shape
+-- jaggedShape :: State StdGen Shape
---jaggedShape = do
+-- jaggedShape = do
 --    s <- randomR (4, 10) & state
 --    return $ shardShape s
 
 cubeShape :: Float -> Shape
-cubeShape size = translateSHz (- size) $ upperPrismPolySU (2 * size) $ square size
+cubeShape size = translateSHz (-size) $ upperPrismPolySU (2 * size) $ square size

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
@@ -168,11 +170,12 @@ hitEffFromBul w bu = case _buEffect bu of
     DestroyBullet -> expireAndDamage bu hitstream w
   where
     sp = _buPos bu
-    hitstream = thingsHitZ 20 sp (sp + _buVel bu) w
+    hitstream = thingsHitZ' 20 sp (sp + _buVel bu) w
 
 getBulHitDams :: Bullet -> Point2 -> [Damage]
 getBulHitDams bu p = case _buPayload bu of
-    BulPlain x -> [Piercing x p v]
+    BulPlain x -> [Piercing x p v (bu ^. buOrigin)
+        ,Inertial 0 p v (bu ^. buOrigin)]
     _ -> []
   where
     v = _buVel bu

src/Dodge/Button/Draw.hs

@@ -1,16 +1,18 @@
-module Dodge.Button.Draw where
+module Dodge.Button.Draw (drawButton) where
 
+import Data.Maybe
+import Dodge.Data.LWorld
 import Color
-import Dodge.Data.Button
 import Geometry
 import Shape
 import ShapePicture
 import Control.Lens
 
-drawButton :: Button -> SPic
+drawButton :: LWorld -> Button -> SPic
-drawButton bt = case bt ^. btEvent of
+drawButton lw bt = case bt ^. btEvent of
     ButtonPress {_bpColor = col} -> defaultDrawButton col bt
     ButtonSwitch {_bsColor1 = col1, _bsColor2 = col2} -> drawSwitch col1 col2 bt
+    ButtonDumbSwitch i -> drawDumbSwitch (fromMaybe True $ lw ^? triggers . ix i)
     ButtonAccessTerminal _ -> mempty
 
 drawSwitch :: Color -> Color -> Button -> SPic
@@ -26,6 +28,19 @@ drawSwitch col1 col2 bt
             ]
         )
 
+drawDumbSwitch :: Bool -> SPic
+drawDumbSwitch t
+    |  t = flick $ pi / 4
+    | otherwise = flick (negate (pi / 4))
+  where
+    flick a = noPic
+        ( mconcat
+            [ colorSH red . upperBox Small Typical 20 $ rectNSWE (-2) (-5) (-10) 10
+            , colorSH (dim red) . translateSH (V3 0 (-2) 20) . rotateSH a . upperBox Small Typical 2 $
+                    rectNSWE 10 0 (-2) 2
+            ]
+        )
+
 defaultDrawButton :: Color -> Button -> SPic
 defaultDrawButton col bt = noPic
     ( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry

src/Dodge/Button/Event.hs

@@ -12,6 +12,7 @@ doButtonEvent = \case
     ButtonPress False f _ -> buttonFlip f
     ButtonSwitch _ f _ _ True -> buttonFlip f
     ButtonSwitch f _ _ _ False -> buttonFlip f
+    ButtonDumbSwitch i -> \_ -> cWorld . lWorld . triggers . ix i %~ not
     ButtonAccessTerminal tid -> const $ accessTerminal tid
 
 buttonFlip :: WdWd -> Button -> World -> World

src/Dodge/Combine/Combinations.hs

@@ -92,8 +92,7 @@ itemCombinations =
 --           , po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam
 --           , po [HELD LASGUN, cr TRANSFORMER] (lasWide 2)
 --           , po [HELD LASGUN, HELD LASGUN, HELD LASGUN, cr HARDWARE] lasCircle
-           , p [o $ cr TRANSFORMER, p 2 $ cr CAN] sparkGun
+           , p [o $ cr TRANSFORMER, p 2 $ cr CAN] teslaCoil
-           , p [o (HELD SPARKGUN), p 2 $ cr PIPE] teslaGun
 --           , p [o $ cr TELEPORTMODULE, p 2 $ cr MICROCHIP] blinker
            , p [o $ HELD BLINKER, p 2 $ cr MICROCHIP] unsafeBlinker
            , po [cr MAGNET, cr TIN] (magShield MagnetRepulse)

src/Dodge/Corpse/Make.hs

@@ -1,25 +0,0 @@
-module Dodge.Corpse.Make (makeCorpse) where
-
-import Control.Lens
-import Dodge.Creature.Picture
-import Dodge.Creature.Radius
-import Dodge.Creature.Shape
---import Dodge.Data.Corpse
-import Dodge.Data.Creature
-import Geometry
-import Shape
-import ShapePicture
-
-makeCorpse :: Creature -> SPic
-makeCorpse cr =
-    noPic
-        . scaleSH (V3 crsize crsize crsize)
-        $ mconcat
-            [ colorSH (_skinHead cskin) $ deadScalp cr
-            , colorSH (_skinUpper cskin) $ deadUpperBody cr
-            , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
-            ]
-  where
-    cskin = crShape $ _crType cr -- this should be fixed
-    crsize = 0.1 * crRad (cr ^. crType)
-    rotmdir = rotateSH (_crMvDir cr - _crDir cr)

src/Dodge/Creature.hs

@@ -3,8 +3,6 @@ module Dodge.Creature (
     module Dodge.Creature.ChaseCrit,
     module Dodge.Creature.Inanimate,
     launcherCrit,
---    pistolCrit,
-    ltAutoCrit,
     spreadGunCrit,
     autoCrit,
     armourChaseCrit,
@@ -13,11 +11,8 @@ module Dodge.Creature (
     module Dodge.Creature.Impulse,
     module Dodge.Creature.Perception,
     module Dodge.Creature.ReaderUpdate,
-    module Dodge.Creature.SentinelAI,
     module Dodge.Creature.State,
-    module Dodge.Creature.Strategy,
     module Dodge.Creature.Test,
-    module Dodge.Creature.Volition,
     module Dodge.Creature.YourControl,
 ) where
 
@@ -34,15 +29,11 @@ import Dodge.Creature.ChaseCrit
 import Dodge.Creature.Impulse
 import Dodge.Creature.Inanimate
 import Dodge.Creature.LauncherCrit
-import Dodge.Creature.LtAutoCrit
 import Dodge.Creature.Perception
 import Dodge.Creature.ReaderUpdate
-import Dodge.Creature.SentinelAI
 import Dodge.Creature.SpreadGunCrit
 import Dodge.Creature.State
-import Dodge.Creature.Strategy
 import Dodge.Creature.Test
-import Dodge.Creature.Volition
 import Dodge.Creature.YourControl
 import Dodge.Data.Creature
 import Dodge.Default
@@ -98,8 +89,7 @@ startCr =
         & crHP .~ HP 10000
         & crInv .~ mempty
         & crFaction .~ PlayerFaction
---        & crMvType .~ MvWalking yourDefaultSpeed
+        & crType .~ Avatar (PulseStatus 55 0) Flesh 50 50 50 AvPosture LeftForward 0
-        & crType .~ Avatar (PulseStatus 55 0) Flesh 50 50 50 3
 
 -- | Items you start with.
 startInvList :: [Item]
@@ -114,6 +104,7 @@ inventoryX c = case c of
         [introScan t | t <- [minBound..maxBound]] <>
         [ flameThrower
         , chemFuelPouch
+        , makeTypeCraft PUMP
         , fuelPack
         , copier ABSOLUTE
         , nulgate
@@ -208,10 +199,12 @@ inventoryX c = case c of
         [ makeTypeCraftNum 2 MICROCHIP
         ]
     "J" ->
-        [ laser
+        [ capacitor
+        , makeTypeCraft TRANSFORMER
+        , laser
         , battery
-        --, dualBeam
+        ] 
-        ] <> makeTypeCraftNum 10 TRANSFORMER
+        <> makeTypeCraftNum 5 BEAMSPLITTER
     "K" ->
         [ autoRifle
         , tinMag
@@ -344,7 +337,7 @@ stackedInventory =
     , megaBattery
     , capacitor
     , makeTypeCraft TRANSFORMER
-    , teslaGun
+    , teslaCoil
     , megaBattery
     , flameThrower
     , chemFuelPouch

src/Dodge/Creature/Action.hs

@@ -10,6 +10,10 @@ module Dodge.Creature.Action (
     youDropItem,
 ) where
 
+import qualified IntSetHelp as IS
+import Dodge.DisplayInventory
+import Dodge.Data.SelectionList
+import RandomHelp
 import Dodge.WorldEvent.ThingsHit
 import Control.Applicative
 import Control.Monad
@@ -33,158 +37,172 @@ import qualified IntMapHelp as IM
 import LensHelp
 import Linear
 import NewInt
+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) = foldMap (performAction cr w) $ cr ^. crActionPlan . apAction
+--    (iss, mayas) = maybe ([],NoAction) (performAction cr w) (cr ^? crActionPlan . apAction)
 
-type ActionUpdate = ([Impulse], [Action])
+type ActionUpdate = ([Impulse], Action)
 
 {- | Performing an action on a frame creates an ActionUpdate:
   gives impulses and updates/deletes the action itself.
 -}
 performAction :: Creature -> World -> Action -> ActionUpdate
 performAction cr w ac = case ac of
+    Eat i x -> ([],Eat i x)
+--    Eat i x | x <= 0 -> ([],NoAction)
+--    Eat i x -> ([],Eat i (x-1))
     AimAt tcid p -> performAimAt cr w tcid p
-    WaitThen 0 newAc -> ([], [newAc])
+    WaitThen 0 newAc -> ([], newAc)
-    WaitThen t newAc -> ([], [WaitThen (t -1) newAc])
+    WaitThen t newAc -> ([], WaitThen (t -1) newAc)
-    ImpulsesList (xs : xss) -> (xs, [ImpulsesList xss])
+    ImpulsesList (xs : xss) a -> performAction cr w a & _1 <>~ xs
-    ImpulsesList _ -> ([], mempty)
+        & _2 %~ ImpulsesList xss
-    DoImpulses imps -> (imps, mempty)
+    ImpulsesList _ a -> performAction cr w a
-    DoActionThen fsta afta -> case performAction cr w fsta of -- NOTE this only does ONE continuation action
+    DoImpulses imps -> (imps, NoAction)
-        (imps, nxta : _) -> (imps, [DoActionThen nxta afta])
+    DoActionThen fsta afta -> case performAction cr w fsta of
-        (imps, []) -> (imps, [afta])
+        (imps, NoAction) -> (imps, afta)
-    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
+        (imps, nxta) -> (imps, DoActionThen nxta afta)
+--    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
     DoActionWhilePartial partAc f resetAc
         | doWdCrBl f w cr -> case performAction cr w partAc of
-            (imps, nxta : _) -> (imps, [DoActionWhilePartial nxta f resetAc])
+            (imps, NoAction) -> (imps, DoActionWhilePartial resetAc f resetAc)
-            (imps, []) -> (imps, [DoActionWhilePartial resetAc f resetAc])
+            (imps, nxta ) -> (imps, DoActionWhilePartial nxta f resetAc)
         | otherwise -> performAction cr w partAc
     DoActionIf f ifa
         | doWdCrBl f w cr -> performAction cr w ifa
-        | otherwise -> ([], mempty)
+        | otherwise -> ([], NoAction)
     DoActionIfElse ifa f elsea
         | doWdCrBl f w cr -> performAction cr w ifa
         | otherwise -> performAction cr w elsea
     DoActionWhileInterrupt repa f afta
-        | doWdCrBl f w cr -> (fst $ performAction cr w repa, [DoActionWhileInterrupt repa f afta])
+        | doWdCrBl f w cr -> (fst $ performAction cr w repa, DoActionWhileInterrupt repa f afta)
         | otherwise -> performAction cr w afta
-    DoActions [] -> ([], mempty)
+    PathTo p a -> performPathTo a cr w p
-    DoActions acs ->
+    EvadeAim -> tryEvadeSideways cr w
-        let (imps, newAcs) = foldMap (performAction cr w) acs
-         in (imps, newAcs)
-    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], mempty)
-    PathTo p -> performPathTo cr w p
     TurnToPoint p -> performTurnToA cr p
-    LeadTarget p -> fromMaybe ([], mempty) $ do
+    LeadTarget p -> fromMaybe ([], NoAction) $ do
         i <- cr ^? crIntention . targetCr . _Just
         tcr <- w ^? cWorld . lWorld . creatures . ix i
-        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], mempty)
+        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], NoAction)
-    UseSelf f -> performAction cr w $ doCrAc f cr
+    DoImpulsesAlongside sideImp mainAc -> performAction cr w mainAc & _1 <>~ sideImp
-    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
-    DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
-        (imp, [nxtac]) -> (sideImp ++ imp, [DoImpulsesAlongside sideImp nxtac])
-        (imp, _) -> (sideImp ++ imp, mempty)
     DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
     DoReplicatePartial _ 0 pac -> performAction cr w pac
     DoReplicatePartial startac t partac -> case performAction cr w partac of
-        (imps, [nextac]) -> (imps, [DoReplicatePartial startac t nextac])
+        (imps, NoAction) -> (imps, DoReplicatePartial startac (t -1) startac)
-        (imps, _) -> (imps, [DoReplicatePartial startac (t -1) startac])
+        (imps, nextac) -> (imps, DoReplicatePartial startac t nextac)
-    NoAction -> ([], mempty)
+    NoAction -> ([], NoAction)
+
+tryEvadeSideways :: Creature -> World -> ActionUpdate
+tryEvadeSideways _ w = jumpleft -- (mv,mempty)
+  where
+    jumpleft = (mv,DoReplicate 5 (DoImpulses mv))
+    mv = [Walk (V2 0 d),UpdateRandGen]
+    d = evalState (takeOne [3,-3]) (w ^. randGen)
 
 performAimAt :: Creature -> World -> Int -> Point2 -> ActionUpdate
-performAimAt cr w tcid p = ([TurnToward tpos aimSp], [AimAt tcid tpos])
+performAimAt cr w tcid p = ([TurnToward tpos aimSp], AimAt tcid tpos)
   where
     cdir = _crDir cr
     cpos = cr ^. crPos . _xy
     canSee' = canSee (_crID cr) tcid w
-    aimSp = case crMvType cr ^? mvAimSpeed of
+    aimSp = case crMvType cr ^? mvTurnRad of
         Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
         Nothing -> error "creature without aiming type"
+--    aimSp = case crMvType cr ^? mvAimSpeed of
+--        Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos)
+--        Nothing -> error "creature without aiming type"
     tpos
         | canSee' = w ^?! cWorld . lWorld . creatures . ix tcid . crPos . _xy
         | otherwise = p
 
-performPathTo :: Creature -> World -> Point2 -> ActionUpdate
+crPathing :: Creature -> (Point2 -> Point2 -> World -> Bool,S.Set EdgeObstacle -> Bool)
-performPathTo cr w p
+crPathing cr = case cr ^. crStance . carriage of
-    | dist cpos p <= crRad (cr ^. crType) = mempty
+    Flying {} -> (isFlyable, not . S.member (WallObstacle WallNotAutoOpen))
-    | isWalkable cpos p w = gotowards p
+    _ -> (isWalkable, not . pathEdgeObstructed)
-    | otherwise = case pointTowardsImpulse cpos p w of
+
+performPathTo :: Action -> Creature -> World -> Point2 -> ActionUpdate
+performPathTo a cr w p
+    | dist cpos p <= crRad (cr ^. crType) = (mempty,NoAction)
+    | fst (crPathing cr) cpos p w = gotowards p
+    | otherwise = case uncurry pointTowardsImpulse' (crPathing cr) cpos p w of
         Just q -> gotowards q
-        _ -> ([ChangeStrategy Flee], [])
+        _ -> ([], a)
   where
-    gotowards q = ( [MvTurnToward q, MvForward, RandomTurn jit] , [PathTo p])
+    gotowards q = ( crMoveImpulses cr q , PathTo p a)
     cpos = cr ^. crPos . _xy
-    jit = _mvTurnJit $ crMvType cr
+
+crMoveImpulses :: Creature -> Point2 -> [Impulse]
+crMoveImpulses cr p = case crMvType cr of
+    NoMvType -> [MvTurnToward p, MvForward]
+    MvWalking {} -> [MvTurnToward p, MvForward]
+    JitMvType {_mvTurnJit = x} -> [MvTurnToward p, MvForward, RandomTurn x]
+    StartStopMvType {} -> [MvTurnToward p, MvForward]
+    BeeMvType {} | cr ^?! crType . startStopMv == 0 -> [SetBeeRandomMovement, MvForward, MvTurnToward p]
+    BeeMvType {} -> [MvTurnToward p, MvForward]
 
 performTurnToA :: Creature -> Point2 -> ActionUpdate
 performTurnToA cr p
-    | angleVV cdirv dirv < 0.1 = mempty
+    | angleVV cdirv dirv < 0.1 = (mempty,NoAction)
-    | otherwise = ([MvTurnToward p, RandomTurn jit], [TurnToPoint p])
+    | otherwise = ([MvTurnToward p, RandomTurn jit], TurnToPoint p)
   where
     cpos = cr ^. crPos . _xy
     cdirv = unitVectorAtAngle (_crDir cr)
     dirv = p -.- cpos
     jit = _mvTurnJit $ crMvType cr
 
---setMinInvSize :: Int -> Creature -> World -> World
---setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity .~ n
-
---organiseInvKeys :: Int -> World -> World
---organiseInvKeys cid w =
---    w & cWorld . lWorld . creatures . ix cid
---        %~ ( (crInvSel . iselPos .~ newSelKey)
---                . (crInv .~ newInv)
---                . (crInvSel . iselAction .~ NoInvSelAction)
---           )
---  where
---    cr = w ^?! cWorld . lWorld . creatures . ix cid -- _creatures (_cWorld w) IM.! cid
---    pairs = IM.toList (_crInv cr)
---    newSelKey = fromMaybe 0 $ findIndex ((== crSel cr) . fst) pairs
---    newInv = IM.fromAscList $ zip [0 ..] $ map snd pairs
-
 -- why not a cid (Int)?
 dropItem :: Creature -> Int -> World -> World
-dropItem cr invid w' =
+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

@@ -5,6 +5,7 @@ module Dodge.Creature.Action.Blink (
     unsafeBlinkAction,
 ) where
 
+import qualified Data.IntMap.Strict as IM
 import Linear
 import Dodge.Creature.Radius
 import Dodge.Zoning.Wall
@@ -28,13 +29,13 @@ 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
     cpos = cr ^. crPos . _xy
     --p2 = bouncePoint (const True) 1 cpos p1 w
-    p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (wlsNearSeg cpos p1 w)
+    p2 = pushIntoMaybe $ collideCircWalls cpos p1 r (IM.elems $ wlsNearSeg cpos p1 w)
     r = crRad $ cr ^. crType
     p3 = maybe p1 ((+.+ squashNormalizeV (cpos -.- p1)) . fst) p2 
     --p3 = maybe p1 (const 0) p2 
@@ -62,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
@@ -81,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
@@ -90,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 = []
+--                { _apAction = NoAction
-                , _apStrategy = FollowImpulses
+----                , _apStrategy = FollowImpulses
-                , _apGoal = [Kill 0]
+--                , _apGoal = Kill 0
-                }
+--                }
         , _crGroup = ShieldGroup
 --        , _crMvType = defaultChaseMvType
         }

src/Dodge/Creature/ChaseCrit.hs

@@ -1,10 +1,18 @@
 module Dodge.Creature.ChaseCrit (
     smallChaseCrit,
     invisibleChaseCrit,
+    crabCrit,
     chaseCrit,
+    hoverCrit,
+    slinkCrit,
+    slimeCrit,
+    beeCrit,
+    hiveCrit,
 ) where
 
---import Dodge.Data.Equipment.Misc
+import qualified Quaternion as Q
+import Linear
+import Dodge.Data.FloatFunction
 import Control.Lens
 import Dodge.Data.Creature
 import Dodge.Default
@@ -30,8 +38,71 @@ chaseCrit =
         & crName .~ "chaseCrit"
         & crHP .~ HP 150
         & crFaction .~ ColorFaction green
-        & crVocalization .~ chaseCritVocalization
+        & crActionPlan . apGoal .~ SearchForFood
-        & crStance . strideLength .~ 30
+        & crActionPlan . apStrategy .~ Search
 
-chaseCritVocalization :: Vocalization
+crabCrit :: Creature
-chaseCritVocalization = Vocalization (50, 200) 0
+crabCrit = defaultCreature
+        & crName .~ "chaseCrit"
+        & crHP .~ HP 350
+        & crType .~ CrabCrit
+            { _meleeCooldownL = 0
+            , _meleeCooldownR = 0
+            , _dodgeCooldown = 0
+            , _lFootPos = 0
+            , _rFootPos = 0
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slinkCrit :: Creature
+slinkCrit = defaultCreature
+        & crName .~ "slinkCrit"
+        & crHP .~ HP 1000
+        & crType .~ SlinkCrit
+            { _meleeCooldown = 0
+            , _slinkSpine = replicate 15 (V3 0 0 2, Q.axisAngle (V3 0 1 0) (pi/15))
+            , _slinkHeadPos = (V3 20 0 15, Q.axisAngle (V3 0 1 0) (pi/2))
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slimeCrit :: Creature
+slimeCrit = defaultCreature
+        & crName .~ "slimeCrit"
+        & crHP .~ HP 1000
+--        & crType .~ SlimeCrit r 0 0 (V2 (slimeToRad r) 0) False 0
+        & crType .~ SlimeCrit r 0 NoSlimeDistortion 1 False 0
+        & crFaction .~ ColorFaction (light green)
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+        & crActionPlan .~ SlimeIntelligence
+        & crStance . carriage .~ Crawling
+  where
+    r = 250000
+
+hoverCrit :: Creature
+hoverCrit =
+    defaultCreature
+        & crName .~ "hoverCrit"
+        & crHP .~ HP 150
+        & crType .~ HoverCrit 0
+        & crFaction .~ ColorFaction blue
+        & crStance . carriage .~ Flying 15
+
+beeCrit :: Creature
+beeCrit =
+    defaultCreature
+        & crName .~ "beeCrit"
+        & crHP .~ HP 100
+        & crType .~ BeeCrit 0 Nothing 0 0 0 Nothing 1
+        & crFaction .~ ColorFaction yellow
+        & crStance . carriage .~ Flying 15
+
+hiveCrit :: Creature
+hiveCrit =
+    defaultCreature
+        & crName .~ "hiveCrit"
+        & crHP .~ HP 100000
+        & crType .~ HiveCrit mempty 0 400
+        & crStance . carriage .~ Rooted
+        & crFaction .~ ColorFaction yellow

src/Dodge/Creature/Damage.hs

@@ -1,6 +1,7 @@
 module Dodge.Creature.Damage (applyCreatureDamage) where
 
---import Linear
+import Dodge.Creature.Mass
+import Linear
 import Dodge.Material.Damage
 import Data.List
 --import Dodge.Creature.Mass
@@ -11,30 +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 dm = 
+applyIndividualDamage cid cr w (Inertial _ _ v _) = w 
-    let (i,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
+    & cWorld . lWorld . creatures . ix cid . crPos . _xy +~ fmap (/ crMass (cr ^. crType)) v
-    in w' & damageHP cr i
+applyIndividualDamage cid cr w dm = 
---  case dm of
+    let (x,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
---    Piercing{} -> applyPiercingDamage cr dm w
+    in w' & damageHP cid x
---    _ -> 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

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Dodge.Creature.HandPos (
     equipSitePQ,
     translatePointToLeftHand,
@@ -11,122 +12,176 @@ module Dodge.Creature.HandPos (
     headPQ,
     translateToES,
     rightHandPQ,
+    leftHandPQ,
+    strideLength,
 ) where
 
-import Dodge.Data.Equipment.Misc
+import Dodge.Data.World
-import qualified Quaternion as Q
+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
+    OnHead ->  headPQ
-    OnChest -> chestPQ
+    OnChest ->  chestPQ
-    OnBack -> backPQ
+    OnBack ->  backPQ
-    OnLeftLeg -> leftLegPQ
+    OnLeftLeg -> const $ legPQ LeftForward
-    OnRightLeg -> rightLegPQ
+    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))
 
-rightHandPQ :: Creature -> Point3Q
+strideLength :: Creature -> Float
-rightHandPQ cr
+strideLength cr = case cr ^. crType of
-    | oneH cr = (V3 11 (-3) 20, Q.qID)
+    Avatar{} -> 35
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0,Q.qID)
+    _ -> 30
-    | twoFlat cr = (V3 4 (-8) 10, Q.qID)
+
-    | otherwise = case cr ^? crStance . carriage of
+handWalkingPos :: FootForward -> Float -> Creature -> Point3
-        Just (Walking sa LeftForward) -> (V3 (- f sa) (- off) 10, Q.qID)
+handWalkingPos b off cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
-        Just (Walking sa RightForward) -> (V3 (- g sa) (- off) 10, Q.qID)
+    (Just sa,Just ff) ->
-        _ -> (V3 0 (- off) 10, Q.qID)
+        let slen = strideLength cr
+            f i
+                | ff == b = 8 * zeroOneSmooth ((slen - i) / slen)
+                | otherwise = 8 * zeroOneSmooth (i / slen)
+         in V3 (f sa) off 12
+    _ -> V3 0 off 12
+
+zeroOneSmooth :: Float -> Float
+zeroOneSmooth x = (1 - cos (pi * x)) / 2
+
+rightHandPQ :: World -> Creature -> Point3Q
+rightHandPQ w cr
+    | oneH w cr = (V3 11 (-3) 20, Q.qid)
+    | twists w cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0, Q.qz 1)
+    | twoFlat w cr = (V3 8 (-8) 12, Q.qid)
+    | Just TwoHandTwist <- w ^? hud . manObject . hiAimStance
+        = (V3 6 (-6) 10, Q.qid)
+    | Just TwoHandFlat <- 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)
+
+crRightHandWall :: Creature -> Maybe Point2
+crRightHandWall cr = do
+    (_,p) <- IM.lookupMin (cr ^. crWallTouch)
+    let wp = p - cr ^. crPos . _xy 
+        dp = argV wp
+        ang = nearZeroAngle (cd - dp)
+        cdp = unitVectorAtAngle cd
+        x   | ang < 0 = 0.8 - (0.5 * ang / (pi / 4))
+            | otherwise =  0.8* dotV cdp (signorm wp)
+        y   | ang < 0 = 2 - (5 * ang / (pi / 4))
+            | otherwise = 2
+        ep = wp - y *^ signorm wp + x *^ vNormal wp
+    guard $ ang > negate (pi / 8)
+    return $ ep & _xy %~ rot
   where
-    off = 8
+    cd = cr ^. crDir
-    sLen = _strideLength $ _crStance cr
+    rot = rotateV (negate cd)
-    f i = negate 2 + negate 6 * (sLen - i) / sLen
-    g i = negate 2 + negate 6 * i / sLen
 
-translateToRightHand :: Creature -> SPic -> SPic
+crLeftHandWall :: Creature -> Maybe Point2
-translateToRightHand = overPosSP . translatePointToRightHand
+crLeftHandWall cr = do
-
+    (_,p) <- IM.lookupMin (cr ^. crWallTouch)
-rightWristPQ :: Creature -> Point3Q
+    let wp = p - cr ^. crPos . _xy 
-rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qID)
+        dp = argV wp
-
+        ang = nearZeroAngle (cd - dp)
-leftHandPQ :: Creature -> Point3Q
+        cdp = unitVectorAtAngle cd
-leftHandPQ cr
+        x   | ang > 0 = 0.8 + (0.5 * ang / (pi / 4))
-    | oneH cr = (V3 0 off 10, Q.qz 0.4)
+            | otherwise =  0.8* dotV cdp (signorm wp)
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
+        y   | ang > 0 = 2 + (5 * ang / (pi / 4))
-    | twoFlat cr = (V3 4 8 10, Q.qID)
+            | otherwise = 2
-    | otherwise = case cr ^? crStance . carriage of
+        ep = wp - y *^ signorm wp - x *^ vNormal wp
-        Just (Walking sa RightForward) -> (V3 (- f sa) off 10 , Q.qID)
+    guard $ ang < (pi / 8)
-        Just (Walking sa LeftForward) -> (V3 (- g sa) off 10 , Q.qID)
+    return $ ep & _xy %~ rot
-        _ -> (V3 0 off 10, Q.qID)
   where
-    off = 8
+    cd = cr ^. crDir
-    sLen = _strideLength $ _crStance cr
+    rot = rotateV (negate cd)
-    f i = negate 2 + negate 6 * (sLen - i) / sLen
-    g i = negate 2 + negate 6 * i / sLen
 
-translatePointToLeftHand :: Creature -> Point3 -> Point3
+translateToRightHand :: World -> Creature -> SPic -> SPic
-translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p,Q.qID))
+translateToRightHand w = overPosSP . translatePointToRightHand w
 
-translateToLeftHand :: Creature -> SPic -> SPic
+rightWristPQ :: World -> Creature -> Point3Q
-translateToLeftHand = overPosSP . translatePointToLeftHand
+rightWristPQ w cr = rightHandPQ w cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
 
-leftWristPQ :: Creature -> Point3Q
+leftHandPQ :: World -> Creature -> Point3Q
-leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qID)
+leftHandPQ w cr
+    | twists w cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
+    | twoFlat w cr = (V3 8 8 12, Q.qid)
+    | Just TwoHandTwist <- w ^? hud . manObject . hiAimStance
+        = (V3 (10 + twoHandOffY cr) 6 20, Q.qid)
+    | Just TwoHandFlat <- w ^? hud . manObject . hiAimStance
+        = (V3 (8 + twoHandOffY cr) 6 12, Q.qid)
+    | Just p <- crLeftHandWall cr = (20 & _xy .~ p, Q.qid)
+    | oneH w cr = (V3 0 8 10, Q.qz 0.4)
+    | otherwise = (handWalkingPos RightForward 8 cr, Q.qid)
 
-leftLegPQ :: Creature -> Point3Q
+twoHandOffY :: Creature -> Float
-leftLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
+twoHandOffY cr = zeroOneSmooth $ case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
-    (V3 x off 0,Q.qID)
+    (Just sa,Just ff) ->
-  where
+        let slen = strideLength cr
-    x = case cr ^? crStance . carriage of
+            f i
-        Just (Walking sa LeftForward) -> f sa
+                | ff == RightForward = (slen - i) / slen
-        Just (Walking sa RightForward) -> - f sa
+                | otherwise = i / slen
-        _ -> 0
+         in f sa
-    off = 5
+    _ -> 0
-    sLen = _strideLength $ _crStance cr
+
-    f i = 8 * (sLen - i) / sLen
+translatePointToLeftHand :: World -> Creature -> Point3 -> Point3
-    
+translatePointToLeftHand w cr p = fst (leftHandPQ w cr `Q.comp` (p, Q.qid))
+
+translateToLeftHand :: World -> Creature -> SPic -> SPic
+translateToLeftHand w = overPosSP . translatePointToLeftHand w
+
+leftWristPQ :: World -> Creature -> Point3Q
+leftWristPQ w cr = leftHandPQ w cr `Q.comp` (V3 0 4 (-4), Q.qid)
 
 translateToLeftLeg :: Creature -> SPic -> SPic
-translateToLeftLeg cr = overPosSP (\p -> fst (leftLegPQ cr `Q.comp` (p,Q.qID)))
+translateToLeftLeg cr = overPosSP (\p -> fst (legPQ LeftForward cr `Q.comp` (p, Q.qid)))
 
-rightLegPQ :: Creature -> Point3Q
+legPQ :: FootForward -> Creature -> Point3Q
-rightLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
+legPQ ff = case ff of
-    (V3 x off 0,Q.qID)
+    LeftForward -> legPQ' id
+    RightForward -> legPQ' negate
+
+legPQ' :: (Float -> Float) -> Creature -> Point3Q
+legPQ' g cr =
+    Q.comp
+        (0, Q.qz (_crMvDir cr - _crDir cr))
+        (V3 x (g off) 0, Q.qid)
   where
-    x = case cr ^? crStance . carriage of
+    x = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
-        Just (Walking sa LeftForward) -> -f sa
+        (Just sa,Just LeftForward) -> -f sa
-        Just (Walking sa RightForward) -> f sa
+        (Just sa,Just RightForward) -> f sa
         _ -> 0
     off = -5
-    sLen = _strideLength $ _crStance cr
+    sLen = strideLength cr
-    f i = 8 * (sLen - i) / sLen
+    f i = g 8 * (sLen - i) / sLen
 
 translateToRightLeg :: Creature -> SPic -> SPic
-translateToRightLeg cr = overPosSP (\p -> fst (rightLegPQ cr `Q.comp` (p,Q.qID)))
+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)
+    | otherwise = (V3 2.5 0 20, Q.qid)
 
---translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
+chestPQ :: World -> Creature -> Point3Q
---translatePointToHead m cr p = fst (headPQ cr `Q.comp` (p,Q.qID))
+chestPQ w cr = backPQ w cr `Q.comp` (0, Q.qz pi)
 
-chestPQ :: Creature -> Point3Q
+backPQ :: World -> Creature -> Point3Q
-chestPQ cr = backPQ cr `Q.comp` (0,Q.qz pi)
+backPQ w cr
-
+    | oneH w cr = (V3 0 0 10, Q.qz 0.5)
-backPQ :: Creature -> Point3Q
+    | twists w cr = (V3 0 3 10, Q.qz (-1.5))
-backPQ cr
-    | oneH cr = (V3 0 0 10, Q.qz 0.5)
-    | twists cr = (V3 0 3 10, Q.qz (-1.5))
     | otherwise = (V3 0 0 10, Q.qz 0)

src/Dodge/Creature/Impulse.hs

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

src/Dodge/Creature/Impulse/Movement.hs

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

src/Dodge/Creature/Impulse/UseItem.hs

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

src/Dodge/Creature/LtAutoCrit.hs

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

src/Dodge/Creature/Mass.hs

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

src/Dodge/Creature/Material.hs

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

src/Dodge/Creature/MaxHP.hs

@@ -6,10 +6,14 @@ import Dodge.Data.Creature.Misc
 crMaxHP :: CreatureType -> Int
 crMaxHP = \case
     Avatar {} -> 15000
-    AvatarDead -> 0
     ChaseCrit {} -> 150
+    CrabCrit {} -> 350
+    HoverCrit {} -> 100
     SwarmCrit -> 50
     AutoCrit -> 100
     BarrelCrit{} -> 100
     LampCrit {} -> 50
-
+    SlinkCrit {} -> 1000
+    SlimeCrit {} -> 1000
+    BeeCrit {} -> 100
+    HiveCrit {} -> 10000

src/Dodge/Creature/MoveType.hs

@@ -2,31 +2,40 @@ module Dodge.Creature.MoveType (crMvType) where
 
 import Dodge.Data.FloatFunction
 import Dodge.Data.Creature
+import Control.Lens
 
 crMvType :: Creature -> CrMvType
 crMvType cr = case _crType cr of
-    Avatar {_avMoveSpeed = s} -> MvWalking s
+    Avatar {} -> MvWalking 1.5
-    AvatarDead -> defaultAimMvType
+    SlinkCrit {} -> NoMvType
-    ChaseCrit {} -> defaultChaseMvType
+    ChaseCrit {} -> defaultChaseMvType & mvSpeed .~ 1.8
+    CrabCrit {} -> defaultChaseMvType & mvSpeed .~ 0.5
+        & mvTurnJit .~ 0.01
+    HoverCrit {} -> defaultChaseMvType & mvSpeed .~ 0.16
     SwarmCrit -> defaultChaseMvType
     AutoCrit -> defaultAimMvType
     BarrelCrit {} -> defaultAimMvType
     LampCrit {} -> defaultAimMvType
+    SlimeCrit {} -> NoMvType
+    BeeCrit {} -> BeeMvType 0.2 0.1 15
+    --BeeCrit {} -> BeeMvType 0.2 0.1 25
+    HiveCrit{} -> NoMvType
 
 defaultAimMvType :: CrMvType
 defaultAimMvType =
-    CrMvType
+    JitMvType
         { _mvSpeed = 3
         , _mvTurnRad = FloatConst 0.2
         , _mvTurnJit = 0.05
-        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
+--        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
         }
 
 defaultChaseMvType :: CrMvType
 defaultChaseMvType =
-    CrMvType
+    JitMvType
         { _mvSpeed = 2
         , _mvTurnRad = FloatAbsCheckGreaterLess (pi / 4) 0.2 0.05
-        , _mvTurnJit = 0.2
+        --, _mvTurnJit = 0.3
-        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
+        , _mvTurnJit = 0.05
+--        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
         }

src/Dodge/Creature/Perception.hs

@@ -1,17 +1,17 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Creature.Perception (
     perceptionUpdate,
-    chaseCritPerceptionUpdate,
     visionCheck,
 ) where
 
+import Dodge.SoundLogic.ExternallyGeneratedSounds
+import Dodge.Creature.Vocalization
 import Control.Lens
 import Control.Monad
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.Base.Collide
 import Dodge.Creature.Radius
-import Dodge.Creature.Vocalization
 import Dodge.Data.World
 import Dodge.FloatFunction
 import Geometry.Data
@@ -21,23 +21,15 @@ import Linear
 import RandomHelp
 import Sound.Data
 
-perceptionUpdate ::
+-- | The [Int] is a list of creature ids that may direct attention and awareness
-    -- | List of creature ids that may direct attention and awareness
+perceptionUpdate :: [Int] -> World -> Creature -> Creature
-    [Int] ->
+perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate w . basicAttentionUpdate is w
-    World ->
-    Creature ->
-    Creature
-perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate . basicAttentionUpdate is w
-
-chaseCritPerceptionUpdate :: [Int] -> World -> Creature -> Creature
-chaseCritPerceptionUpdate is w =
-    rememberSounds w . chaseCritAwarenessUpdate w . basicAttentionUpdate is w
 
 {- | Update a creatures awareness based upon the creatures' current direction
  of attention
 -} -- TODO delete?
-basicAwarenessUpdate :: Creature -> Creature
+basicAwarenessUpdate :: World -> Creature -> Creature
-basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
+basicAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
     Fixated i ->
         cr & crPerception . cpAwareness
             %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
@@ -45,7 +37,7 @@ basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
         cr
             & crPerception . cpAwareness
                 %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
-            & maybeBark
+            & maybeBecomeCognizant
       where
         oldAwareness = _cpAwareness $ _crPerception cr
         newAwareness =
@@ -53,50 +45,68 @@ basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
                 oldAwareness
         becomesCognizant =
             any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness
-        thejitter = [RandomImpulse $ RandImpulseCircMove 1]
+        maybeBecomeCognizant = fromMaybe id $ do
-        maybeBark = fromMaybe id $ do
             guard becomesCognizant
-            sid <- vocalizationTest cr
+--            guard $ cr ^. crVocalization == VocReady
             return $
-                crActionPlan . apAction
+                (crActionPlan . apStrategy .~ WarningCry) . 
-                    .~ [ImpulsesList ([Bark sid] : replicate 5 thejitter)]
+                (crActionPlan . apAction
+                    .~ ImpulsesList (crImpulsesOnCognizant w cr)
+                        (AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy))
+                )
+
+crImpulsesOnCognizant :: World -> Creature -> [[Impulse]]
+crImpulsesOnCognizant w cr = case cr ^. crType of
+    ChaseCrit {} | Just sid <- cognizantVoc w cr -> [Bark sid]: replicate 5 [RandomImpulse $ RandImpulseCircMove 3] 
+        <> [[ChangeStrategy $ CloseToMelee 0]]
+    HoverCrit {} | Just sid <- cognizantVoc w cr -> [Bark sid]:
+          [[ChangeStrategy $ CloseToMelee 0]]
+    CrabCrit {} -> [[ChangeStrategy $ CloseToMelee 0]]
+    _ | Just sid <- cognizantVoc w cr -> [Bark sid]: replicate 5 [RandomImpulse $ RandImpulseCircMove 1]
+    _ -> replicate 5 [RandomImpulse $ RandImpulseCircMove 3]
+
+cognizantVoc :: World -> Creature -> Maybe SoundID
+cognizantVoc w cr = case cr ^. crType of
+    ChaseCrit {} -> Just (evalState (takeOne (crWarningSounds cr)) (_randGen w))
+    HoverCrit {} -> Just beep3QuickS
+    _ -> Nothing
 
 -- TODO fold in randgen update, requires that this is a world to world function
-chaseCritAwarenessUpdate :: World -> Creature -> Creature
+--chaseCritAwarenessUpdate :: World -> Creature -> Creature
-chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
+--chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
-    Fixated i ->
+--    Fixated i ->
-        cr & crPerception . cpAwareness
+--        cr & crPerception . cpAwareness
-            %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
+--            %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
-    AttentiveTo is ->
+--    AttentiveTo is ->
-        cr
+--        cr
-            & crPerception . cpAwareness
+--            & crPerception . cpAwareness
-                %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
+--                %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
-            & maybeBark
+--            & maybeBark
-      where
+--      where
-        oldAwareness = _cpAwareness $ _crPerception cr
+--        oldAwareness = _cpAwareness $ _crPerception cr
-        newAwareness =
+--        newAwareness =
-            (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
+--            (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
-                oldAwareness
+--                oldAwareness
-        becomesCognizant =
+--        becomesCognizant =
-            any isCognizant $
+--            any isCognizant $
-                IM.unionWith cogRaised oldAwareness newAwareness
+--                IM.unionWith cogRaised oldAwareness newAwareness
-        thejitter = [RandomImpulse $ RandImpulseCircMove 3]
+--        thejitter = [RandomImpulse $ RandImpulseCircMove 3]
-        maybeBark = fromMaybe id $ do
+--        maybeBark = fromMaybe id $ do
-            guard becomesCognizant
+--            guard becomesCognizant
-            guard $ cr ^? crVocalization . vcCoolDown == Just 0
+--            guard $ cr ^. crVocalization == VocReady
-            let soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
+--            let soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
-                numjits = fst $ randomR (15, 25) (_randGen w)
+--                numjits = fst $ randomR (15, 25) (_randGen w)
-            return $
+--            return $
-                (crActionPlan . apStrategy .~ WarningCry)
+--                (crActionPlan . apStrategy .~ WarningCry)
-                    . ( crActionPlan . apAction
+--                    . ( crActionPlan . apAction
-                            .~ [ ImpulsesList
+--                            .~ [ ImpulsesList
-                                    ( [Bark soundid] :
+--                                    ( [Bark soundid] :
-                                      replicate numjits thejitter
+--                                      replicate numjits thejitter
-                                        ++ [[ChangeStrategy $ CloseToMelee 0]]
+--                                        ++ [[ChangeStrategy $ CloseToMelee 0]]
-                                    )
+--                                    )
-                               , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy)
+--                               , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy)
-                               ]
+--                               ]
-                      )
+--                      )
 
 cogRaised :: Awareness -> Awareness -> Awareness
 cogRaised Suspicious{} Cognizant{} = Cognizant 100
@@ -122,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

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

src/Dodge/Creature/Radius.hs

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

src/Dodge/Creature/ReaderUpdate.hs

@@ -1,18 +1,20 @@
+{-# LANGUAGE LambdaCase #-}
 module Dodge.Creature.ReaderUpdate (
-    doStrategyActions,
-    setTargetMv,
     targetYouWhenCognizant,
     overrideMeleeCloseTarget,
     watchUpdateStrat,
     overrideInternal,
     searchIfDamaged,
-    goToTarget,
+--    goToTarget,
     flockACC,
     chaseCritMv,
-    setMvPos,
+    crabActionUpdate,
+    setMvPosToTargetCr,
     setViewPos,
+    hoverCritMv,
 ) where
 
+import Dodge.WorldEvent.ThingsHit
 import Control.Applicative
 import Control.Monad
 import Data.Bifunctor
@@ -22,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
@@ -42,21 +44,20 @@ tryMeleeAttack cr tcr
     | _meleeCooldown (_crType cr) == 0
         && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
         && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
-        && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 =
+        && abs (_crDir cr - argV (tpos - cpos)) < pi / 4 =
         cr & crActionPlan . apAction
-                .~ [ DoImpulses [Melee $ _crID tcr] `DoActionThen`
+                .~ DoImpulses [Melee $ _crID tcr] `DoActionThen`
                         DoReplicate 10 NoAction
-                        `DoActionThen` DoImpulses
+--                        `DoActionThen` DoImpulses
-                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
+--                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
-                   ]
+--            & crActionPlan . apStrategy .~ MeleeStrike
-            & crActionPlan . apStrategy .~ MeleeStrike
     | otherwise = cr
   where
     cpos = cr ^. crPos . _xy
     tpos = tcr ^. crPos . _xy
 
-setMvPos :: World -> Creature -> Creature
+setMvPosToTargetCr :: World -> Creature -> Creature
-setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
+setMvPosToTargetCr w cr = cr & crIntention . mvToPoint .~ mpos
   where
     int = _crIntention cr
     mtpos = do
@@ -80,17 +81,17 @@ attentionViewPoint w cr = do
     guard $ visionCheck cr (tcr ^. crPos . _xy) > 0
     tcr ^? crPos . _xy
 
-setTargetMv ::
+--setTargetMv ::
-    -- | Function for determining target
+--    -- | Function for determining target
-    (World -> Creature -> Maybe Creature) ->
+--    (World -> Creature -> Maybe Creature) ->
-    World ->
+--    World ->
-    Creature ->
+--    Creature ->
-    Creature
+--    Creature
-setTargetMv targFunc w cr =
+--setTargetMv targFunc w cr =
-    maybe
+--    maybe
-        cr
+--        cr
-        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
+--        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
-        (targFunc w cr)
+--        (targFunc w cr)
 
 -- ugly
 flockACC :: World -> Creature -> Creature
@@ -106,6 +107,7 @@ flockACC w cr = fromMaybe cr $ do
         macr =
             safeMinimumOn (dist cpos . (^. crPos . _xy))
                 . filter isFarACC
+                . IM.elems
                 $ crsNearCirc cpos 50 w
     return $ case macr of
             Nothing -> cr
@@ -118,64 +120,153 @@ flockACC w cr = fromMaybe cr $ do
                             else negate r *.* horDir
                  in cr & crIntention . mvToPoint ?~ tpos +.+ horShift
 
+crabActionUpdate :: Int -> World -> World
+crabActionUpdate cid w = case _apStrategy (_crActionPlan cr) of
+    _ | Just tid <- meleel -> w & tocr . crActionPlan . apAction 
+                .~ DoImpulses [MeleeL tid] `DoActionThen`
+                        DoReplicate 10 NoAction
+    _ | Just tid <- meleer -> w & tocr . crActionPlan . apAction 
+                .~ DoImpulses [MeleeR tid] `DoActionThen`
+                        DoReplicate 10 NoAction
+    WarningCry -> w
+    CloseToMelee tid | aimi tid -> w & tocr . crActionPlan . apAction .~ EvadeAim
+        & tocr . crType . dodgeCooldown .~ dc
+        & randGen .~ g
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> w
+    Wander | Just tid <- cr ^? crIntention . targetCr . _Just
+        , canSee tid (cr ^. crID) w -> w & tocr . crActionPlan . apStrategy .~ CloseToMelee tid
+    _ -> case cr ^? crIntention . mvToPoint . _Just of
+        Just p
+            | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
+                w & tocr . crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
+            | otherwise ->
+                w -- & tocr . crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & tocr . crActionPlan . apStrategy .~ Search
+                    & tocr . crIntention . mvToPoint .~ Nothing
+        _ -> w & tocr %~ viewTarget w
+  where
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    tocr = cWorld . lWorld . creatures . ix cid
+    meleel = do
+        tid <- cr ^? crIntention . targetCr . _Just
+        tcr <- w ^? cWorld . lWorld . creatures . ix tid
+        let cpos = cr ^. crPos . _xy
+            tpos = tcr ^. crPos . _xy
+        guard $ _meleeCooldownL (_crType cr) == 0
+            && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
+            && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
+            && (_crDir cr - argV (tpos -.- cpos)) > (-pi / 4)
+            && (_crDir cr - argV (tpos -.- cpos)) <= 0
+            && cr ^?! crType . meleeCooldownR < 15
+        return tid
+    meleer = do
+        tid <- cr ^? crIntention . targetCr . _Just
+        tcr <- w ^? cWorld . lWorld . creatures . ix tid
+        let cpos = cr ^. crPos . _xy
+            tpos = tcr ^. crPos . _xy
+        guard $ _meleeCooldownR (_crType cr) == 0
+            && Just (_crID tcr) == cr ^? crActionPlan . apStrategy . meleeTarget
+            && dist tpos cpos < crRad (cr ^. crType) + crRad (tcr ^. crType) + 5
+            && (_crDir cr - argV (tpos -.- cpos)) < pi / 4
+            && (_crDir cr - argV (tpos -.- cpos)) >= 0
+            && cr ^?! crType . meleeCooldownL < 15
+        return tid
+    (dc,g) = randomR (15,50) (w ^. randGen)
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
+    aimi tid = fromMaybe False $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix tid
+        hp <- cr ^? crHP . _HP
+        Aiming <- tcr ^? crStance . posture
+        let txy = tcr ^. crPos . _xy
+            cxy = cr ^. crPos . _xy
+        0 <- cr ^? crType . dodgeCooldown
+        return $ hasLOS cxy txy w
+            && abs (nearZeroAngle (tcr^.crDir - argV (cxy - txy))) < 0.3
+            && isWalkable txy cxy w  
+            && diffAngles (cr ^. crDir) (argV (txy - cxy)) < 0.1
+            && hp > 0
+
 chaseCritMv :: World -> Creature -> Creature
 chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of
     WarningCry -> cr
-    MeleeStrike -> cr
     CloseToMelee cid
-        | Just 0 == (cr ^? crVocalization . vcCoolDown) ->
+        | VocReady == (cr ^. crVocalization) ->
             cr
                 & crActionPlan . apAction
-                    .:~ ImpulsesList
+                    .~ ImpulsesList
                         ( [Bark soundid] :
                           replicate numjits [RandomImpulse thejitter]
                             ++ [[ChangeStrategy (CloseToMelee cid)]]
-                        )
+                        ) NoAction
-                & crVocalization . vcCoolDown .~ 10
+                & resetCrVocCoolDown w
                 & crActionPlan . apStrategy .~ WarningCry
       where
         thejitter = RandImpulseCircMove 3
         soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
         numjits = fst $ randomR (15, 25) (_randGen w)
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
     _ -> case cr ^? crIntention . mvToPoint . _Just of
         Just p
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
-                cr & crActionPlan . apAction .~ [PathTo p]
+                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
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
 
-goToTarget :: World -> Creature -> Creature
+hoverCritMv :: World -> Creature -> Creature
-goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
+hoverCritMv w cr = case _apStrategy (_crActionPlan cr) of
-    Just p -> cr & crActionPlan . apAction .~ [PathTo p]
+    WarningCry -> cr
-    _ -> viewTarget w cr
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
+    _ -> case cr ^? crIntention . mvToPoint . _Just of
+        Just p
+            | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
+                cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
+            | otherwise ->
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & crActionPlan . apStrategy .~ Search
+                    & crIntention . mvToPoint .~ Nothing
+        _ -> viewTarget w cr
+  where
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
+
+--goToTarget :: World -> Creature -> Creature
+--goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
+--    Just p -> cr & crActionPlan . apAction .~ [PathTo p]
+--    _ -> viewTarget w cr
 
 viewTarget :: World -> Creature -> Creature
 viewTarget w cr = case cr ^? crIntention . viewPoint . _Just of
     Just p
         | hasLOSIndirect p (cr ^. crPos . _xy) w ->
             cr
-                & crActionPlan . apAction .~ [TurnToPoint p]
+                & crActionPlan . apAction .~ TurnToPoint p
                 & crIntention . viewPoint .~ Nothing
                 & crActionPlan . apStrategy .~ Investigate
         | otherwise ->
-            cr & crActionPlan . apAction %~ replaceNullWith (PathTo p)
+--            cr & crActionPlan . apAction %~ replaceNullWith (PathTo p (DoImpulses [ChangeStrategy Wander]))
+            cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
                 & crActionPlan . apStrategy .~ Investigate
     Nothing -> cr
 
-replaceNullWith :: a -> [a] -> [a]
+--replaceNullWith :: a -> [a] -> [a]
-replaceNullWith x [] = [x]
+--replaceNullWith x [] = [x]
-replaceNullWith _ xs = xs
+--replaceNullWith _ xs = xs
-
-doStrategyActions :: Creature -> Creature
-doStrategyActions cr = case cr ^? crActionPlan . apStrategy of
-    Just (StrategyActions strat acs) ->
-        cr
-            & crActionPlan . apAction .~ acs
-            & crActionPlan . apStrategy .~ strat
-    _ -> cr
 
 overrideInternal :: (Creature -> Bool) -> (Creature -> Creature) -> Creature -> Creature
 overrideInternal test update cr
@@ -215,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/SentinelAI.hs

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

src/Dodge/Creature/Shape.hs

@@ -7,10 +7,15 @@ import Dodge.Data.Creature.Misc
 
 crShape :: CreatureType -> CreatureShape
 crShape = \case
-    Avatar{} -> Humanoid (greyN 0.9) (lightx4 black) (greyN 0.3) InanimateAI
+    Avatar{} -> Humanoid (greyN 0.9) (lightx4 black) (greyN 0.3)
-    ChaseCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3) ChaseAI
+    ChaseCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
-    SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3) SwarmAI
+    CrabCrit {} -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
-    AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3) AutoAI
+    HoverCrit {} -> Humanoid (greyN 0.9) (light blue) (greyN 0.3)
-    AvatarDead -> Humanoid (greyN 0.9) (lightx4 black) (greyN 0.3) InanimateAI
+    SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3)
+    AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
+    SlinkCrit{} -> Humanoid (greyN 0.9) (dark . dark . dark $ orange) (greyN 0.3)
     BarrelCrit {} -> Barreloid
-    LampCrit {} -> NonDrawnCreature
+    LampCrit {} -> NoCreatureShape
+    SlimeCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
+    BeeCrit {} -> NoCreatureShape
+    HiveCrit {} -> NoCreatureShape

src/Dodge/Creature/Slime.hs

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

src/Dodge/Creature/State.hs

@@ -4,6 +4,9 @@ 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
 import Control.Applicative
@@ -35,7 +38,6 @@ import Dodge.Zoning.Creature
 import FoldableHelp
 import Geometry
 import LensHelp
-import Picture
 import qualified Quaternion as Q
 import RandomHelp
 import qualified SDL
@@ -43,11 +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 {} -> hoverPainEffect cr
+    HiveCrit{} -> hivePainEffect cr
+    _ -> jitterPain cr
+
+
+hoverPainEffect :: Creature -> World -> World
+hoverPainEffect cr
+    | _crPain cr > 50 =
+                (cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50)
+                . (cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1)
+    | otherwise = id
+
+
+hivePainEffect :: Creature -> World -> World
+hivePainEffect cr w
+    | _crPain cr > 0 = w & cWorld . lWorld . creatures . ix (cr ^. crID) . crPain %~ (max 0 . subtract 5)
+        & cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos & _xy +~ p & _z .~ 20) v 200
+        & randGen .~ g
+    | otherwise = w
+  where
+    (a,g') = randomR (0,2*pi) $ w ^. randGen
+    (b,g) = runState randOnUnitSphere g'
+    p = (crRad (cr ^. crType) + 5) *^ unitVectorAtAngle a
+    v = 3 *^ b
+
+jitterPain :: Creature -> World -> World
+jitterPain cr w
     | _crPain cr > 200 = dojitter 3 100
     | _crPain cr > 20 = dojitter 2 10
     | _crPain cr > 0 = dojitter 1 1
@@ -55,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) %~ crMvBy 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
 
@@ -78,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
@@ -133,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
@@ -207,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
@@ -218,41 +251,41 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
                     { _lpPhaseV = 1
                     , _lpDir = _crDir cr + argV (Q.qToV2 q)
                     , _lpPos = pos
-                    , _lpColor = col
+--                    , _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)
+    (p, q) = o `Q.comp` (V3 5 0 0, Q.qid)
     x = 1
     isammolink AmmoMagSF{} = True
     isammolink _ = False
-    pos = cr ^. crPos . _xy + xyV3 (rotate3 cdir p)
+    pos = cr ^. crPos . _xy + xyV3 (rotate3z cdir p)
     cdir = _crDir cr
     itm = itmtree ^. dtValue . _1
     pointittarg = cWorld . lWorld . items . ix itid . itTargeting
     itid = itm ^. itID . unNInt
-    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
 
 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
-    pos = _crPos cr + rotate3 cdir (p + Q.rotate q (V3 5 0 1.5))
+    pos = _crPos cr + rotate3z cdir (p + Q.rotate q (V3 5 0 1.5))
     cdir = _crDir cr
 
 -- this probably needs to be set to null when dropped as well?
@@ -284,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
@@ -298,6 +334,7 @@ setRBCreatureTargeting cr w ituse
     newtarg =
         safeMinimumOn (dist mwp . (^. crPos . _xy))
             . filter (canseepos . (^. crPos . _xy))
+            . IM.elems
             $ crsNearCirc mwp 40 w
     canseepos p = hasLOS ((^. crPos . _xy) cr) p w
     mwp = w ^. cWorld . lWorld . lAimPos

src/Dodge/Creature/State/WalkCycle.hs

@@ -1,31 +1,174 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Creature.State.WalkCycle (updateWalkCycle) where
+module Dodge.Creature.State.WalkCycle (updateCarriage
+    ,compressionScale
+    , flyInertia
+    ) where
 
+import qualified Quaternion as Q
+import Dodge.Creature.Radius
+import Geometry
+import Dodge.Update.Camera.Rotate
+import qualified SDL
+import Dodge.WorldEvent.ThingsHit
+import Data.Maybe
+import Dodge.Creature.HandPos
 import Linear
 import Control.Lens
 import Dodge.Data.World
 import Dodge.SoundLogic
 import Sound.Data
 
-updateWalkCycle :: Int -> World -> World
+updateCarriage :: Int -> World -> World
-updateWalkCycle cid w
+updateCarriage cid w = fromMaybe w $ do
-    | Just cr <- w ^? cWorld . lWorld . creatures . ix cid
+    cr <- w ^? cWorld . lWorld . creatures . ix cid
-      , Walking x ff <- cr ^. crStance . carriage
+    return $ updateCarriage' cid cr w (cr ^. crStance . carriage)
-      , x >= cr ^. crStance . strideLength =
-        w
-            & soundMultiFrom
-                [FootstepSound i | i <- [0 .. 10]]
-                (cr ^. crPos . _xy)
-                (chooseFootSound ff)
-                Nothing
-            & over (cWorld . lWorld . creatures . ix cid . crStance . carriage) resetStride
-    | otherwise = w
 
-resetStride :: Carriage -> Carriage
+updateCarriage' :: Int -> Creature -> World -> Carriage -> World
-resetStride = \case
+updateCarriage' cid cr w = \case
-    Walking _ ff -> Walking 0 (normalGait ff)
+    Walking -> maybeTakeStep cid cr w 
-    x -> x
+        & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
+        & chasmTestCliffPush walkCliffPush cr
+    Crawling -> w & chasmTestCliffPush walkCliffPush cr
+    Floating -> w
+    Flying {_zSpeed = dz} -> let x = flyInertia cr
+        in
+          w & tocr . crPos . _xy +~ x *^ f (cr ^. crOldPos . _xy - oop ^. _xy)
+            & tocr . crPos . _z +~ dz
+            & tocr . crStance . carriage . zSpeed 
+                %~ if cr ^. crPos . _z < 17 then min 0.05 . (+0.001) else max (-0.05) . subtract 0.001
+    Boosting {} -> w
+    Falling {_fallRot = q, _carDir = q'} -> 
+        let v = 0.95 *^ (cr ^. crOldPos - oop & _z -~ 0.5)
+            ep = cr ^. crPos + v
+        in if ep ^. _z < 0 && cr ^. crOldPos . _z >= 0 &&
+                (not (any (pointInPoly (ep ^. _xy)) (w ^. cWorld . chasms))
+                    || any (uncurry $ crOnSeg cr) (w ^. cWorld . cliffs))
+            then w & tocr . crPos .~ (ep & _z .~ 0)
+                    & cWorld . lWorld . creatures . ix cid . crStance . carriage .~ OnGround q'
+            else w & cWorld . lWorld . creatures . ix cid . crPos .~ ep
+                    & cWorld . lWorld . creatures . ix cid . crStance . carriage . carDir *~ q
+                        
+    OnGround {} -> w
+        & tocr . crPos . _xy +~ 0.8 *^ (cr ^. crOldPos . _xy - oop ^. _xy)
+        & chasmTestCliffPush groundCliffPush cr
+    Rooted {} -> w
+    Mounted mid p -> fromMaybe w $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        mp <- mcr ^? crPos
+        d <- mcr ^? crType . slimeCompression
+        return $ w & tocr . crPos .~ mp + (oxyrot (mcr ^. crDir) 
+            (oxyrot (-mcr^.crDir) p & _x *~ d & _y %~ (/d)))
+  where
+    oxyrot a = over _xy (rotateV a)
+    tocr = cWorld . lWorld . creatures . ix cid
+    oop = cr ^. crOldOldPos
+    f v | norm v > 10 = 10 *^ signorm v
+        | otherwise = v
+
+compressionScale :: Point2 -> Point2 -> Point2
+compressionScale d p = dot d p *^ normalize d
+    + (dot d' p / norm d) *^ d'
+  where
+    d' = vNormal $ normalize d
+
+flyInertia :: Creature -> Float
+flyInertia _ = 0.975
+
+pushAgainst :: Point2 -> Point2 -> Point2
+pushAgainst x y
+    | a > norm y = 0
+    | a > 0 = y - project y x
+    | otherwise = y
+  where
+    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 (min 10 (cr ^. crType . to crRad))
+
+groundCliffPush :: Creature -> [(Point2,Point2)] -> Point2
+groundCliffPush cr xs = x *^ circSegsInside cxy r xs
+  where
+    -- at least 0.01 so that corpses don't hang on the edge of a cliff too long
+    x = max 0.01 $ 0.25 * (1 - dist cxy p / (2*r)) ** 2
+    cxy = cr ^. crPos . _xy
+    r = cr ^. crType . to crRad
+    p = circSegsInside' cxy r xs
+
+circSegsInside' :: Point2 -> Float -> [(Point2,Point2)] -> Point2
+circSegsInside' p r = \case
+    [x,y] -> fromJust (uncurry (uncurry intersectLineLine (f x)) (f y))
+    ((x,y):_) -> closestPointOnLine x y p + r *^ normalizeV (vNormal (x-y))
+    _ -> error "circSegsInside"
+  where
+    r' = r+0.5
+    f (x,y) = (x+r'*^n,y+r'*^n)
+      where
+        n = normalizeV (vNormal (x-y))
+
+circSegsInside :: Point2 -> Float -> [(Point2,Point2)] -> Point2
+circSegsInside p r = \case
+    [x,y] -> normalize $ fromJust (uncurry (uncurry intersectLineLine (f x)) (f y)) - p
+    ((x,y):_) -> normalizeV (vNormal (x-y))
+    _ -> error "circSegsInside"
+  where
+    r' = r+0.5
+    f (x,y) = (x+r'*^n,y+r'*^n)
+      where
+        n = normalizeV (vNormal (x-y))
+
+--circTwoLineCorner :: Float -> Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
+--circTwoLineCorner r x y a b = intersectLineLine x y a b
+
+chasmTestCliffPush :: (Creature -> [(Point2,Point2)] -> Point2) -> Creature -> World -> World
+chasmTestCliffPush f' cr w
+    | (xy:xys) <- filter g (w ^. cWorld . cliffs) =
+        w
+            & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
+            & tocr . crPos . _xy +~ f' cr (xy:xys) -- (f cr (xy:xys)) *^ h xy xys
+            & chasmRotate cr (uncurry (-) xy)
+    | any f (w ^. cWorld . chasms) = w & tocr . crStance . carriage 
+        .~ Falling 
+            (Q.axisAngle (0 & _xy .~ vNormal (cr^.crOldOldPos._xy - cr^.crOldPos._xy)) 0.03) 
+            Q.qid
+    | otherwise = w
+  where
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix (_crID cr)
+    --g = uncurry $ crOnSeg cr
+    g = uncurry $ crOnSeg' cr
+    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
+    | otherwise = w
+  where
+    t = cr ^. crID == 0 && null (w ^? input . mouseButtons . ix SDL.ButtonRight)
+
+maybeTakeStep :: Int -> Creature -> World -> World
+maybeTakeStep cid cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    (Just x,Just ff) | x >= strideLength cr ->
+        soundMultiFrom
+            [FootstepSound i | i <- [0 .. 10]]
+            (cr ^. crPos . _xy)
+            (chooseFootSound ff)
+            Nothing
+        . over (cWorld . lWorld . creatures . ix cid . crType) resetStride
+    _ -> id
+
+
+resetStride :: CreatureType -> CreatureType
+resetStride ct = case ct ^? footForward of
+    Just _ -> ct & strideAmount .~ 0 & footForward %~ normalGait
+    _ -> ct
 
 normalGait :: FootForward -> FootForward
 normalGait = \case

src/Dodge/Creature/Statistics.hs

@@ -3,13 +3,13 @@ module Dodge.Creature.Statistics (
     getCrMoveSpeed,
     crStrength,
     crDexterity,
-    crIntelligence,
+--    crIntelligence,
 ) where
 
+import Dodge.Data.World
 import Dodge.Data.Equipment.Misc
 import qualified Data.Map.Strict as M
 import NewInt
-import Dodge.Data.LWorld
 import Data.Maybe
 --import qualified IntMapHelp as IM
 import qualified Data.IntMap.Strict as IM
@@ -19,36 +19,42 @@ import qualified Data.IntSet as IS
 crDexterity :: Creature -> Int
 crDexterity cr = case cr ^. crType of
     Avatar { _avDexterity = x } -> x
-    AvatarDead -> 0
     ChaseCrit {} -> 46
+    HoverCrit {} -> 46
     SwarmCrit -> 46
     AutoCrit -> 46
     BarrelCrit {} -> 0
     LampCrit {} -> 0
+    _ -> 46
 
 crStrength :: Creature -> Int
 crStrength cr = case cr ^. crType of
     Avatar { _avStrength = x } -> x
-    AvatarDead -> 0
     ChaseCrit {} -> 46
+    HoverCrit {} -> 46
     SwarmCrit -> 40
     AutoCrit -> 46
     BarrelCrit {} -> 0
     LampCrit {} -> 0
+    _ -> 46
 
-crIntelligence :: Creature -> Int
+--crIntelligence :: Creature -> Int
-crIntelligence  cr = case cr ^. crType of
+--crIntelligence  cr = case cr ^. crType of
-    Avatar { _avIntelligence = x } -> x
+--    Avatar { _avIntelligence = x } -> x
-    AvatarDead -> 0
+--    ChaseCrit {} -> 20
-    ChaseCrit {} -> 20
+--    CrabCrit {} -> 20
-    SwarmCrit -> 20
+--    HoverCrit {} -> 20
-    AutoCrit -> 20
+--    SwarmCrit -> 20
-    BarrelCrit {} -> 0
+--    AutoCrit -> 20
-    LampCrit {} -> 0
+--    BarrelCrit {} -> 0
+--    LampCrit {} -> 0
+--    SlinkCrit{} -> 5
+--    SlimeCrit{} -> 1
+--    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
@@ -64,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
@@ -106,8 +112,7 @@ heldItemWeight = \case
     FLAMETORRENT -> 10
     FLAMEWALL -> 10
     BLOWTORCH -> 10
-    SPARKGUN -> 15
+    TESLACOIL -> 15
-    TESLAGUN -> 15
     TRACTORGUN -> 10
     RLAUNCHER -> 20
     RLAUNCHERX{} -> 20

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
-                    --     $ DoImpulses [ChangeStrategy WatchAndWait]
-            ]
-    _ -> WatchAndWait
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
-    holsterIfAiming
-        | crIsAiming cr = holsterWeapon
-        | otherwise = NoAction

src/Dodge/Creature/Test.hs

@@ -7,21 +7,19 @@ in fact a creature with that id need not exist.
 -}
 module Dodge.Creature.Test (
     crIsAiming,
---    crIsReloading,
     crIsArmouredFrom,
     oneH,
     twists,
     twoFlat,
---    crWeaponReady,
     crInAimStance,
     crNearPoint,
     isAnimate,
---    crCanShoot,
     crHasTargetLOS,
     crAwayFromPost,
     crHasTarget,
     crStratConMatches,
     crSafeDistFromTarg,
+    hasAutoDoorBody,
 ) where
 
 import Linear
@@ -31,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
@@ -83,30 +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 . aimStance == Just as
+crInAimStance as w cr = cr ^? crStance . posture == Just Aiming
+    && w ^? hud . manObject . hiAimStance == Just as
 
-oneH :: Creature -> Bool
+oneH :: World -> Creature -> Bool
 oneH = crInAimStance OneHand
 
-twoFlat :: Creature -> Bool
+twoFlat :: World -> Creature -> Bool
 twoFlat = crInAimStance TwoHandFlat
 
-twists :: Creature -> Bool
+twists :: World -> Creature -> Bool
-twists cr = crInAimStance TwoHandUnder cr || crInAimStance TwoHandOver cr
+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 $
@@ -117,9 +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 TwoHandUnder cr = negate 1
+        | crInAimStance TwoHandTwist w cr = negate 1
-        | crInAimStance TwoHandOver cr = negate 1
         | otherwise = 0
 
 --crOnSeg :: Point2 -> Point2 -> Creature -> Bool
@@ -135,4 +129,19 @@ isAnimate :: Creature -> Bool
 {-# INLINE isAnimate #-}
 isAnimate cr = case _crActionPlan cr of
     Inanimate -> False
-    _ -> True
+    SlimeIntelligence -> True
+    ActionPlan{} -> True
+
+hasAutoDoorBody :: Creature -> Bool
+hasAutoDoorBody cr = crittype && notdestroyed
+  where
+    notdestroyed = case cr ^. crHP of
+        HP {} -> True
+        CrIsCorpse {} -> True
+        AvatarDestroyed {} -> False
+    crittype = case cr ^. crType of
+        SlimeCrit {} -> False
+        BeeCrit {} -> False
+        HiveCrit {} -> False
+        _ -> True
+    

src/Dodge/Creature/Update.hs

@@ -1,14 +1,28 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Dodge.Creature.Update (updateCreature) where
 
+import qualified Data.Semigroup as Semi
+import Dodge.WorldEvent.ThingsHit
+import Dodge.Humanoid
+import Dodge.Creature.Perception
+import Dodge.Creature.ReaderUpdate
+import Dodge.Creature.Slime
+import Dodge.Creature.Radius
+import Dodge.Creature.MoveType
+import Dodge.Base.Collide
+import Data.List (sortOn)
+import Dodge.Zoning.Creature
+import Dodge.Creature.ChaseCrit
+import Dodge.Creature.Damage
 import Color
-import qualified Data.IntMap.Strict as IM
+import Control.Monad
-import qualified Data.List as List
+import qualified IntMapHelp as IM
 import Data.Maybe
 import Dodge.Barreloid
--- import Dodge.Base.NewID
+import Dodge.Base.You
-import Dodge.Corpse.Make
 import Dodge.Creature.Action
-import Dodge.Creature.Radius
+import Dodge.Creature.Picture
 import Dodge.Creature.State
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Vocalization
@@ -16,51 +30,489 @@ 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
 import Dodge.SoundLogic
-import Dodge.Update.Camera.Rotate
 import FoldableHelp
 import Geometry
 import LensHelp
 import Linear
 import NewInt
+import qualified Quaternion as Q
 import RandomHelp
-import SDL (MouseButton (..))
 import Shape
 import ShapePicture.Data
+import qualified Data.IntSet as IS
 
 -- Should separate out creature movement from other parts here
 -- allow for knockbacks etc to be determined as well as intended movements
 updateCreature :: Creature -> World -> World
 updateCreature cr
-    | cr ^. crPos . _z < negate 100 = (tocr . crHP .~ CrIsPitted) . destroyAllInvItems cr
+    | cr ^. crPos . _z < negate 300 = (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature) 
-    | CrIsCorpse _ <- cr ^. crHP = chasmTestCorpse cr
+        . destroyAllInvItems cr
-    | null (cr ^? crHP . _HP) = id
+    | otherwise = case cr ^. crHP of
-    | cr ^. crPos . _z < 0 = (tocr . crZVel -~ 0.5) . (tocr . crPos . _z +~ _crZVel cr)
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . applyCreatureDamage (_crID cr) cr
-    | otherwise = updateLivingCreature cr
+        AvatarDestroyed{} -> id
+        HP{} -> cleardamage . updateLivingCreature cr
   where
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
+    cleardamage = cWorld . lWorld . creatures . ix (cr^.crID) . crDamage .~ mempty
 
 updateLivingCreature :: Creature -> World -> World
-updateLivingCreature cr =
+updateLivingCreature cr = case cr ^. crType of
-    chasmTestLiving cr . case _crType cr of
+    Avatar{} ->
-        Avatar{} ->
+        (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
-            (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
+            . crUpdate cid
-                . crUpdate cid
+            . yourControl
-                . yourControl cr
+    LampCrit{} -> updateLampoid cr
-        LampCrit{} -> updateLampoid cr
+    BarrelCrit bt -> updateBarreloid bt cr
-        BarrelCrit bt -> updateBarreloid bt cr
+    ChaseCrit{} -> crUpdate cid . performActions cid . setChaseCritKinematics cid . updateChaseCrit cid cr
-        AvatarDead -> id
+    CrabCrit{} -> crUpdate cid . performActions cid . crabCritInternal cid
-        ChaseCrit{} -> \w ->
+    AutoCrit{} -> crUpdate cid
-            crUpdate cid . performActions cid $
+    SwarmCrit{} -> crUpdate cid
-                over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
+    HoverCrit{} -> crUpdate cid . performActions cid . hoverCritHoverSound cr .
-        _ -> crUpdate cid
+            updateHoverCrit cid
+    SlinkCrit{} -> slinkCritUpdate cid
+    SlimeCrit{} -> updateSlimeCrit cid
+    BeeCrit{} -> crUpdate cid . performActions cid . updateBeeFromPheremones cr cid . updateBeeCrit cr cid
+    HiveCrit{} -> crUpdate cid . performActions cid . updateHiveCrit cr cid
   where
     cid = cr ^. crID
 
+updateHiveCrit :: Creature -> Int -> World -> World
+updateHiveCrit cr cid w
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees
+    , Just y <- cr ^? crType . hiveGestation
+    , y == 0 
+    , Just z <- cr ^? crType . hiveSlime
+    , z >= 400
+        = w 
+        & tocr . crType . hiveChildren %~ IS.insert nid
+        & tocr . crType . hiveGestation .~ 50
+        & cWorld . lWorld . creatures . at nid ?~ ncr
+        & tocr . crType . hiveSlime -~ 400
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees = w
+        & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
+    | otherwise = w
+  where
+    nbees = 15
+    tocr = cWorld . lWorld . creatures . ix cid
+    nid = IM.newKey $ w ^. cWorld . lWorld . creatures
+    ncr = beeCrit & crPos .~ (cr ^. crPos + (0 & _xy +~ 25))
+        & crID .~ nid
+        & crType . beeHive ?~ cid
+
+updateBeeFromPheremones :: Creature -> Int -> World -> World
+updateBeeFromPheremones cr cid w
+    | any f (w ^. cWorld . lWorld . beePheremones) = w 
+        & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
+    | otherwise = w
+  where
+    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos . _xy) < 20
+
+updateBeeCrit :: Creature -> Int -> World -> World
+updateBeeCrit cr cid
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr cid
+    | otherwise = beeLifespanCheck cr cid . updateCalmBee cr cid
+
+beeLifespanCheck :: Creature -> Int -> World -> World
+beeLifespanCheck cr cid
+    | Just ls <- cr ^? crType . beeLifespan
+    , Just x <- cr ^? crType . beeSlime
+    , ls < 1
+    , x < 5
+        = cWorld . lWorld . creatures . ix cid . crHP . _HP -~ 1
+    | otherwise = id
+
+updateAggroBee :: Creature -> Int -> World -> World
+updateAggroBee cr cid w
+    | Mounted{} <- cr ^. crStance . carriage = w & tocr . crStance . carriage .~ Flying 0 
+    | Just tcr <- atarget
+    , distance (tcr ^. crPos . _xy) (cr ^. crPos . _xy) < crRad (cr ^. crType) + crRad (tcr ^. crType) + 1
+    , nearZeroAngle (argV (tcr ^. crPos . _xy - cr ^. crPos . _xy) - cr ^. crDir) < pi / 2
+    , 0 <- cr ^?! crType . meleeCooldown
+        = w & tocr . crPos .~ (cr ^. crOldPos & _xy -~ 5 *^ unitVectorAtAngle (cr ^. crDir))
+            & tocr . crType . startStopMv .~ (cr ^?! to crMvType . mvPulseTime)
+            & cWorld . lWorld . creatures . ix (tcr ^. crID) . crDamage 
+                .:~ Blunt 50 (cxy + crRad (cr ^. crType) *^ vdir) vdir (CrMeleeO (cr ^. crID))
+            & tocr . crType . meleeCooldown .~ 20
+    | Just tcr <- atarget = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
+        & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w & tocr . crType . beeAggro -~ 1
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | otherwise = w & tocr . crType . beeAggro -~ 1
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+        & randGen .~ g 
+  where
+    (p,g) = runState (randOnCirc 150) (w ^. randGen)
+    atarget = listToMaybe . sortOn (distance cxy . (^.crPos._xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w
+    vdir = unitVectorAtAngle (cr ^. crDir)
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = t (tcr ^. crType)
+        && isJust (tcr ^? crHP . _HP)
+        && hasLOS cxy (tcr ^. crPos . _xy) w
+    t = \case
+        Avatar{} -> True
+        ChaseCrit{} -> True
+        CrabCrit{} -> True
+        _ -> False
+
+-- do bees need to be able to see slime targets?
+-- if no path can be made, reset harvest action
+-- this should all be simplified
+-- should count how many are mounted on an individual slime, try for a different
+-- slime if too many
+updateCalmBee :: Creature -> Int -> World -> World
+updateCalmBee cr cid w 
+    | Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just x <- cr ^? crType . beeSlime 
+    , x >= 50 = w 
+        & tocr . crType . beeSlime -~ 50
+        & cWorld . lWorld . creatures . ix (hcr ^. crID) . crType . hiveSlime +~ 50
+    | Just x <- cr ^? crType . beeSlime 
+    , x < 50
+    , Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just ReturnToHive <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just ReturnToHive <- cr ^? crActionPlan . apStrategy = w 
+    | Just x <- cr ^? crType . beeSlime 
+    , x >= 1500 = starthivereturn
+        & randGen .~ gsa
+        & tocr . crType . beeLifespan %~ max 0 . subtract sa
+    | Just mid <- cr ^? crStance . carriage . mountID
+    , mountshakeoff mid = startsearch
+    | Nothing <- cr ^? crActionPlan . apStrategy . harvestTarget 
+    ,  xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g') <- runState (takeOne xs) (w ^. randGen) =
+         w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+            & randGen .~ g'
+    | Just tid <- cr ^? crStance . carriage . mountID
+    , Just SlimeCrit{} <- w ^? cWorld . lWorld . creatures . ix tid . crType = w
+        & tocr . crType . beeSlime +~ sspeed
+        & cWorld . lWorld . creatures . ix tid . crType . slimeSlime -~ sspeed
+    | Just (tcr,ti) <- gettarg
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.8*crRad (tcr ^. crType) 
+    , Just d <- tcr ^? crType . slimeCompression
+        = w
+        & tocr . crStance . carriage .~ Mounted ti 
+            (oxyrot (tcr^.crDir) 
+                (oxyrot (-tcr^.crDir) (cr ^. crPos - tcr ^. crPos) & _x %~ (/d) & _y *~ d))
+        & tocr . crActionPlan . apAction .~ NoAction
+    | Just (tcr,_) <- gettarg = w
+            & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+    | Just (HarvestFrom{}) <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just (SearchTimed 0) <- cr ^? crActionPlan . apStrategy = starthivereturn
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w
+        & tocr . crActionPlan . apStrategy . searchTimer %~ (max 0 . subtract 1)
+    | otherwise = startsearch
+  where
+    oxyrot a = over _xy (rotateV a)
+    (sa,gsa) = runState (takeOne [0,1]) (w ^. randGen)
+    starthivereturn = fromMaybe w $ do
+        hcr <- gethive
+        return $ w
+            & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+            & tocr . crActionPlan . apStrategy .~ ReturnToHive
+            & tocr . crStance . carriage %~ dounmount
+    dounmount x = case x of
+        Flying{} -> x
+        _ -> Flying 0
+    startsearch = w
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crStance . carriage %~ dounmount
+        & randGen .~ g
+        & tocr . crActionPlan . apStrategy .~ SearchTimed 200
+    (p,g) = runState (randOnCirc 200) (w ^. randGen)
+    cxy = cr ^. crPos . _xy
+    mountshakeoff mid = fromMaybe False $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        x <- mcr ^? crType . slimeDistortion . sdTime
+        return $ x > 8
+    sspeed = 5
+    gettarg = do
+        i <- cr ^? crActionPlan . apStrategy . harvestTarget 
+        tcr <-  w ^? cWorld . lWorld . creatures . ix i
+        x <- tcr ^? crType . slimeSlime . to slimeToRad
+        guard $ x > 12
+        return (tcr,i)
+    gethive = do
+        i <- cr ^? crType . beeHive . _Just
+        w ^? cWorld . lWorld . creatures . ix i
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = fromMaybe False $ do
+        r <- tcr ^? crType . slimeSlime . to slimeToRad
+        return $ r > 12
+
+updateSlimeCrit :: Int -> World -> World
+updateSlimeCrit cid w 
+    | cr ^?! crType . slimeSlime < 2500 
+        = w & cWorld . lWorld . creatures . at cid .~ Nothing
+    | Just hitp <- w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmPos
+        , Just hitv <-  w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmVector
+        , Just w' <- splitSlimeCrit' hitp hitv cid cr w = w'
+    | (cr ^?! crType . slimeIsCompressing) && 1 > p
+        = let (w',g) = runState (setSlimeDir cid cr w) (w ^. randGen)
+            in w' & randGen .~ g
+    | otherwise = updateCarriage cid $ w
+        & cWorld . lWorld . creatures . ix cid %~ mvslime
+        & cWorld . lWorld . creatures . ix cid . crDamage .~ []
+        & tocr %~ doSlimeRadChange
+        & tocr . crType . slimeDistortion %~ fsst
+        & tocr . crType . slimeEngulfProgress %~ (max 0 . subtract 0.5)
+  where
+    fsst (SlimeDistortion x ps t) | x > 0 = SlimeDistortion (x-1) ps t
+    fsst _ = NoSlimeDistortion
+    tocr = cWorld . lWorld . creatures . ix cid
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    mvslime cr' = cr' & crType . slimeCompression +~ f (0.1/r)
+        & crPos . _xy +~ 0.1 *^ unitVectorAtAngle (cr' ^. crDir)
+        & crType . slimeIsCompressing %~ f'
+    f | cr ^?! crType . slimeIsCompressing = negate
+      | otherwise = id
+    f'  | p > 1.5 = const True
+        | otherwise = id
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    p = cr ^?! crType . slimeCompression
+
+setSlimeDir :: Int -> Creature -> World -> State StdGen World
+setSlimeDir cid cr w = do
+    i <- state $ randomR (0,1)
+    d <- state $ randomR (0,2*pi)
+    if i < (r - 11) / 50
+        then do
+            x <- randInCirc 1
+            return $ fromMaybe w $ splitSlimeCrit' (x + cxy) (unitVectorAtAngle d) cid cr w
+        else return $ w & tocr . crDir .~ d
+                & tocr . crType . slimeIsCompressing .~ False
+                & tocr . crDamage .~ mempty
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+
+doSlimeRadChange :: Creature -> Creature
+doSlimeRadChange = crType . slimeSlimeChange %~ f
+  where
+    f x | x > 1000 = x - 1000
+        | x < -1000 = x + 1000
+        | otherwise = 0
+
+splitSlimeCrit' :: Point2 -> Point2 -> Int -> Creature -> World -> Maybe World
+splitSlimeCrit' p v cid cr w = do
+    (cr1,cr2) <- splitSlimeCrit p v cr
+    let cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
+        (s,g) = runState (takeOne [popS,pop1S,pop2S,pop3S]) (w ^. randGen)
+    return $ w & cWorld . lWorld . creatures . ix cid .~ cr1
+            & cWorld . lWorld . creatures . at cid' ?~ (cr2 & crID .~ cid')
+            & soundStart (CrSound cid) (cr ^. crPos . _xy) s Nothing
+            & randGen .~ g
+
+splitSlimeCrit :: Point2 -> Point2 -> Creature -> Maybe (Creature, Creature)
+splitSlimeCrit p v cr = do
+    let mp = closestPointOnLine p (p+v) cxy
+        h = r - distance mp cxy
+    guard $ h > 0
+    let a1 = segmentArea r h
+        a2 = pi*r*r - a1
+        r1 = sqrt (a1/pi)
+        r2 = sqrt (a2/pi)
+        mvdir 
+            | isLHS p (p+v) cxy = normalize (vNormal v)
+            | otherwise = - normalize (vNormal v)
+        (ps',qs') 
+            | isLHS p (p+v) cxy = (ps,qs)
+            | otherwise = (qs,ps)
+        c1 = cr' & crPos . _xy .~ mp + r1 *^ mvdir
+                & crType . slimeSlime .~ round (r1 ^ (2 :: Int) * 100)
+                & crDir .~ argV mvdir
+        c2 = cr' & crPos . _xy .~ mp - r2 *^ mvdir
+                & crType . slimeSlime .~ round (r2^(2::Int) * 100)
+                & crDir .~ argV (-mvdir)
+        c1ps = qs' & each +~ cxy - (mp + r1 *^ mvdir) & each %~ rotateV (- c1 ^. crDir)
+        c2ps = ps' & each +~ cxy - (mp - r2 *^ mvdir) & each %~ rotateV (- c2 ^. crDir)
+    return (c1 & crType . slimeDistortion . sdShape .~ f c1ps c1
+        ,c2 & crType . slimeDistortion . sdShape .~ f c2ps c2
+        )
+  where
+    f xs@(_:_) c = polyInPoly (centroid xs) xs (slimeOutline c)
+    f _ _ = mempty
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    cr' = cr & crDamage .~ []
+        & crType . slimeSlimeChange .~ 0
+        & crType . slimeDistortion .~ SlimeDistortion 10  mempty True
+        & crType . slimeIsCompressing .~ False
+        & crType . slimeCompression .~ 1
+    (ps,qs) = cutPoly (p-cxy) (p+v-cxy) $ slimeOutline cr & each %~ rotateV (cr ^. crDir)
+    
+-- h is the height of the segment, ie r - distance to center
+segmentArea :: Float -> Float -> Float
+segmentArea r h = r*r*acos(1-h/r) - (r-h)*sqrt(h*(2*r-h))
+
+slinkCritUpdate :: Int -> World -> World
+slinkCritUpdate cid w =
+    w
+        & cWorld
+        . lWorld
+        . creatures
+        . ix cid
+        . crType
+        . slinkSpine
+        . each
+        . _2
+        *~ Q.axisAngle (V3 0 1 0) (pi / 1000)
+
+setChaseCritKinematics :: Int -> World -> World
+setChaseCritKinematics cid w = w
+    & cWorld . lWorld . creatures . ix cid %~ setChaseCritKinematics' w
+
+ccAngles :: World -> Creature -> (Float,Float,Float,Float)
+ccAngles w cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f (-a) 0 0
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f 
+            (0.45*pi - a)
+            (-0.9*pi)
+            (0.45*pi)
+    | otherwise = f (0.6*pi) (-0.2*pi) (-0.4*pi)
+  where
+    f a b c = (0,a,b,c)
+
+ccKState :: World -> Creature -> ChaseKState
+ccKState _ cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = PeckingCK i
+    | CloseToMelee i <- cr^?!crActionPlan.apStrategy = AimingCK i
+    | otherwise = UprightCK
+
+setChaseCritKinematics' :: World -> Creature -> Creature
+setChaseCritKinematics' w = f . g
+  where
+    g cr | ccKState w cr == cr ^?! crType . chaseKState = cr
+        | PeckingCK i <- ccKState w cr = cr
+            & crType . chaseLerp .~ 3
+            & crType . chaseKState .~ PeckingCK i
+        | otherwise = cr & crType . chaseLerp .~ 20
+            & crType . chaseKState .~ ccKState w cr
+    f cr = 
+        let (a,b,c,d) = ccAngles w cr
+            x = cr ^?! crType . chaseLerp
+        in if x <= 1
+            then cr & crType . chaseqy0 .~ a
+              & crType . chaseqy1 .~ b
+              & crType . chaseqy2 .~ c
+              & crType . chaseqy3 .~ d
+            else cr 
+              & crType . chaseqy0 %~ h x a
+              & crType . chaseqy1 %~ h x b
+              & crType . chaseqy2 %~ h x c
+              & crType . chaseqy3 %~ h x d
+              & crType . chaseLerp -~ 1
+    h x a b = 1/fromIntegral x * a + (1-1/fromIntegral x) * b
+
+updateChaseCrit :: Int -> Creature -> World -> World
+updateChaseCrit cid cr 
+    | SearchForFood <- cr ^?! crActionPlan . apGoal = updateFoodSearchChaseCrit cid cr
+    | Flee <- cr^?!crActionPlan.apGoal
+        , NoAction <- cr^?!crActionPlan.apAction = tocr.crActionPlan.apGoal.~SearchForFood
+    | Flee <- cr^?!crActionPlan.apGoal = id
+    | otherwise = updateCalmChaseCrit cid
+  where
+    tocr = cWorld.lWorld.creatures.ix cid
+
+updateFoodSearchChaseCrit :: Int -> Creature -> World -> World
+updateFoodSearchChaseCrit cid cr w 
+    | (tcr:_) <- sortOn f . IM.elems . IM.filter avoidcr $ crsNearCirc cxy 60 w 
+        = let p = fleePoint cr cxy (20 *^ normalize (cxy - tcr^.crPos._xy)) w
+          in w &tocr.crActionPlan.apAction.~PathTo p NoAction
+                &tocr.crActionPlan.apGoal.~Flee
+    | Eat i 0 <- cr^?! crActionPlan.apAction = w
+            & cWorld .lWorld.creatures . at i .~ Nothing
+            & tocr . crActionPlan.apAction.~NoAction
+            & tocr . crActionPlan.apStrategy.~Search
+    | Eat i x <- cr^?! crActionPlan.apAction = w
+            & tocr .crActionPlan.apAction.acTimer-~1
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Nothing <- w ^?cWorld.lWorld.creatures.ix i = w & tocr . crActionPlan.apStrategy .~ Search
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Just tcr <-w^?cWorld.lWorld.creatures.ix i
+        ,distance cxy (tcr^.crPos._xy) < 15 = w
+            & tocr.crActionPlan.apAction.~Eat i 5
+--            & tocr.crActionPlan.apAction.~NoAction
+--            & tocr.crActionPlan.apStrategy.~Search
+--            & cWorld.lWorld.creatures.at i.~Nothing
+    | CloseToMelee{}<-cr^?!crActionPlan.apStrategy 
+        ,PathTo{}<-cr^?!crActionPlan.apAction= w
+    | xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g) <- runState (takeOne xs) (w ^. randGen) = w&tocr.crActionPlan.apAction.~DoImpulses[MvForward]
+        &tocr.crActionPlan.apStrategy.~CloseToMelee (tcr^.crID)
+        &tocr.crActionPlan.apAction.~PathTo (tcr^.crPos._xy) NoAction
+        &randGen.~g
+    | otherwise = w
+  where
+    f c = fromMaybe 100 $ do
+        s <- cr^?crType.slimeSlime
+        return $ dist cxy (c^.crPos._xy) - sqrt(0.01*fromIntegral s)
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    avoidcr c | ct@SlimeCrit{} <- c^.crType = distance cxy (c^.crPos._xy)-crRad ct < 10
+        | otherwise = False
+    istarget tcr 
+        | BeeCrit{} <- tcr^.crType 
+        , CrIsCorpse{} <- tcr^.crHP = True
+        | otherwise = False
+    
+fleePoint :: Creature -> Point2 -> Point2 -> World -> Point2
+fleePoint c p v w = g . minimum $ f <$> [p+v, p+0.9*^vNormal v, p-0.9*^vNormal v]
+  where
+    f ep = let q = walkablePoint c p ep w
+            in Semi.Arg (-distance q p) q
+    g (Semi.Arg _ x) = x
+
+
+updateCalmChaseCrit :: Int -> World -> World
+updateCalmChaseCrit cid w = w
+    & tocr %~ overrideMeleeCloseTarget w
+    & tocr %~ setViewPos w
+    & tocr %~ setMvPosToTargetCr w
+    & tocr %~ chaseCritMv w
+    & tocr %~ perceptionUpdate [0] w
+    & tocr %~ targetYouWhenCognizant w
+    & tocr %~ searchIfDamaged
+    & tocr . crType . meleeCooldown %~ max 0 . subtract 1
+    & tocr . crVocalization %~ updateVocTimer
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+
+
+hoverCritHoverSound :: Creature -> World -> World
+hoverCritHoverSound cr w
+    | d < 100 
+        = soundContinueVol (0.5 * (1 - 0.01 * d)) (CrSound cid) cxy buzz1S (Just 2) w
+    | otherwise = w
+  where
+    cxy = cr ^. crPos . _xy
+    d = max 0 (dist (you w ^. crPos . _xy) cxy - 100)
+    cid = cr ^. crID
+
 {- | this seems to work, but I am not sure about the ordering:
  previously, the movement was updated before the ai in order to correctly set the oldpos.
  This should be made more sensible: should the movement side effects apply to
@@ -73,56 +525,85 @@ crUpdate cid =
     checkDeath cid
         . doDamage cid
         . invItemEffs cid
-        . updateWalkCycle cid  -- stride appears to be updated elsewhere as well
+        . updateCarriage cid -- stride appears to be updated elsewhere as well
 
 checkDeath :: Int -> World -> World
 checkDeath cid w = maybe id checkDeath' (w ^? cWorld . lWorld . creatures . ix cid) w
 
 checkDeath' :: Creature -> World -> World
 checkDeath' cr w = case cr ^. crHP of
-    HP x | x > 0 -> w & tocr . crDamage .~ []
+    HP x | x > 0 -> w
-    HP x | x > -200 && _crDeathTimer cr > 0 ->
+    HP x | x > -200 && null (cr ^. crDeathTimer) -> w & tocr %~ startDeathTimer
-            w
+    HP x
-                & tocr . crDamage .~ []
+        | x > -200
-                & tocr . crDeathTimer -~ 1
+        , Just y <- cr ^. crDeathTimer
+        , y > 0 -> w & tocr . crDeathTimer . _Just -~ 1
     HP _ ->
         w
             & dropAll cr -- the order of these is possibly important
             & stopSoundFrom (CrWeaponSound (_crID cr) 0)
             & corpseOrGib cr
+            & crDeathEffects cr
+            & tocr . crStance . carriage %~ toDeathCarriage
     _ -> w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
+crDeathEffects :: Creature -> World -> World
+crDeathEffects cr w = case cr ^. crType of
+    BeeCrit {_beeHive = mhid} -> beepheremone $ fromMaybe w $ do
+        hid <- mhid
+        return $ w & cWorld . lWorld . creatures . ix hid . crType . hiveChildren %~ IS.delete (cr ^. crID)
+    _ -> w
+  where
+    beepheremone 
+        | Just x <- cr ^? crType . beeLifespan
+        ,   x < 1 = id
+        | otherwise = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos) (cr ^. crPos - cr ^. crOldPos) 200
+
+startDeathTimer :: Creature -> Creature
+startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
+            HoverCrit{} -> 0
+            BeeCrit{} -> 0
+            _ -> 5
+
+toDeathCarriage :: Carriage -> Carriage
+toDeathCarriage = \case
+    Flying{} -> Falling Q.qid Q.qid
+    Walking -> OnGround Q.qid
+    _ -> Falling Q.qid Q.qid
+
 -- could look at the amount of damage here (given by maxDamage) too
 corpseOrGib :: Creature -> World -> World
-corpseOrGib cr = case cr ^? crDamage . to maxDamageType . _Just . _1 of
+corpseOrGib cr w =
-    Just CookingDamage ->
+    w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
-        sethp (CrIsCorpse $ scorchSPic thecorpse)
+        Just CookingDamage ->
-            . dodeathsound CookDeath
+            sethp (CrIsCorpse $ scorchSPic thecorpse)
-    Just PoisonDamage ->
+                . dodeathsound CookDeath
-        sethp (CrIsCorpse $ poisonSPic thecorpse)
+        Just PoisonDamage ->
-            . dodeathsound PoisonDeath
+            sethp (CrIsCorpse $ poisonSPic thecorpse)
-    Just PhysicalDamage
+                . dodeathsound PoisonDeath
-        | _crPain cr > 200 ->
+        Just PhysicalDamage
-            addCrGibs cr
+            | _crPain cr > 300 ->
-                . sethp CrIsGibs
+                makeCrGibs cr
-                . dodeathsound GibsDeath
+                    . (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature)
-    _ ->
+                    . dodeathsound GibsDeath
-        sethp (CrIsCorpse thecorpse)
+        _ ->
-            . dodeathsound PlainDeath
+            sethp (CrIsCorpse thecorpse)
+                . dodeathsound PlainDeath
   where
     dodeathsound dt = f dt . stopSoundFrom (CrMouth cid)
-    f dt w = fromMaybe w $ do
+    f dt w' = fromMaybe w' $ do
-        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w)
+        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w')
         sid <- msid
         return $
-            w
+            w'
                 & soundStart (CrMouth cid) (cr ^. crPos . _xy) sid Nothing
-                & randGen .~ g
+                & randGen
+                .~ g
     cid = cr ^. crID
     sethp x = cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ x
-    thecorpse = makeCorpse cr
+    thecorpse = makeCorpse w (w ^. randGen) cr
 
 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
@@ -134,49 +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
 
-chasmTestLiving :: Creature -> World -> World
-chasmTestLiving cr w
-    | _crZVel cr < 0 =
-        w
-            & tocr . crZVel -~ 0.5
-            & tocr . crPos . _z +~ _crZVel cr
-    | Just (x, y) <- List.find g (w ^. cWorld . cliffs) =
-        w
-            & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
-            & tocr . crPos . _xy -~ normalizeV (vNormal (x - y))
-            & chasmRotate cr (x - y)
-    | any f (w ^. cWorld . chasms) = w & tocr . crZVel -~ 0.5
-    | otherwise = w
-  where
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
-    g = uncurry $ circOnSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-    f = circInPolygon (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-
-chasmTestCorpse :: Creature -> World -> World
-chasmTestCorpse cr w
-    | _crZVel cr < 0 =
-        w
-            & tocr . crZVel -~ 0.5
-            & tocr . crPos . _z +~ _crZVel cr
-    | Just (x, y) <- List.find g (w ^. cWorld . cliffs) =
-        w
-            & soundContinue (CrChasm (_crID cr)) (cr ^. crPos . _xy) debrisS (Just 100)
-            & tocr . crPos . _xy +~ normalizeV (vNormal (x - y))
-            & chasmRotate cr (x - y)
-    | any f (w ^. cWorld . chasms) = w & tocr . crZVel -~ 0.5
-    | otherwise = w
-  where
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
-    g = uncurry $ circOnSeg (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-    f = circInPolygon (cr ^. crPos . _xy) (crRad $ cr ^. crType)
-
-chasmRotate :: Creature -> Point2 -> World -> World
-chasmRotate cr v w
-    | t = rotateTo8 (argV v) w
-    | otherwise = w
-  where
-    t = cr ^. crID == 0 && null (w ^? input . mouseButtons . ix SDL.ButtonRight)
-
 updatePulse :: Pulse -> Pulse
 updatePulse p
     | p ^. pulseProgress >= p ^. pulseRate = p & pulseProgress .~ 0

src/Dodge/Creature/Vocalization.hs

@@ -3,30 +3,19 @@
 module Dodge.Creature.Vocalization (
     crWarningSounds,
     crDeathSounds,
-    vocalizationTest,
     resetCrVocCoolDown,
 ) where
 
+import Dodge.Material.Sound
 import Control.Lens
 import Dodge.Data.World
 import Dodge.SoundLogic.ExternallyGeneratedSounds
 import Sound.Data
 import System.Random
 
-crVocalizationSound :: Creature -> Maybe SoundID
-crVocalizationSound cr = case cr ^. crType of
-    Avatar{} -> Nothing
-    AvatarDead -> Nothing
-    ChaseCrit{} -> Just seagullChatterS
-    SwarmCrit -> Nothing
-    AutoCrit -> Nothing
-    BarrelCrit{} -> Nothing
-    LampCrit{} -> Nothing
-
 crWarningSounds :: Creature -> [SoundID]
 crWarningSounds cr = case cr ^. crType of
     Avatar{} -> mempty
-    AvatarDead -> mempty
     ChaseCrit{} ->
         [ seagullBarkS
         , seagullChatterS
@@ -37,20 +26,31 @@ crWarningSounds cr = case cr ^. crType of
         , seagullCry1S
         , seagullCry2S
         ]
+    SlinkCrit{} -> mempty
+    SlimeCrit{} -> mempty
+    CrabCrit {} -> mempty
+    HoverCrit {} -> mempty
     SwarmCrit -> mempty
     AutoCrit -> mempty
     BarrelCrit{} -> mempty
     LampCrit{} -> mempty
+    BeeCrit{} -> mempty
+    HiveCrit{} -> mempty
 
 crDeathSounds :: Creature -> DeathType -> [SoundID]
 crDeathSounds cr dt = case cr ^. crType of
     Avatar{} -> mempty
-    AvatarDead -> mempty
     ChaseCrit{} -> defaultDeathSounds dt
+    CrabCrit{} -> defaultDeathSounds dt
+    HoverCrit{} -> hoverDeathSounds dt
+    SlinkCrit{} -> defaultDeathSounds dt
+    SlimeCrit{} -> defaultDeathSounds dt
     SwarmCrit -> mempty
     AutoCrit -> mempty
     BarrelCrit{} -> mempty
     LampCrit{} -> mempty
+    BeeCrit{} -> defaultDeathSounds dt
+    HiveCrit{} -> defaultDeathSounds dt
 
 defaultDeathSounds :: DeathType -> [SoundID]
 defaultDeathSounds = \case
@@ -59,14 +59,16 @@ defaultDeathSounds = \case
     PlainDeath -> mempty
     GibsDeath -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S]
 
-vocalizationTest :: Creature -> Maybe SoundID
+hoverDeathSounds :: DeathType -> [SoundID]
-vocalizationTest cr = case cr ^? crVocalization . vcCoolDown of
+hoverDeathSounds = \case
-    Just 0 -> crVocalizationSound cr
+    CookDeath -> mempty
-    _ -> Nothing
+    PoisonDeath -> mempty
+    PlainDeath -> [clangS]
+    GibsDeath -> destroyMatS Electronics
 
+crVocalResetTime :: Creature -> StdGen -> Int
+crVocalResetTime _ = fst . randomR (50,100)
+
+-- this should update the randgen as well
 resetCrVocCoolDown :: World -> Creature -> Creature
-resetCrVocCoolDown w cr = case cr ^? crVocalization . vcMaxCoolDown of
+resetCrVocCoolDown w cr = cr & crVocalization .~ VocTimer 0 (crVocalResetTime cr (w ^. randGen))
-    Just (i, j) -> cr & crVocalization . vcCoolDown .~ x
-      where
-        x = fst $ randomR (i, j) (_randGen w)
-    Nothing -> cr

src/Dodge/Creature/Volition.hs

@@ -1,39 +0,0 @@
--- | Not a good name, perhaps: internal creature actions.
-module Dodge.Creature.Volition (
-    holsterWeapon,
-    drawWeapon,
-    shootTillEmpty,
-    shootFirstMiss,
-) where
-
-import Dodge.Data.AimStance
-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 OneHand, 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

@@ -2,9 +2,7 @@
 
 module Dodge.Creature.YourControl (yourControl) where
 
-import Linear
 import Control.Monad
-import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.AssignHotkey
@@ -16,63 +14,45 @@ import Dodge.Data.Equipment.Misc
 import Dodge.Data.World
 import Dodge.InputFocus
 import Dodge.Inventory
-import Dodge.Item.AimStance
 import Dodge.SelectedClose
 import Dodge.WASD
 import Geometry
 import LensHelp
+import Linear
 import NewInt
 import qualified SDL
 
 -- | The AI equivalent for your control.
-yourControl :: Creature -> World -> World
+yourControl :: World -> World
-yourControl _ w
+yourControl w
     | inTextInputFocus w = w
-    | Just x <- w ^? hud . subInventory
+    | NoSubInventory <- w ^. hud . subInventory =
-      , f x =
         w
             & cWorld . lWorld . creatures . ix 0 %~ wasdWithAiming w
-            & tryClickUse pkeys
+            & tryClickUse (w ^. input . mouseButtons)
             & handleHotkeys
     | otherwise = w & cWorld . lWorld . creatures . ix 0 %~ wasdWithAiming w
-  where
-    f = \case
-        NoSubInventory -> True
-        ExamineInventory -> True
-        _ -> False
-    pkeys = w ^. input . mouseButtons
 
 -- the following only works because modifier keys are ordered after scancode "hotkeys"
 handleHotkeys :: World -> World
 handleHotkeys w
     | ispressed SDL.ScancodeLShift || ispressed SDL.ScancodeRShift
-      , (hk:_) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
+    , (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
+    , (hk : _) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
-      , Just itid <- lw ^? hotkeys . ix hk . unNInt
+    , Just itid <- lw ^? hotkeys . ix hk . unNInt
-      , Just invid <- lw ^? items . ix itid . itLocation . ilInvID =
+    , Just invid <- lw ^? items . ix itid . itLocation . ilInvID =
         w & invSetSelectionPos 0 (_unNInt invid)
-    | otherwise =
+    | otherwise = M.foldl' useHotkey w pressedhotkeys
-        M.foldl'
-            useHotkey
-            w
-            (M.intersectionWith (,) thehotkeys (w ^. input . pressedKeys))
   where
     pkeys = w ^. input . pressedKeys
     ispressed k = k `M.member` _pressedKeys (_input w)
     thehotkeys = M.mapKeys hotkeyToScancode $ w ^. cWorld . lWorld . hotkeys
     lw = w ^. cWorld . lWorld
-
+    pressedhotkeys = M.intersectionWith (,) thehotkeys (w ^. input . pressedKeys)
---modifierKeys :: S.Set SDL.Scancode
---modifierKeys = S.fromList 
---    [ SDL.ScancodeLShift
---    , SDL.ScancodeRShift
---    , SDL.ScancodeRCtrl
---    , SDL.ScancodeLCtrl
---    ]
 
 useHotkey :: World -> (NewInt ItmInt, Int) -> World
 useHotkey w (NInt itid, pt) = fromMaybe w $ do
@@ -124,7 +104,10 @@ scancodeToHotkey = \case
  within wasdMovement should probably be done first
 -}
 wasdWithAiming :: World -> Creature -> Creature
-wasdWithAiming w cr = wasdAim inp w $ wasdMovement (w ^. cWorld . lWorld) inp cam speed cr
+wasdWithAiming w cr 
+    | Walking <- cr ^. crStance . carriage 
+        = wasdAim inp w $ wasdMovement w inp cam speed cr
+    | otherwise = cr
   where
     speed = _mvSpeed $ crMvType cr
     inp = w ^. input
@@ -132,58 +115,44 @@ wasdWithAiming w cr = wasdAim inp w $ wasdMovement (w ^. cWorld . lWorld) inp ca
 
 wasdAim :: Input -> World -> Creature -> Creature
 wasdAim inp w cr
-    | Just 0 <- inp ^? mouseButtons . ix SDL.ButtonRight
+    | SDL.ButtonRight `M.member` _mouseButtons inp
-      , Nothing <- inp ^? mouseButtons . ix SDL.ButtonLeft =
+    , AtEase <- cr ^. crStance . posture = setposture Aiming (-twistAmount)
-        setAimPosture (w ^. cWorld . lWorld . items) cr
+    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn w mousedir cr
-    | SDL.ButtonRight `M.member` _mouseButtons inp =
+    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twistAmount
-        aimTurn (w ^. cWorld . lWorld) mousedir cr
+    | otherwise = creatureTurnTowardDir (_crMvDir cr) 0.2 cr
-    | Aiming {} <- cr ^. crStance . posture = removeAimPosture cr
-    | otherwise = creatureTurnTowardDir (_crMvAim cr) 0.2 cr
   where
+    setposture x r =
+        cr
+            & crStance . posture .~ x
+            & doAimTwist (w ^? hud . manObject . hiAimStance) r
     mousedir = argV $ w ^. cWorld . lWorld . lAimPos - (cr ^. crPos . _xy)
 
-setAimPosture :: IM.IntMap Item -> Creature -> Creature
+doAimTwist :: Maybe AimStance -> Float -> Creature -> Creature
-setAimPosture m cr = fromMaybe cr $ do
-    invid <- cr ^? crManipulation . manObject . imRootSelectedItem
-    itid <- cr ^? crInv . ix invid
-    as <- fmap itemBaseStance $ m ^? ix itid
-    return $ cr
-        & crStance . posture .~ Aiming as
-        & doAimTwist as (- twoHandTwistAmount)
-
-doAimTwist :: AimStance -> Float -> Creature -> Creature
 doAimTwist as x
-    | as == TwoHandOver || as == TwoHandUnder = crDir +~ x
+    | as == Just TwoHandTwist = crDir +~ x
     | otherwise = id
 
-removeAimPosture :: Creature -> Creature
+twistAmount :: Float
-removeAimPosture cr = fromMaybe cr $ do
+twistAmount = 1.6 * pi
-    as <- cr ^? crStance . posture . aimStance
-    return $ cr
-        & crStance . posture .~ AtEase
-        & doAimTwist as twoHandTwistAmount
 
-twoHandTwistAmount :: Float
+wasdMovement :: World -> Input -> Camera -> Float -> Creature -> Creature
-twoHandTwistAmount = 1.6 * pi
+wasdMovement w inp cam speed = theMovement -- . setMvAim
-
-wasdMovement :: LWorld -> Input -> Camera -> Float -> Creature -> Creature
-wasdMovement lw inp cam speed = theMovement . setMvAim
   where
-    setMvAim = fromMaybe id $ do
+--    setMvAim = fromMaybe id $ do
-        dir <- safeArgV movDir
+--        dir <- safeArgV movDir
-        return $ crMvAim .~ (cam ^. camRot + dir)
+--        return $ crMvAim .~ (cam ^. camRot + dir)
     movDir = wasdDir inp
     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
@@ -220,8 +189,7 @@ heldItemBulkiness = \case
     FLAMETORRENT -> 1
     FLAMEWALL -> 1
     BLOWTORCH -> 1
-    SPARKGUN -> 1
+    TESLACOIL -> 1
-    TESLAGUN -> 1
     TRACTORGUN -> 1
     RLAUNCHER -> 0.9
     RLAUNCHERX{} -> 0.9
@@ -239,11 +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 . lWorld . creatures . ix 0
+        Just (Sel 0 invid) -> useItem invid ltime w
-            . crManipulation
+        _ -> interactWithCloseObj <$> getSelectedCloseObj w ?? w
-            . manObject
-            . imSelectedItem
-            . unNInt of
-        Just invid -> useItem invid ltime w
-        Nothing -> interactWithCloseObj <$> getSelectedCloseObj w ?? w

src/Dodge/CreatureEffect.hs

@@ -34,19 +34,11 @@ doCrBl cb = case cb of
     CrCanShoot -> error "got rid of crCanShoot"
     CrIsAiming -> crIsAiming
     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
@@ -54,30 +46,30 @@ doCrWdAc cw = case cw of
 --            $
 --            DoReplicate t $
 --                foldr DoActionThen NoAction as
-    ChooseMovementSpreadGun -> chooseMovementSpreadGun
+--    ChooseMovementSpreadGun -> chooseMovementSpreadGun
-    ChooseMovementLtAuto -> chooseMovementLtAuto
+--    ChooseMovementLtAuto -> chooseMovementLtAuto
 
-chooseMovementSpreadGun :: Creature -> World -> Action
+--chooseMovementSpreadGun :: Creature -> World -> Action
-chooseMovementSpreadGun cr w
+--chooseMovementSpreadGun cr w
-    | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi =
+--    | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi =
-        DoImpulses [UseItem, MoveForward (-3)]
+--        DoImpulses [UseItem, MoveForward (-3)]
-    | d < 30 = DoImpulses [UseItem, TurnToward p 0.06]
+--    | d < 30 = DoImpulses [UseItem, TurnToward p 0.06]
-    | d < 60 = DoImpulses [UseItem, TurnToward p 0.06, MoveForward 3]
+--    | d < 60 = DoImpulses [UseItem, TurnToward p 0.06, MoveForward 3]
-    | d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3]
+--    | d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3]
-    | d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 * (d -100)), MoveForward 3]
+--    | d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 * (d -100)), MoveForward 3]
-    | otherwise =
+--    | otherwise =
-        DoImpulses [TurnToward p 0.26, MoveForward 3]
+--        DoImpulses [TurnToward p 0.26, MoveForward 3]
-  where
+--  where
-    d = dist cpos p
+--    d = dist cpos p
-    cpos = cr ^. crPos . _xy
+--    cpos = cr ^. crPos . _xy
-    --tcr = _creatures (_cWorld w) IM.! 0
+--    --tcr = _creatures (_cWorld w) IM.! 0
-    tcr = w ^?! cWorld . lWorld . creatures . ix 0
+--    tcr = w ^?! cWorld . lWorld . creatures . ix 0
-    p = tcr ^. crPos . _xy
+--    p = tcr ^. crPos . _xy
 
 chooseMovementLtAuto :: Creature -> World -> Action
 chooseMovementLtAuto cr w
-    | dist cpos p > 200 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward 3]
+--    | dist cpos p > 200 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward 3]
-    | dist cpos p < 80 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward (-3)]
+--    | dist cpos p < 80 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward (-3)]
     | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 =
         DoImpulses [UseItem, TurnToward p' 0.01, Move (V2 0 3)]
     | otherwise =
@@ -89,9 +81,9 @@ chooseMovementLtAuto cr w
     v = vNormal $ p -.- cpos
     p' = p +.+ 0.5 *.* (v -.- 20 *.* normalizeV v)
 
-fleeFrom :: Creature -> Maybe Creature -> Action
+--fleeFrom :: Creature -> Maybe Creature -> Action
-fleeFrom cr mtcr = case mtcr of
+--fleeFrom cr mtcr = case mtcr of
-    Just tcr -> DoImpulses 
+--    Just tcr -> DoImpulses 
-        [MoveForward 3
+--        [MoveForward 3
-        , TurnToward ((2 *.* (cr ^. crPos ._xy)) -.- (tcr ^. crPos . _xy)) (pi / 4)]
+--        , TurnToward ((2 *.* (cr ^. crPos ._xy)) -.- (tcr ^. crPos . _xy)) (pi / 4)]
-    Nothing -> NoAction
+--    Nothing -> NoAction

src/Dodge/Damage.hs

@@ -49,6 +49,7 @@ dmType = \case
     Explosive{} -> PhysicalDamage
     Poison{} -> PoisonDamage
     Enterrement{} -> PhysicalDamage
+    Inertial {} -> PhysicalDamage
 
 collectDamageTypes :: [Damage] -> M.Map DamageType Int
 collectDamageTypes = foldl' (flip f) M.empty
@@ -65,7 +66,7 @@ damageInCircle f p r w =
         & cWorld . lWorld . creatures %~ docrdams
   where
     dowldams wds = foldl' g wds (wlsHitRadial p r w)
-    docrdams crs = foldl' h crs (crsHitRadial p r w)
+    docrdams crs = foldl' h crs (bodiesHitRadial p r w)
     g wds (x, wl) = wds & at (_wlID wl) . non mempty .:~ f x
     h crs (x, cr) = crs & ix (_crID cr) . crDamage .:~ f x
 

src/Dodge/Data/ActionPlan.hs

@@ -13,17 +13,19 @@ import Sound.Data
 
 data ActionPlan
     = Inanimate
+    | SlimeIntelligence
     | ActionPlan
         { -- _apImpulse :: [Impulse] -- done per frame
-         _apAction :: [Action] -- updated per frame, likely persist across frames
+         _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)
 
 data Impulse
     = Move Point2
+    | Walk Point2
     | MoveForward Float
     | MoveNoStride Point2
     | Turn Float
@@ -34,16 +36,20 @@ data Impulse
     | MvForward
     | TurnTo Point2
     | UseItem
-    | SwitchToItem Int
+--    | SwitchToItem Int
     | DropItem
     | Bark SoundID -- placeholder for various communication types
     | Melee Int
+    | MeleeL Int
+    | MeleeR Int
     | ChangePosture Posture
     | MakeSound SoundID
     | ChangeStrategy Strategy
-    | AddGoal Goal
+--    | AddGoal Goal
     | ImpulseUseTarget { _impulseUseTarget :: CrImp }
     | ImpulseNothing
+    | UpdateRandGen
+    | SetBeeRandomMovement
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data RandImpulse
@@ -56,7 +62,7 @@ infixr 9 `WaitThen`
 
 infixr 9 `DoActionThen`
 
-infixr 9 `DoActionWhile`
+--infixr 9 `DoActionWhile`
 
 infixr 9 `DoReplicate`
 
@@ -67,18 +73,16 @@ data Action
         { _targetID :: Int
         , _targetSeenAt :: Point2
         }
-    | PathTo { _pathToPoint :: Point2 }
+    | PathTo { _pathToPoint :: Point2, _pathFailAction :: Action }
+    | Eat {_targetID :: Int, _acTimer :: Int}
+    | EvadeAim
     | TurnToPoint { _turnToPoint :: Point2 }
-    | ImpulsesList { _impulsesListList :: [[Impulse]] }
+    | ImpulsesList { _impulsesListList :: [[Impulse]], _acAction :: Action }
     | DoImpulses { _doImpulsesList :: [Impulse] }
     | WaitThen
         { _waitThenTimer :: Int
         , _waitThenAction :: Action
         }
-    | DoActionWhile
-        { _doActionWhileCondition :: WdCrBl
-        , _doActionWhileAction :: Action
-        }
     | DoActionWhilePartial
         { _doActionWhilePartial :: Action
         , _doActionWhileCondition :: WdCrBl
@@ -98,7 +102,7 @@ data Action
         , _doActionWhileThenCondition :: WdCrBl
         , _doActionWhileThenThen :: Action
         }
-    | DoActions { _doActionsList :: [Action] }
+--    | DoActions { _doActionsList :: [Action] }
     | DoActionThen
         { _doActionThenFirst :: Action
         , _doActionThenSecond :: Action
@@ -114,9 +118,6 @@ data Action
         }
     | LeadTarget { _leadTargetBy :: Point2 }
     | NoAction
-    | StartSentinelPost
-    | UseSelf { _useSelf :: CrAc }
-    | ArbitraryAction {_arbitraryAction :: CrWdAc}
 -- | Repeatedly perform impulses alongside a main action until the main action terminates
     | DoImpulsesAlongside
         { _sideImpulses :: [Impulse]
@@ -131,23 +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/AimStance.hs

@@ -8,8 +8,7 @@ import Data.Aeson
 import Data.Aeson.TH
 
 data AimStance
-    = TwoHandUnder
+    = TwoHandTwist
-    | TwoHandOver
     | TwoHandFlat
     | OneHand
     deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/Bullet.hs

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

src/Dodge/Data/Button.hs

@@ -23,6 +23,7 @@ data ButtonEvent
         , _bsColor2 :: Color
         , _btOn :: Bool
         }
+    | ButtonDumbSwitch { _bdsTrigger :: Int }
     | ButtonAccessTerminal {_btTermID :: Int}
 
 data Button = Button

src/Dodge/Data/CamouflageStatus.hs

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

src/Dodge/Data/CardinalPoint.hs

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

src/Dodge/Data/Cloud.hs

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

src/Dodge/Data/ComposedItem.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.ComposedItem where
 
+import Color.Data
 import Control.Lens
 import Dodge.Data.AmmoType
 import Dodge.Data.Item
@@ -26,7 +27,7 @@ data ItemSF -- Structural Function
     | JoystickSF
     | RemoteDetonatorSF
     | SmokeReducerSF
-    | NoSF
+    | NoSF Color
     | AmmoModifierSF AmmoType
     | AmmoTargetingSF AmmoType
     | AmmoPayloadSF AmmoType
@@ -37,12 +38,16 @@ data ItemSF -- Structural Function
     | GrenadeHitEffectSF
     | ToggleSF
     | MapperSF
-    | LaserWeaponSF
+--    | LaserWeaponSF
+    | LaserWeaponXSF {_lasWepXSF :: Int}
     | PulseLaserSF
     | CapacitorSF
     | TransformerSF
     | PulseBallSF
+    | PlasmaSF
     | TorchSF
+    | PumpSF
+    | BeamSplitterSF
     deriving (Eq, Ord, Show, Read)
 
 type CItem = (Item, ItemSF)

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

@@ -22,6 +22,7 @@ import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import qualified Data.Map.Strict as M
+import qualified Data.IntMap.Strict as IM
 import Dodge.Data.ActionPlan
 import Dodge.Data.Creature.Misc
 import Dodge.Data.Creature.Perception
@@ -30,20 +31,18 @@ import Dodge.Data.Creature.State
 import Dodge.Data.Item
 import Dodge.Data.Material
 import Geometry.Data
---import qualified IntMapHelp as IM
 
 data Creature = Creature
     { _crPos :: Point3
     , _crOldPos :: Point3
-    , _crZVel :: Float
+    , _crOldOldPos :: Point3
     , _crDir :: Float
     , _crMvDir :: Float
-    , _crMvAim :: Float
     , _crType :: CreatureType
     , _crID :: Int
     , _crHP :: CrHP
     , _crInv :: NewIntMap InvInt Int
-    , _crManipulation :: Manipulation
+--    , _crManipulation :: Manipulation
     , _crEquipment :: M.Map EquipSite (NewInt ItmInt)
     , _crDamage :: [Damage]
     , _crPain :: Int
@@ -56,14 +55,24 @@ data Creature = Creature
     , _crGroup :: CrGroup
     , _crIntention :: Intention
     , _crName :: String
-    , _crDeathTimer :: Int
+    , _crDeathTimer :: Maybe Int
+    , _crWallTouch :: IM.IntMap Point2
     }
 
+-- Prisms, not lenses
 data CrHP
     = HP Int
     | CrIsCorpse SPic
-    | CrIsGibs
+    | AvatarDestroyed
-    | CrIsPitted
+--    | 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
 
 data DeathType = CookDeath | PoisonDeath | PlainDeath | GibsDeath
 
@@ -93,4 +102,5 @@ concat
         [ ''Creature
         , ''Intention
         , ''CrHP
+        , ''CrDestructionType
         ]

src/Dodge/Data/Creature/Misc.hs

@@ -1,52 +1,42 @@
 {-# 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
+import qualified Data.IntSet as IS
 
 data Vocalization
-    = Mute
+    = VocTimer {_vcTime :: Int ,_vcMaxTime :: Int }
-    | Vocalization
+    | VocReady
-        { _vcMaxCoolDown :: (Int, Int)
-        , _vcCoolDown :: Int
-        }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CrMvType
     = NoMvType
-    | MvWalking {_mvSpeed :: Float}
+    | MvWalking {_mvSpeed :: Float} -- note this may interact with a friction element
-    | CrMvType
+    -- so currently 26.04.03 the actual max speed when walking is twice this
+    | JitMvType
         { _mvSpeed :: Float
         , _mvTurnRad :: FloatFloat
         , _mvTurnJit :: Float
-        , _mvAimSpeed :: FloatFloat
         }
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+    | StartStopMvType
-
+        { _mvSpeed :: Float
-data HumanoidAI
+        , _mvTurnSpeed :: Float
-    = ChaseAI
+        , _mvPulseTime :: Int
-    | InanimateAI
+        }
-    | SpreadGunAI
+    | BeeMvType
-    | PistolAI
+        { _mvSpeed :: Float
-    | LtAutoAI
+        , _mvTurnSpeed :: Float
-    | LauncherAI
+        , _mvPulseTime :: Int
-    | SwarmAI
+        }
-    | AutoAI
-    | FlockArmourChaseAI
-    | MiniGunAI
-    | LongAI
-    | MultGunAI
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Pulse = PulseStatus
@@ -62,24 +52,89 @@ data CreatureType
         , _avStrength :: Int
         , _avDexterity :: Int
         , _avIntelligence :: Int
-        , _avMoveSpeed :: Float
+        , _avPosture :: AvatarPosture
+        , _footForward :: FootForward
+        , _strideAmount :: Float
+        }
+    | ChaseCrit {_meleeCooldown :: Int
+        , _footForward :: FootForward
+        , _strideAmount :: Float
+        , _chaseqy0 :: Float
+        , _chaseqy1 :: Float
+        , _chaseqy2 :: Float
+        , _chaseqy3 :: Float
+        , _chaseqz :: Float
+        , _chaseLerp :: Int
+        , _chaseKState :: ChaseKState
+        }
+    | CrabCrit 
+        { _meleeCooldownL :: Int
+        , _meleeCooldownR :: Int
+        , _dodgeCooldown :: Int
+        , _lFootPos :: Point2
+        , _rFootPos :: Point2
+        }
+    | HoverCrit {_meleeCooldown :: Int}
+    | SlinkCrit 
+        { _meleeCooldown :: Int
+        , _slinkSpine :: [Point3Q]
+        , _slinkHeadPos :: Point3Q
+        }
+    | SlimeCrit
+        { _slimeSlime :: Int -- note multiplied by 100
+        , _slimeSlimeChange :: Int
+--        , _slimeRadWobble :: Float
+        --, _slimeSplitTimer :: Int
+        , _slimeDistortion :: SlimeShapeDistortion
+        , _slimeCompression :: Float
+        , _slimeIsCompressing :: Bool
+        , _slimeEngulfProgress :: Float
+        } 
+    | BeeCrit
+        { _beeSlime :: Int
+        , _beeHive :: Maybe Int
+        , _startStopMv :: Int
+        , _beeAggro :: Int
+        , _meleeCooldown :: Int
+        , _beeRandomMovement :: Maybe FootForward
+        , _beeLifespan :: Int
+        }
+    | HiveCrit
+        { _hiveChildren :: IS.IntSet
+        , _hiveGestation :: Int
+        , _hiveSlime :: Int
         }
-    | AvatarDead
-    | ChaseCrit {_meleeCooldown :: 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
     = Humanoid
         { _skinHead :: Color
         , _skinUpper :: Color
         , _skinLower :: Color
-        , _humanoidAI :: HumanoidAI
         }
     | Barreloid
-    | NonDrawnCreature
+    | NoCreatureShape
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data BarrelType
@@ -89,17 +144,15 @@ data BarrelType
 
 makeLenses ''Pulse
 makeLenses ''BarrelType
-
---makeLenses ''CreatureStatistics
 makeLenses ''Vocalization
 makeLenses ''CrMvType
 makeLenses ''CreatureType
+makeLenses ''CreatureShape
+makeLenses ''SlimeShapeDistortion
+deriveJSON defaultOptions ''ChaseKState
+deriveJSON defaultOptions ''SlimeShapeDistortion
 deriveJSON defaultOptions ''Pulse
-
---deriveJSON defaultOptions ''CreatureStatistics
 deriveJSON defaultOptions ''Vocalization
-
---deriveJSON defaultOptions ''CrMvType
-deriveJSON defaultOptions ''HumanoidAI
 deriveJSON defaultOptions ''BarrelType
+deriveJSON defaultOptions ''AvatarPosture
 deriveJSON defaultOptions ''CreatureType

src/Dodge/Data/Creature/Stance.hs

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

src/Dodge/Data/CreatureEffect.hs

@@ -18,19 +18,20 @@ data WdCrBl
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CrBl = CrCanShoot | CrIsAiming | CrIsAnimate
+    | CrOpenAutoDoor
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 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,19 +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, _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/Door.hs

@@ -33,6 +33,7 @@ data Door = Door
     , _drZeroPos :: (Point2,Float)
     , _drOnePos :: (Point2,Float)
     , _drLerp :: Float
+    , _drOldLerp :: Float
     , _drFootPrint :: IM.IntMap (Point2,Point2)
     , _drHP :: Int
     , _drPushedBy :: PushSource
@@ -40,7 +41,10 @@ data Door = Door
     , _drMounts :: [MountedObject]
     }
 
-data DoorUpdate = DoorDoNothing | DoorLerp {_drLerpSpeed :: Float}
+data DoorUpdate 
+    = DoorDoNothing 
+    | DoorLerp {_drLerpSpeed :: Float}
+    | DoorLerpWithTimer {_drLerpTimer :: Int, _drLerpSpeed :: Float}
 
 
 makeLenses ''Door

src/Dodge/Data/DoubleTree.hs

@@ -5,11 +5,6 @@
 module Dodge.Data.DoubleTree where
 
 import Control.Lens
---import Data.Aeson
---import Data.Aeson.TH
-import Data.Bifunctor
-
---import qualified Data.Map.Strict as M
 
 data DoubleTreeNodeType
     = DTRootNode
@@ -18,67 +13,15 @@ data DoubleTreeNodeType
     | DTMidBelowNode
     | DTBottomNode
 
--- for each child, records the link type to the father node
-data LabelDoubleTreeNodeType a
-    = LDTRootNode
-    | LDTTopNode a
-    | LDTMidAboveNode a
-    | LDTMidBelowNode a
-    | LDTBottomNode a
-
 data DTree a = DT {_dtValue :: a, _dtLeft :: [DTree a], _dtRight :: [DTree a]}
     deriving (Eq, Ord, Show, Read)
 
-data LDTree b a = LDT -- LabelDoubleTree
-    { _ldtValue :: a
-    , _ldtLeft :: [(b, LDTree b a)]
-    , _ldtRight :: [(b, LDTree b a)]
-    }
-    deriving (Eq, Ord, Show, Read)
-
--- I am not sure about the double use of records here
-data ContextLDT b a
-    = TopLDT
-    | LeftwardLDT
-        { _cldtUp :: ContextLDT b a
-        , _cldtCloseLeft :: [(b, LDTree b a)]
-        , _cldtParent :: a
-        , _cldtLink :: b
-        , _cldtCloseRight :: [(b, LDTree b a)]
-        , _cldtFarRight :: [(b, LDTree b a)]
-        }
-    | RightwardLDT
-        { _cldtUp :: ContextLDT b a
-        , _cldtFarLeft :: [(b, LDTree b a)]
-        , _cldtCloseLeft :: [(b, LDTree b a)]
-        , _cldtParent :: a
-        , _cldtLink :: b
-        , _cldtCloseRight :: [(b, LDTree b a)]
-        }
-
-data LocationLDT b a = LocLDT
-    { _locLdtContext :: ContextLDT b a
-    , _locLDT :: LDTree b a
-    }
-
 instance Functor DTree where
     fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)
 
 instance Foldable DTree where
     foldMap f (DT x l r) = foldMap (foldMap f) l <> f x <> foldMap (foldMap f) r
 
-instance Functor (LDTree b) where
-    fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r)
-
-instance Bifunctor LDTree where
-    second = fmap
-    first f (LDT x l r) =
-        LDT
-            x
-            (map (bimap f (first f)) l)
-            (map (bimap f (first f)) r)
-
-
 data ContextDT a
     = TopDT
     | LeftwardDT
@@ -102,35 +45,12 @@ data LocationDT a = LocDT
     }
 
 makeLenses ''DTree
-makeLenses ''LDTree
-makeLenses ''LocationLDT
-makeLenses ''ContextLDT
 makeLenses ''LocationDT
 makeLenses ''ContextDT
 
-instance Functor (LocationLDT b) where
-    fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)
-
 instance Functor LocationDT where
     fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t)
 
-instance Functor (ContextLDT b) where
-    fmap f = \case
-        TopLDT -> TopLDT
-        LeftwardLDT u cl p l cr fr -> LeftwardLDT 
-            (fmap f u)
-            (fmap (fmap (fmap f)) cl)
-            (f p)
-            l
-            (fmap (fmap (fmap f)) cr)
-            (fmap (fmap (fmap f)) fr)
-        RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u)
-            (fmap (fmap (fmap f)) fl)
-            (fmap (fmap (fmap f)) cl)
-            (f p)
-            l
-            (fmap (fmap (fmap f)) cr)
-
 instance Functor ContextDT where
     fmap f = \case
         TopDT -> TopDT

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

@@ -24,7 +24,7 @@ import System.Random
 data GenWorld = GenWorld
     { _gwWorld :: World
     , _genRooms :: IM.IntMap Room
-    , _genPmnt :: IM.IntMap Placement
+    , _genPmnt :: IM.IntMap Placement  -- stored generated placements
     , _genInts :: IM.IntMap Int
     }
 
@@ -32,11 +32,10 @@ data GenWorld = GenWorld
 data PSType
     = PutCrit {_unPutCrit :: Creature}
     | PutMachine
-        { _putMachinePoly :: [Point2]
+        { _putMachineMachine :: Machine
-        , _putMachineMachine :: Machine
         , _putMachineMaybeItem :: Maybe Item
         }
-    | PutLS LightSource
+    | PutLS {_putLS :: LightSource}
     | PutButton {_putButton :: Button}
     | PutProp Prop
     | PutTerminal {_unputTerminal :: Terminal}
@@ -100,6 +99,8 @@ data PlacementSpot
     | PSNoShiftCont {_psPos :: Point2, _psRot :: Float}
     | PSPos
         { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
+        -- looks for the first rp for which a rp rm returns Just (ps,rp'),
+        -- replaces the rp with rp'
         , _psRoomEff :: RoomPos -> Room -> Room
         , _psFallback :: Maybe Placement
         }
@@ -138,7 +139,8 @@ data Room = Room
     , _rmPos :: [RoomPos]
     , _rmPath :: S.Set (Point2, Point2)
     , _rmPmnts :: [Placement]
-    , _rmInPmnt :: [(Int,GenWorld -> Placement)]
+    , _rmInPmnt :: [(Int,GenWorld -> State StdGen Placement)]  -- so far as I can tell,
+        -- the first Int only determines the order in which these are applied
     , _rmBound :: [[Point2]]
     , _rmFloor :: Floor
     , _rmName :: String
@@ -161,3 +163,12 @@ makeLenses ''RoomType
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement
+
+-- I may regret this. I believe it satisfies associativity, but haven't thought
+-- about it too much.
+instance Semigroup Placement where
+    p <> q = p & plIDCont %~ f
+      where
+        f g gw pl = case g gw pl of
+            Nothing -> Just q
+            Just r -> Just $ r & plIDCont %~ f

src/Dodge/Data/HUD.hs

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

src/Dodge/Data/Input.hs

@@ -3,6 +3,7 @@
 
 module Dodge.Data.Input where
 
+import Dodge.Data.CardinalPoint
 import Dodge.Data.Config
 import Dodge.Data.Terminal.Status
 import Control.Lens
@@ -14,10 +15,9 @@ data MouseContext
     = NoMouseContext
     | MouseAiming
     | MouseInGame
-    | MouseMenuClick {_mcoMenuClick :: Int}
+    | MouseMenu {_mcoMenuClick :: Maybe Int}
-    | MouseMenuCursor
+    | OverInvDrag {_mcoDragSection :: Int }
-    | OverInvDrag {_mcoDragSection :: Int , _mcoMaybeSelect :: Maybe (Int,Int) }
+    | OverInvDragSelect { _mcoSecSelStart :: XInfinity (Int,Int) }
-    | OverInvDragSelect { _mcoSecSelStart :: Maybe (Int,Int), _mcoSelEnd :: Maybe Int }
     | OverInvSelect { _mcoInvSelect :: (Int,Int)}
     | OverCombFiltInv { _mcoInvFilt :: (Int,Int)}
     | OverCombSelect { _mcoCombSelect :: (Int,Int)}
@@ -25,13 +25,14 @@ data MouseContext
     | OverCombFilter
     | OverCombEscape
     | OverTerminal {_mcoTermID :: Int, _mcoTermStatus :: TerminalStatus}
+    | OverTerminalBar {_mcoBarOffset :: Point2}
     | OutsideTerminal
-    | MouseGameRotate
+    | MouseGameRotate {_mcoRotateDist :: Float}  -- TODO warp mouse to this distance
     | OverDebug {_mcoDBBool :: DebugBool, _mcoDBInt :: Int}
     deriving (Show)
 
 data Input = Input
-    { _mousePos :: Point2 -- in pixels, from the center of the screen
+    { _mousePos :: Point2 -- in pixels, from the center of the screen, +ve up and right (I believe)
     , _mouseContext :: MouseContext
     , _mouseMoving :: Bool
     , _pressedKeys :: M.Map Scancode Int
@@ -46,8 +47,13 @@ data Input = Input
     , _textInput :: [Either TermSignal Char]
     , _scrollTestFloat :: Float
     , _scrollTestInt :: Int
+    , _inputMemory :: InputMemory
     }
 
+data InputMemory
+    = WasMouseGameRotating
+    | WasNotMouseGameRotating
+
 data TermSignal
     = TSescape
     | TSreturn

src/Dodge/Data/Item/Combine.hs

@@ -33,6 +33,7 @@ data ItemType
     | DETECTOR {_ibtDetector :: Detector}
     | ARHUD
     | LASER
+    | COMPASS
     deriving (Eq, Ord, Show, Read)
 
 data InventoryPathing
@@ -62,6 +63,7 @@ data CraftType
     | PUMP
     | MOTOR
     | TRANSFORMER
+    | BEAMSPLITTER
     | PRISM
     | LIGHTER
     | MAGNET
@@ -100,6 +102,7 @@ data AttachType
     | HOMINGMODULE
     | SHELLPAYLOAD {_shellPayload :: Payload}
     | CAPACITOR
+    | COMPRESSOR
     deriving (Eq, Ord, Show, Read)
 
 data AmmoMagType
@@ -163,8 +166,7 @@ data HeldItemType
     | FLAMETORRENT
     | FLAMEWALL
     | BLOWTORCH
-    | SPARKGUN
+    | TESLACOIL
-    | TESLAGUN
     | TRACTORGUN
     | RLAUNCHER
     | RLAUNCHERX {_xNum :: 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

@@ -3,34 +3,21 @@
 
 module Dodge.Data.Item.Use.Consumption.LoadAction where
 
+import Dodge.Data.AimStance
 import Dodge.Data.Item.Location
 import NewInt
 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
-        , _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

@@ -40,8 +40,10 @@ module Dodge.Data.LWorld (
     module Dodge.Data.Wall,
     module Dodge.Data.WorldEffect,
     module Dodge.Data.PulseLaser,
+    module Dodge.Data.PlasmaBall,
 ) where
 
+import Dodge.Data.PlasmaBall
 import ShapePicture.Data
 import Dodge.Data.PulseLaser
 import Dodge.Data.Equipment.Misc
@@ -94,6 +96,7 @@ data LWorld = LWorld
     , _creatureGroups :: IM.IntMap CrGroupParams
     , _items :: IM.IntMap Item
     , _clouds :: [Cloud]
+    , _beePheremones :: [BeePheremone]
     , _dusts :: [Dust]
     , _gasses :: [Gas]
     , _gusts :: IM.IntMap Gust
@@ -101,6 +104,7 @@ data LWorld = LWorld
     , _debris :: [Debris]
     , _projectiles :: IM.IntMap Projectile
     , _bullets :: [Bullet]
+    , _plasmaBalls :: [PlasmaBall]
     , _radarSweeps :: [RadarSweep]
     , _energyBalls :: [EnergyBall]
     , _flames :: [Flame]
@@ -142,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,9 +3,10 @@
 
 module Dodge.Data.Laser where
 
+import Dodge.Data.Damage
 import NewInt
 import Dodge.Data.Item.Location
-import Color
+--import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -20,8 +21,8 @@ data Laser = Laser
     { _lpPhaseV :: Float
     , _lpPos :: Point2
     , _lpDir :: Float
-    , _lpColor :: Color
     , _lpType :: LaserType
+    , _lpOrigin :: DamageOrigin
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Machine.hs

@@ -17,7 +17,6 @@ import Dodge.Data.AmmoType
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import qualified Data.IntSet as IS
 import qualified Data.Map.Strict as M
 import Dodge.Data.Damage
 import Dodge.Data.GenParams
@@ -26,11 +25,14 @@ import Dodge.Data.Machine.Sensor
 import Dodge.Data.Material
 import Dodge.Data.ObjectType
 import Geometry.Data
+import qualified Data.IntMap.Strict as IM
 
 data Machine = Machine
     { _mcID :: Int
-    , _mcWallIDs :: IS.IntSet
+--    , _mcWallIDs :: IS.IntSet
     , _mcMaterial :: Material
+    , _mcSkin :: Material
+    , _mcFootPrint :: IM.IntMap (Point2,Point2)
     , _mcPos :: Point2
     , _mcDir :: Float
     , _mcHP :: Int
@@ -40,8 +42,7 @@ data Machine = Machine
     }
 
 data MachineType
-    = McStatic
+    = McTerminal
-    | McTerminal
     | McDamSensor DamageSensor
     | McProxSensor ProximitySensor
     | McTurret {_mctTurret :: Turret, _mctTurretStun :: Int}
@@ -52,7 +53,6 @@ data MachineType
 
 instance ShortShow MachineType where
     shortShow = \case
-        McStatic -> "McStatic"
         McTerminal -> "McTerm"
         McDamSensor {} -> "McDamSen"
         McProxSensor {} -> "McProxSen"

src/Dodge/Data/Material.hs

@@ -17,6 +17,10 @@ data Material
     | Flesh
     | Electronics
     | ForceField
+    | Photovoltaic
+    | LightningRod
+    | Pyroelectric
+    | Piezoelectric
     deriving (Eq, Ord, Show, Bounded, Enum, Read) --Generic, Flat)
 
 deriveJSON defaultOptions ''Material

src/Dodge/Data/MountedObject.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Dodge.Data.MountedObject where
 
+import Control.Lens
 import ShapePicture.Data
 import Geometry.Data
 import Data.Aeson
@@ -13,4 +15,9 @@ data MountedObject
     | MountedSPic SPic
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+moPos :: ASetter' MountedObject Point3
+moPos f = \case
+    MountedLight p r c -> Identity $ MountedLight (runIdentity $ f p) r c
+    MountedSPic sp -> Identity . MountedSPic $ sp & spPos %~ (runIdentity . f)
+
 deriveJSON defaultOptions ''MountedObject

src/Dodge/Data/Muzzle.hs

@@ -40,6 +40,7 @@ data MuzzleEffect
     | MuzzleLaser
     | MuzzlePulseLaser
     | MuzzlePulseBall
+    | MuzzlePlasmaBall
     | MuzzleTesla
     | MuzzleTractor
     | MuzzleRLauncher

src/Dodge/Data/PlasmaBall.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Dodge.Data.PlasmaBall (module Dodge.Data.PlasmaBall) where
+
+import Dodge.Data.Damage
+import Control.Lens
+import Data.Aeson
+import Data.Aeson.TH
+import Geometry.Data
+
+data PlasmaBall = PBall
+    { _pbType :: PlasmaBallType
+    , _pbVel :: Point2
+    , _pbPos :: Point2
+    , _pbOrigin :: DamageOrigin
+    }
+    deriving (Show, Eq, Ord, Read) --Generic, Flat)
+
+data PlasmaBallType = DefaultPlasma
+    deriving (Show, Eq, Ord, Read) --Generic, Flat)
+
+makeLenses ''PlasmaBall
+deriveJSON defaultOptions ''PlasmaBallType
+deriveJSON defaultOptions ''PlasmaBall