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
-      -- texture
+    , -- | world position one along in the X direction
+      -- 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
-            & cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ CrIsGibs
+            & makeExplosionAt (CrIndirectO (cr ^. crID)) ((cr ^. crPos) & _z +~ 20) 0
+            & cWorld . lWorld . creatures . at (_crID cr) .~ Nothing
     _ -> w
   where
     f w' p = makeSpark NormalSpark (p + normalizeV p + cr ^. crPos . _xy) (argV p) w'
@@ -44,7 +43,7 @@ updateExpBarrel ps cr w = case cr ^. crHP of
 updateBarrel :: Creature -> World -> World
 updateBarrel cr = case cr ^. crHP of
     HP x | x > 0 -> doDamage (cr ^. crID)
-    HP _ -> cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ 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 #-}
---bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
+-- {-# INLINE bounceBall #-}
+-- 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
-    (p, n) <-
-        fst $
-            intersectCylSeg
-                (cr ^. crPos)
-                (crRad $ cr ^. crType)
-                h
-                sp
-                ep
+    let h = crHeight cr
+    (p, n) <- fst $ intersectCylSeg (cr ^. crPos) (crRad $ cr ^. crType) h sp ep
     return (p, Just (n, OCreature cr))
 
-crHeight :: Creature -> Maybe Float
+crHeight :: Creature -> Float
 crHeight cr = case cr ^. crHP of
-    HP{} -> Just 25
-    CrIsCorpse{} -> Just 5
-    CrIsGibs -> Nothing
-    CrIsPitted -> Nothing
+    HP{} -> case cr ^. crType of
+        HoverCrit {} -> 10
+        ChaseCrit {} -> 25
+        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
---{-# INLINE collidePointTestFilter #-}
---collidePointTestFilter t sp ep = runIdentity
+-- collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
+-- {-# INLINE collidePointTestFilter #-}
+-- 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 #-}
---overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+-- {-# INLINE overlapSegWalls #-}
+-- 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 
-    $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
+overlapSegWalls sp ep = IM.mapMaybe $
+    \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 ::
-    Point2 ->
-    Float ->
-    [Wall] ->
-    [(Point2, Wall)]
+overlapCircWalls :: Point2 -> Float -> [Wall] -> [(Point2, Wall)]
 {-# INLINE overlapCircWalls #-}
-overlapCircWalls p r = mapMaybe dointersect
+overlapCircWalls p r = mapMaybe g
   where
-    dointersect wl = f (_wlLine wl) <&> (,wl)
-    f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
+    g wl = f (_wlLine wl) <&> (,wl)
+    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
-            f
-            ( a +.+ rad *.* normalizeV (a -.- b)
-            , b +.+ rad *.* normalizeV (b -.- a)
+            ( f $ a + rad *^ normalizeV (a - b)
+            , f $ b + rad *^ normalizeV (b - a)
             )
       where
-        f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
+        f = (+ rad *^ normalizeV (vNormal $ a - b))
 
 overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
 {-# INLINE overlapCircWallsClosest #-}
-overlapCircWallsClosest 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
+overlapCircWallsClosest p r = safeMinimumOn (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
-    j <- _crInv (you w) ^? ix i
+    Sel 0 i <- w ^? hud . diSelection . _Just
+    j <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix (NInt i)
     w ^? cWorld . lWorld . items . ix j
 
 yourRootItem :: World -> Maybe Item
 yourRootItem w = do
-    i <- you w ^? crManipulation . manObject . imRootSelectedItem
-    j <- _crInv (you w) ^? ix i
+    i <- w ^? hud . manObject . hiRootSelectedItem
+    j <- w ^? cWorld . lWorld . creatures . ix 0 . crInv . ix i
     w ^? cWorld . lWorld . items . ix j
 
+yourRootItemDT :: World -> Maybe (DTree OItem)
+yourRootItemDT w = do
+    i <- 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/Block/Debris.hs

@@ -5,14 +5,17 @@ module Dodge.Block.Debris (
     makeBlockDebris,
     makeDebris,
     makeDebrisDirected,
+    makeMachineDebris,
 ) where
 
+import Control.Monad
+import Dodge.Machine.Draw
+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.Color
 import Dodge.Material.Sound
 import Dodge.ShiftPoint
 import Dodge.WorldEvent.Sound
@@ -23,8 +26,20 @@ 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
@@ -32,34 +47,62 @@ makeDoorDebris dr w = w & makeDebris mt p
         wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
         ((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
-        return $ _wlMaterial wl
+        w ^? cWorld . lWorld . walls . ix wlid
+
+blockDebrisType :: Maybe Wall -> Block -> DebrisType
+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 :: Material -> Point2 -> World -> World
+makeDebris :: DebrisType -> Material -> Point2 -> World -> World
 makeDebris = makeDebrisDirected (2 * pi) 0
 
-makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World
--- makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
--- makeDebrisDirected arcrad dir bm col p w =
-makeDebrisDirected arcrad dir bm p w =
+makeDebrisZ :: Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisZ = makeDebrisDirectedZ (2 * pi) 0
+
+makeDebrisDirectedZ :: Float -> Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisDirectedZ arcrad dir z dt bm p w =
     w
-        --        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
-        & cWorld
-        . lWorld
-        . debris
-        <>~ thedebris
-        & randGen
-        .~ newg
+        & 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
+        & cWorld . lWorld . debris <>~ thedebris
+        & randGen .~ newg
         & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
   where
     (thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w
@@ -70,10 +113,9 @@ makeDebrisDirected arcrad dir bm p w =
         return $
             DebrisChunk
                 { _dbPos = p `v2z` h
-                , --            , _dbType = BlockDebris col
-                  _dbType = BlockDebris (materialColor bm)
+                , _dbType = dt
                 , _dbVel = v `v2z` 0
-                , _dbRot = Q.qID
+                , _dbRot = Q.qid
                 , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
                 }
 
@@ -82,7 +124,7 @@ makeDebrisDirected arcrad dir bm p w =
 --                & prPos .~ p
 --                & prVel .~ v
 --                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
---                & prQuat .~ Q.qID
+--                & prQuat .~ Q.qid
 --                & prVelZ .~ 0
 --                & prPosZ .~ h
 

src/Dodge/Bullet.hs

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

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

src/Dodge/Creature/Action/Blink.hs

@@ -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 =
-            ActionPlan
-                { _apAction = []
-                , _apStrategy = FollowImpulses
-                , _apGoal = [Kill 0]
-                }
+--        , _crActionPlan =
+--            ActionPlan
+--                { _apAction = NoAction
+----                , _apStrategy = FollowImpulses
+--                , _apGoal = Kill 0
+--                }
         , _crGroup = ShieldGroup
 --        , _crMvType = defaultChaseMvType
         }

src/Dodge/Creature/ChaseCrit.hs

@@ -1,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
-        & crStance . strideLength .~ 30
+        & crActionPlan . apGoal .~ SearchForFood
+        & crActionPlan . apStrategy .~ Search
 
-chaseCritVocalization :: Vocalization
-chaseCritVocalization = Vocalization (50, 200) 0
+crabCrit :: Creature
+crabCrit = defaultCreature
+        & crName .~ "chaseCrit"
+        & crHP .~ HP 350
+        & crType .~ CrabCrit
+            { _meleeCooldownL = 0
+            , _meleeCooldownR = 0
+            , _dodgeCooldown = 0
+            , _lFootPos = 0
+            , _rFootPos = 0
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slinkCrit :: Creature
+slinkCrit = defaultCreature
+        & crName .~ "slinkCrit"
+        & crHP .~ HP 1000
+        & crType .~ SlinkCrit
+            { _meleeCooldown = 0
+            , _slinkSpine = replicate 15 (V3 0 0 2, Q.axisAngle (V3 0 1 0) (pi/15))
+            , _slinkHeadPos = (V3 20 0 15, Q.axisAngle (V3 0 1 0) (pi/2))
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slimeCrit :: Creature
+slimeCrit = defaultCreature
+        & crName .~ "slimeCrit"
+        & crHP .~ HP 1000
+--        & crType .~ SlimeCrit r 0 0 (V2 (slimeToRad r) 0) False 0
+        & crType .~ SlimeCrit r 0 NoSlimeDistortion 1 False 0
+        & crFaction .~ ColorFaction (light green)
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+        & crActionPlan .~ SlimeIntelligence
+        & crStance . carriage .~ Crawling
+  where
+    r = 250000
+
+hoverCrit :: Creature
+hoverCrit =
+    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 dms cr w = foldl' (applyIndividualDamage cr) w dms
+applyCreatureDamage :: Int -> Creature -> World -> World
+applyCreatureDamage cid cr w = foldl' (applyIndividualDamage cid cr) w (cr ^. crDamage)
 
-applyIndividualDamage :: Creature -> World -> Damage -> World
-applyIndividualDamage cr w dm = 
-    let (i,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
-    in w' & damageHP cr i
---  case dm of
---    Piercing{} -> applyPiercingDamage cr dm w
---    _ -> w & damageHP cr (_dmAmount dm)
+applyIndividualDamage :: Int -> Creature -> World -> Damage -> World
+applyIndividualDamage cid cr w (Inertial _ _ v _) = w 
+    & cWorld . lWorld . creatures . ix cid . crPos . _xy +~ fmap (/ crMass (cr ^. crType)) v
+applyIndividualDamage cid cr w dm = 
+    let (x,w') = damMatSideEffect dm (crMaterial (_crType cr)) (Left cr) w
+    in w' & damageHP cid x
 
---applyPiercingDamage :: Creature -> Damage -> World -> World
---applyPiercingDamage cr dm w
---    | crIsArmouredFrom (w ^. cWorld . lWorld . items) p cr 
---        = f . makeSpark NormalSpark p1 (argV (p1 - p)) $ w
---    | otherwise = f . damageHP cr (_dmAmount dm) $ w
---  where
---    f = cWorld . lWorld . creatures . ix (_crID cr) . crPos . _xy +~ _dmVector dm
---            / V2 x x
---    x = crMass (_crType cr)
---    p = _dmPos dm
---    p1 = p + 2 *.* squashNormalizeV (p - cr ^. crPos . _xy)
-
-damageHP :: Creature -> Int -> World -> World
-damageHP cr x =
-    (cWorld . lWorld . creatures . ix (_crID cr) . crHP . _HP -~ x)
-    . (cWorld . lWorld . creatures . ix (_crID cr) . crPain +~ x)
+damageHP :: Int -> Int -> World -> World
+damageHP cid x =
+    (cWorld . lWorld . creatures . ix cid . crHP . _HP -~ x)
+    . (cWorld . lWorld . creatures . ix cid . crPain +~ x)

src/Dodge/Creature/HandPos.hs

@@ -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 qualified Quaternion as Q
+import Dodge.Data.World
+import Control.Monad
+import qualified Data.IntMap.Strict as IM
+import Linear
 import Control.Lens
 import Dodge.Creature.Test
-import Dodge.Data.Creature
+import Dodge.Data.Equipment.Misc
 import Geometry
+import qualified Quaternion as Q
 import ShapePicture
 
-translateToES :: Creature -> EquipSite -> Point3 -> Point3
-translateToES cr es p = fst (equipSitePQ es cr `Q.comp` (p,Q.qID))
+translateToES :: World -> Creature -> EquipSite -> Point3 -> Point3
+translateToES w cr es p = fst (equipSitePQ es w cr `Q.comp` (p, Q.qid))
 
-equipSitePQ :: EquipSite -> Creature -> Point3Q
+equipSitePQ :: EquipSite -> World -> Creature -> Point3Q
 equipSitePQ = \case
     OnLeftWrist -> leftWristPQ
     OnRightWrist -> rightWristPQ
-    OnHead -> headPQ
-    OnChest -> chestPQ
-    OnBack -> backPQ
-    OnLeftLeg -> leftLegPQ
-    OnRightLeg -> rightLegPQ
+    OnHead ->  headPQ
+    OnChest ->  chestPQ
+    OnBack ->  backPQ
+    OnLeftLeg -> const $ legPQ LeftForward
+    OnRightLeg -> const $ legPQ RightForward
 
-translatePointToRightHand :: Creature -> Point3 -> Point3
-translatePointToRightHand cr p =  fst (rightHandPQ cr `Q.comp` (p,Q.qID))
+translatePointToRightHand :: World -> Creature -> Point3 -> Point3
+translatePointToRightHand w cr p = fst (rightHandPQ w cr `Q.comp` (p, Q.qid))
 
-rightHandPQ :: Creature -> Point3Q
-rightHandPQ cr
-    | oneH cr = (V3 11 (-3) 20, Q.qID)
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 4 (-10) 0,Q.qID)
-    | twoFlat cr = (V3 4 (-8) 10, Q.qID)
-    | otherwise = case cr ^? crStance . carriage of
-        Just (Walking sa LeftForward) -> (V3 (- f sa) (- off) 10, Q.qID)
-        Just (Walking sa RightForward) -> (V3 (- g sa) (- off) 10, Q.qID)
-        _ -> (V3 0 (- off) 10, Q.qID)
+strideLength :: Creature -> Float
+strideLength cr = case cr ^. crType of
+    Avatar{} -> 35
+    _ -> 30
+
+handWalkingPos :: FootForward -> Float -> Creature -> Point3
+handWalkingPos b off cr = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    (Just sa,Just ff) ->
+        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
-    sLen = _strideLength $ _crStance cr
-    f i = negate 2 + negate 6 * (sLen - i) / sLen
-    g i = negate 2 + negate 6 * i / sLen
+    cd = cr ^. crDir
+    rot = rotateV (negate cd)
 
-translateToRightHand :: Creature -> SPic -> SPic
-translateToRightHand = overPosSP . translatePointToRightHand
-
-rightWristPQ :: Creature -> Point3Q
-rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qID)
-
-leftHandPQ :: Creature -> Point3Q
-leftHandPQ cr
-    | oneH cr = (V3 0 off 10, Q.qz 0.4)
-    | twists cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
-    | twoFlat cr = (V3 4 8 10, Q.qID)
-    | otherwise = case cr ^? crStance . carriage of
-        Just (Walking sa RightForward) -> (V3 (- f sa) off 10 , Q.qID)
-        Just (Walking sa LeftForward) -> (V3 (- g sa) off 10 , Q.qID)
-        _ -> (V3 0 off 10, Q.qID)
+crLeftHandWall :: Creature -> Maybe Point2
+crLeftHandWall 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 < (pi / 8)
+    return $ ep & _xy %~ rot
   where
-    off = 8
-    sLen = _strideLength $ _crStance cr
-    f i = negate 2 + negate 6 * (sLen - i) / sLen
-    g i = negate 2 + negate 6 * i / sLen
+    cd = cr ^. crDir
+    rot = rotateV (negate cd)
 
-translatePointToLeftHand :: Creature -> Point3 -> Point3
-translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p,Q.qID))
+translateToRightHand :: World -> Creature -> SPic -> SPic
+translateToRightHand w = overPosSP . translatePointToRightHand w
 
-translateToLeftHand :: Creature -> SPic -> SPic
-translateToLeftHand = overPosSP . translatePointToLeftHand
+rightWristPQ :: World -> Creature -> Point3Q
+rightWristPQ w cr = rightHandPQ w cr `Q.comp` (V3 0 (-4) (-4), Q.qid)
 
-leftWristPQ :: Creature -> Point3Q
-leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qID)
+leftHandPQ :: World -> Creature -> Point3Q
+leftHandPQ w cr
+    | twists w cr = (V3 0 5 20, Q.qz (-1)) `Q.comp` (V3 12 4 0, Q.qz 0.4)
+    | twoFlat w cr = (V3 8 8 12, Q.qid)
+    | Just TwoHandTwist <- w ^? hud . manObject . hiAimStance
+        = (V3 (10 + twoHandOffY cr) 6 20, Q.qid)
+    | Just TwoHandFlat <- 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
-leftLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
-    (V3 x off 0,Q.qID)
-  where
-    x = case cr ^? crStance . carriage of
-        Just (Walking sa LeftForward) -> f sa
-        Just (Walking sa RightForward) -> - f sa
-        _ -> 0
-    off = 5
-    sLen = _strideLength $ _crStance cr
-    f i = 8 * (sLen - i) / sLen
-    
+twoHandOffY :: Creature -> Float
+twoHandOffY cr = zeroOneSmooth $ case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+    (Just sa,Just ff) ->
+        let slen = strideLength cr
+            f i
+                | ff == RightForward = (slen - i) / slen
+                | otherwise = i / slen
+         in f sa
+    _ -> 0
+
+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
-rightLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
-    (V3 x off 0,Q.qID)
+legPQ :: FootForward -> Creature -> Point3Q
+legPQ ff = case ff of
+    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
-        Just (Walking sa LeftForward) -> -f sa
-        Just (Walking sa RightForward) -> f sa
+    x = case (cr ^? crType . strideAmount,cr ^? crType . footForward) of
+        (Just sa,Just LeftForward) -> -f sa
+        (Just sa,Just RightForward) -> f sa
         _ -> 0
     off = -5
-    sLen = _strideLength $ _crStance cr
-    f i = 8 * (sLen - i) / sLen
+    sLen = strideLength cr
+    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 cr
-    | twists cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
-    | oneH cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
-    | otherwise = (V3 2.5 0 20, Q.qID)
+headPQ :: World -> Creature -> Point3Q
+headPQ w cr
+    | twists w cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
+    | oneH w cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
+    | otherwise = (V3 2.5 0 20, Q.qid)
 
---translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
---translatePointToHead m cr p = fst (headPQ cr `Q.comp` (p,Q.qID))
+chestPQ :: World -> Creature -> Point3Q
+chestPQ w cr = backPQ w cr `Q.comp` (0, Q.qz pi)
 
-chestPQ :: Creature -> Point3Q
-chestPQ cr = backPQ cr `Q.comp` (0,Q.qz pi)
-
-backPQ :: Creature -> Point3Q
-backPQ cr
-    | oneH cr = (V3 0 0 10, Q.qz 0.5)
-    | twists cr = (V3 0 3 10, Q.qz (-1.5))
+backPQ :: World -> Creature -> Point3Q
+backPQ w cr
+    | oneH w cr = (V3 0 0 10, Q.qz 0.5)
+    | twists w cr = (V3 0 3 10, Q.qz (-1.5))
     | otherwise = (V3 0 0 10, Q.qz 0)

src/Dodge/Creature/Impulse.hs

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

src/Dodge/Creature/Impulse/Movement.hs

@@ -3,11 +3,16 @@ module Dodge.Creature.Impulse.Movement (
     creatureTurnTowardDir,
     crMvAbsolute,
     crMvBy,
+    crWalk,
     crMvByNoStride,
     crMvForward,
+    crMvForward',
     creatureTurnTo,
+    mvTurnToward,
 ) where
 
+import Dodge.Creature.State.WalkCycle
+import Dodge.Creature.MoveType
 import Linear
 import Control.Lens
 import Dodge.Base
@@ -18,32 +23,37 @@ import Geometry
 {- | Creature attempts to moves under its own steam.
 The idea is that this may or may not work, depending on the status of the creature.
 For now, though, this cannot fail.
+p is the movement translation vector, will be made relative to creature direction
 -}
-crMvBy ::
-    -- | Movement translation vector, will be made relative to creature direction
-    Point2 ->
-    LWorld ->
-    Creature ->
-    Creature
+crMvBy :: Point2 -> World -> Creature -> Creature
 crMvBy p lw cr = crMvAbsolute lw (rotateV (_crDir cr) p) cr
 
-crMvByNoStride ::
-    -- | Movement translation vector, will be made relative to creature direction
-    Point2 ->
-    LWorld ->
-    Creature ->
-    Creature
+-- | p is the movement translation vector, made relative to creature direction
+crWalk :: Point2 -> World -> Creature -> Creature
+crWalk p lw cr = crWalkAbsolute lw (rotateV (_crDir cr) p) cr
+
+-- | p is the movement translation vector, made relative to creature direction
+crMvByNoStride :: Point2 -> World -> Creature -> Creature
 crMvByNoStride p lw cr = crMvAbsoluteNoStride lw (rotateV (_crDir cr) p) cr
 
-crMvAbsolute :: LWorld -> Point2 -> Creature -> Creature
-crMvAbsolute lw p' cr =
+crMvAbsolute :: World -> Point2 -> Creature -> Creature
+crMvAbsolute w p' cr =
       cr
         & crPos . _xy +~ p
-        & crMvDir .~ argV p
+        & 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,7 +56,7 @@ 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

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
-    AvatarDead -> defaultAimMvType
-    ChaseCrit {} -> defaultChaseMvType
+    Avatar {} -> MvWalking 1.5
+    SlinkCrit {} -> NoMvType
+    ChaseCrit {} -> defaultChaseMvType & mvSpeed .~ 1.8
+    CrabCrit {} -> defaultChaseMvType & mvSpeed .~ 0.5
+        & mvTurnJit .~ 0.01
+    HoverCrit {} -> defaultChaseMvType & mvSpeed .~ 0.16
     SwarmCrit -> defaultChaseMvType
     AutoCrit -> defaultAimMvType
     BarrelCrit {} -> defaultAimMvType
     LampCrit {} -> defaultAimMvType
+    SlimeCrit {} -> NoMvType
+    BeeCrit {} -> 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
-        , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
+        --, _mvTurnJit = 0.3
+        , _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 ::
-    -- | List of creature ids that may direct attention and awareness
-    [Int] ->
-    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
+-- | The [Int] is a list of creature ids that may direct attention and awareness
+perceptionUpdate :: [Int] -> World -> Creature -> Creature
+perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate w . basicAttentionUpdate is w
 
 {- | Update a creatures awareness based upon the creatures' current direction
  of attention
 -} -- TODO delete?
-basicAwarenessUpdate :: Creature -> Creature
-basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
+basicAwarenessUpdate :: World -> Creature -> Creature
+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]
-        maybeBark = fromMaybe id $ do
+        maybeBecomeCognizant = fromMaybe id $ do
             guard becomesCognizant
-            sid <- vocalizationTest cr
+--            guard $ cr ^. crVocalization == VocReady
             return $
-                crActionPlan . apAction
-                    .~ [ImpulsesList ([Bark sid] : replicate 5 thejitter)]
+                (crActionPlan . apStrategy .~ WarningCry) . 
+                (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 w cr = case _cpAttention $ _crPerception cr of
-    Fixated i ->
-        cr & crPerception . cpAwareness
-            %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
-    AttentiveTo is ->
-        cr
-            & crPerception . cpAwareness
-                %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
-            & maybeBark
-      where
-        oldAwareness = _cpAwareness $ _crPerception cr
-        newAwareness =
-            (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
-                oldAwareness
-        becomesCognizant =
-            any isCognizant $
-                IM.unionWith cogRaised oldAwareness newAwareness
-        thejitter = [RandomImpulse $ RandImpulseCircMove 3]
-        maybeBark = fromMaybe id $ do
-            guard becomesCognizant
-            guard $ cr ^? crVocalization . vcCoolDown == Just 0
-            let soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
-                numjits = fst $ randomR (15, 25) (_randGen w)
-            return $
-                (crActionPlan . apStrategy .~ WarningCry)
-                    . ( crActionPlan . apAction
-                            .~ [ ImpulsesList
-                                    ( [Bark soundid] :
-                                      replicate numjits thejitter
-                                        ++ [[ChangeStrategy $ CloseToMelee 0]]
-                                    )
-                               , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy)
-                               ]
-                      )
+--chaseCritAwarenessUpdate :: World -> Creature -> Creature
+--chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
+--    Fixated i ->
+--        cr & crPerception . cpAwareness
+--            %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
+--    AttentiveTo is ->
+--        cr
+--            & crPerception . cpAwareness
+--                %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
+--            & maybeBark
+--      where
+--        oldAwareness = _cpAwareness $ _crPerception cr
+--        newAwareness =
+--            (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
+--                oldAwareness
+--        becomesCognizant =
+--            any isCognizant $
+--                IM.unionWith cogRaised oldAwareness newAwareness
+--        thejitter = [RandomImpulse $ RandImpulseCircMove 3]
+--        maybeBark = fromMaybe id $ do
+--            guard becomesCognizant
+--            guard $ cr ^. crVocalization == VocReady
+--            let soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
+--                numjits = fst $ randomR (15, 25) (_randGen w)
+--            return $
+--                (crActionPlan . apStrategy .~ WarningCry)
+--                    . ( crActionPlan . apAction
+--                            .~ [ ImpulsesList
+--                                    ( [Bark soundid] :
+--                                      replicate numjits thejitter
+--                                        ++ [[ChangeStrategy $ CloseToMelee 0]]
+--                                    )
+--                               , 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 ::
-    -- | Creatures that may attract this creature's attention
-    [Int] ->
-    World ->
-    Creature ->
-    Creature
+basicAttentionUpdate :: [Int] -> World -> Creature -> Creature
 basicAttentionUpdate cids w cr =
     cr & crPerception . cpAttention
         .~ AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids)

src/Dodge/Creature/Picture.hs

@@ -3,84 +3,430 @@ Drawing of creatures.
 Takes into account damage etc.
 -}
 module Dodge.Creature.Picture (
-    basicCrPict,
-    deadScalp,
-    deadUpperBody,
-    deadFeet,
+    makeCorpse,
+    drawCreature,
 ) 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
-basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
+drawCreature :: World -> IM.IntMap Item -> Creature -> SPic
+drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $
+    case cr ^. crType of
+        _ | CrIsCorpse sp <- cr ^. crHP -> sp
+        _ | null (cr ^? crHP . _HP) -> mempty
+        BarrelCrit{} -> barrelShape
+        LampCrit{_lampHeight = h} -> lampCrSPic h
+        ChaseCrit{} -> noPic $ drawChaseCrit w cr
+        Avatar{} -> basicCrPict w m cr
+        SwarmCrit -> basicCrPict w m cr
+        AutoCrit -> basicCrPict w m cr
+        CrabCrit{} -> noPic $ drawCrabCrit w cr
+        HoverCrit{} -> noPic $ drawHoverCrit cr
+        SlinkCrit{} -> noPic $ drawSlinkCrit cr
+        SlimeCrit{} -> noPic $ drawSlimeCrit cr
+        BeeCrit{} -> noPic $ drawBeeCrit cr
+        HiveCrit{} -> drawHive
+  where
+    fallrot = case cr ^? crStance . carriage . carDir of
+        Just q -> _1 . each . sfVs . each %~ Q.rotate q
+        _ -> id
 
-crCamouflage :: Creature -> CamouflageStatus
-crCamouflage _ = FullyVisible
+drawSlimeCrit :: Creature -> Shape
+drawSlimeCrit cr =
+    colorSH green $
+        upperPrismPolyHalf Medium Typical (cr ^?! crType . slimeEngulfProgress + min 15 r) ps
+  where
+    r = slimeToRad $ cr ^?! crType . slimeSlime - cr ^?! crType . slimeSlimeChange
+    so = slimeOutline cr
+    ps = fromMaybe so $ do
+        SlimeDistortion x' qs _ <- cr ^? crType . slimeDistortion
+        let x = fromIntegral x'
+        guard $ length qs == 12
+        return $ zipWith (+) (fmap (0.1 * (10 - x) *^) so) (fmap (0.1 * x *^) qs)
 
-basicCrShape :: Creature -> Shape
-basicCrShape cr
-    | crCamouflage cr == Invisible = mempty
-    | otherwise =
-        scaleSH (V3 crsize crsize crsize) $
-            mconcat
-                [ colorSH (_skinHead cskin) . overPosSH (translateToES cr OnHead) $ scalp
-                , colorSH (_skinUpper cskin) $ upperBody cr
-                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
-                ]
+basicCrPict :: World -> IM.IntMap Item -> Creature -> SPic
+basicCrPict w m cr = drawEquipment w m cr <> noPic (basicCrShape w cr)
+
+basicCrShape :: World -> Creature -> Shape
+basicCrShape w cr =
+    scaleSH (V3 crsize crsize crsize) $
+        mconcat
+            [ colorSH (_skinHead cskin) . overPosSH (translateToES w cr OnHead) $ scalp
+            , colorSH (_skinUpper cskin) $ upperBody w cr
+            , rotmdir $ colorSH (_skinLower cskin) $ feet cr
+            ]
   where
     cskin = crShape $ _crType cr
     crsize = 0.1 * crRad (cr ^. crType)
     rotmdir = rotateSH (_crMvDir cr - _crDir cr)
 
+drawSlinkCrit :: Creature -> Shape
+drawSlinkCrit cr =
+    snd (foldl' f ((V3 0 0 0, Q.qid), mempty) $ cr ^?! crType . slinkSpine)
+        <> shead
+        & each . sfColor .~ cskin ^?! skinUpper
+  where
+    shead =
+        polyCirc 6 15
+            & upperPrismPoly Medium Important 10
+            & each . sfVs . each %~ Q.apply (cr ^?! crType . slinkHeadPos)
+    cskin = crShape $ _crType cr
+    f ((p, q), sh) (p', q') = ((p, q) `Q.comp` (p', q'), sh <> (g p' & each . sfVs . each %~ Q.apply (p, q)))
+    g _ = upperPrismPoly Medium Important 2 $ polyCirc 6 15
+
+drawHoverCrit :: Creature -> Shape
+drawHoverCrit cr =
+    colorSH
+        (_skinHead cskin)
+        (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
+        <> colorSH
+            (_skinUpper cskin)
+            (mconcat [overPosSH (Q.apply $ f a) $ upperBox Medium Typical 1 $ polyCirc 3 5 | a <- [0, pi / 2, pi, 1.5 * pi]])
+  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
-    Just (Walking sa LeftForward) ->
-        translateSHxy (f sa) off aFoot
-            <> translateSHxy (- f sa) (- off) aFoot
-    Just (Walking sa RightForward) ->
-        translateSHxy (- f sa) off aFoot
-            <> translateSHxy (f sa) (- off) aFoot
-    _ -> translateSHxy 0 off aFoot <> translateSHxy 0 (- off) aFoot
+feet cr = case (cr ^? crType . strideAmount, cr ^? crType . footForward) of
+    (Just sa, Just LeftForward) -> sh (f sa)
+    (Just sa, Just RightForward) -> sh (-f sa)
+    _ -> sh 0
   where
+    sh x = translateSHxy x off aFoot <> translateSHxy (-x) (-off) aFoot
     aFoot = upperPrismPolyST 10 $ polyCirc 3 4
     off = 5
-    sLen = _strideLength $ _crStance cr
-    --f i = 6 * (sLen - i) / sLen
-    f i = 8 * (sLen - 2*i) / sLen
+    sLen = strideLength cr
+    --    f i = 8 * (sLen - 2*i) / sLen
+    f i = 8 * oneSmooth ((sLen - 2 * i) / sLen)
+
+crabFeet :: World -> Creature -> Shape
+{-# INLINE crabFeet #-}
+crabFeet _ cr =
+    uncurryV translateSHxy rpos (afoot & each . sfVs . each %~ Q.rotate r1)
+        <> ( afoot
+                & each . sfVs . each %~ Q.rotate r2
+                & each . sfVs . each +~ V3 0 2 5
+           )
+        <> uncurryV translateSHxy rpos' (afoot & each . sfVs . each %~ Q.rotate r1')
+        <> ( afoot
+                & each . sfVs . each %~ Q.rotate r2'
+                & each . sfVs . each +~ V3 0 2 5
+           )
+        <> uncurryV translateSHxy lpos (afoot & each . sfVs . each %~ Q.rotate l1)
+        <> ( afoot
+                & each . sfVs . each %~ Q.rotate l2
+                & each . sfVs . each +~ V3 0 (-2) 5
+           )
+        <> uncurryV translateSHxy lpos' (afoot & each . sfVs . each %~ Q.rotate l1')
+        <> ( afoot
+                & each . sfVs . each %~ Q.rotate l2'
+                & each . sfVs . each +~ V3 0 (-2) 5
+           )
+  where
+    rpos = rot (cr ^?! crType . rFootPos - cxy)
+    rot = rotateV cdir
+    lpos = rot (cr ^?! crType . lFootPos - cxy)
+    f p q = q + 2 *^ (p - q)
+    cdir = -cr ^. crDir
+    cxy = cr ^. crPos . _xy
+    afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2
+    (r1, r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5)
+    rpos' = f (V2 0 10) rpos
+    (r1', r2') = spiderJoint (0 & _xy .~ rpos') (V3 0 2 5)
+    (l1, l2) = spiderJoint (0 & _xy .~ lpos) (V3 0 (-2) 5)
+    lpos' = f (V2 0 (-10)) lpos
+    (l1', l2') = spiderJoint (0 & _xy .~ lpos') (V3 0 (-2) 5)
+
+spiderJoint :: Point3 -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
+spiderJoint p q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a + b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
+  where
+    -- spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+
+    a = angleThreeSides 10 (distance p q) 10
+    b = angleVV3 (q - p) (V3 0 0 (-1))
+    c = argV $ (p - q) ^. _xy
+    f x = Q.qz c * x
+
+-- spiderJoint' :: Point3 -> Float -> Float -> Point3 -> (Q.Quaternion Float, Q.Quaternion Float)
+-- spiderJoint' p l1 l2 q = (f $ Q.axisAngle (V3 0 (-1) 0) (pi - (a+b)), f . Q.axisAngle (V3 0 (-1) 0) $ a - b)
+----spiderJoint p q = (Q.qz c, Q.axisAngle (V3 0 (-1) 0) $ a)
+--  where
+--    a = angleThreeSides 10 (distance p q) 10
+--    b = angleVV3 (q-p) (V3 0 0 (-1))
+--    c = argV $ (p-q) ^. _xy
+--    f x = Q.qz c * x
+
+makeCorpse :: World -> StdGen -> Creature -> SPic
+makeCorpse w g cr = case cr ^. crType of
+    HoverCrit{} -> noPic $ drawHoverCrit cr
+    ChaseCrit{} -> noPic $ chaseCorpse g cr
+    CrabCrit{} -> noPic $ crabCorpse g cr
+    BeeCrit{} -> noPic $ drawBeeCrit cr
+    _ ->
+        noPic
+            . scaleSH (V3 crsize crsize crsize)
+            $ mconcat
+                [ colorSH (_skinHead cskin) $ deadScalp cr
+                , colorSH (_skinUpper cskin) $ deadUpperBody w cr
+                , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+                ]
+  where
+    cskin = crShape $ _crType cr -- this should be fixed
+    crsize = 0.1 * crRad (cr ^. crType)
+    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
+
+chaseCorpse :: StdGen -> Creature -> Shape
+chaseCorpse g cr =
+    mconcat
+        [ colorSH (_skinUpper cskin) . upperPrismPolyHalfMI 0 $
+            polyCirc 3 12
+                & each %~ vNormal
+                & each . _y *~ 0.6
+        , colorSH (_skinUpper cskin) . overPosSH (Q.apply neckq) $
+            upperPrismPolyHalfMI 3 ((+ V2 8 0) . vNormal <$> trapTBH 2 5 8)
+        , colorSH
+            (_skinHead cskin)
+            (overPosSH (Q.apply headq) (upperBox Medium Important 2 [V2 0 (-4), V2 9 0, V2 0 4]))
+        , rotmdir $ colorSH (_skinLower cskin) $ deadFeet cr
+        ]
+  where
+    neckq = (V3 6 0 0, Q.qz a)
+    (a, g') = randomR (-2, 2) g
+    b = fst $ randomR (-2, 2) g'
+    cskin = crShape $ _crType cr -- this should be fixed
+    rotmdir = rotateSH (_crMvDir cr - _crDir cr)
+    headq = neckq `Q.comp` (V3 16 0 0, Q.qz b)
+
+crabCorpse :: StdGen -> Creature -> Shape
+crabCorpse g cr =
+    mconcat
+        [ colorSH (_skinUpper cskin) $
+            overPosSH
+                (Q.apply torsoq)
+                ( upperPrismPolyHalfMI 5 $
+                    polyCirc 4 10
+                        & each . _x *~ 0.6
+                )
+        , colorSH (_skinUpper cskin) $
+            overPosSH (Q.apply lclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 20 0 (-2) 2)
+                <> overPosSH (Q.apply rclawq) (upperPrismPolyHalfMI 4 $ rectNSWE 0 (-20) (-2) 2)
+        , colorSH (cskin ^?! skinLower) $
+            foldMap (mkfoot 5) (take 2 ps)
+                <> foldMap (mkfoot (-5)) (take 2 $ drop 2 ps)
+        , colorSH
+            (_skinHead cskin)
+            (overPosSH (Q.apply headq) (upperPrismPolyHalfMI 1 $ square 2))
+        ]
+  where
+    headq = torsoq `Q.comp` (V3 3 0 4, Q.qid)
+    torsoq = (V3 0 0 0, Q.qid)
+    lclawq = torsoq `Q.comp` (V3 2 8 1, Q.axisAngle (V3 1 0 0) (-0.1) * Q.qz la)
+    (la, g') = randomR (-2, 2) g
+    ra = fst $ randomR (-2, 2) g'
+    ps = evalState (replicateM 4 (randInCirc 9)) g
+    mkfoot y p =
+        let p' = 0 & _xy .~ p + V2 0 (3 * y)
+            (q1, q2) = spiderJoint (V3 0 y 0) p'
+         in (afoot & each . sfVs . each %~ Q.apply (V3 0 y 0, q1))
+                <> (afoot & each . sfVs . each %~ Q.apply (p', q2))
+    afoot = upperPrismPolyST 10 $ polyCirc 3 2
+    rclawq = torsoq `Q.comp` (V3 2 (-8) 1, Q.axisAngle (V3 1 0 0) 0.1 * Q.qz ra)
+    cskin = crShape $ _crType cr -- this should be fixed
 
 deadFeet :: Creature -> Shape
 {-# INLINE deadFeet #-}
 deadFeet = feet
 
-arms :: Creature -> Shape
+arms :: World -> Creature -> Shape
 {-# INLINE arms #-}
-arms cr =
+arms w cr =
     (^. _1) $
-        translateToRightHand cr aHand
-            <> translateToLeftHand cr aHand
+        translateToRightHand w cr aHand
+            <> translateToLeftHand w cr aHand
   where
-    aHand = noPic $ translateSHz (-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 = 
-        mconcat
-            [ translateSHxy 0 3 . rotateSH (negate 0.2) $ aShoulder
-            , translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
-            ]
-    aShoulder = scaleSH (V3 10 10 1) baseShoulder
+    tsh = ashoulder 3 (-0.2) <> ashoulder (-3) 0.2
+    ashoulder y a = translateSHxy 0 y . rotateSH a $ scaleSH (V3 10 10 1) baseShoulder
 
-deadUpperBody :: Creature -> Shape
-deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
+deadUpperBody :: World -> Creature -> Shape
+deadUpperBody w cr = deadRot cr . translateSHz (negate 10) . upperBody w $ cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
-baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
+-- baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
+baseShoulder = scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 
-upperBody :: Creature -> Shape
+upperBody :: World -> Creature -> Shape
 {-# INLINE upperBody #-}
-upperBody cr = arms cr <> shoulderSH (torso cr)
+upperBody w cr = arms w cr <> torso w cr
 
-shoulderSH :: Shape -> Shape
-shoulderSH = translateSHz 20
-
-drawEquipment :: IM.IntMap Item -> Creature -> SPic
+drawEquipment :: World -> IM.IntMap Item -> Creature -> SPic
 {-# INLINE drawEquipment #-}
-drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
+drawEquipment w m cr = foldMap (itemEquipPict w cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
+
+barrelShape :: SPic
+barrelShape = noPic $ cylinderPoly Medium Important (map (addZ 20) ps) (map (addZ 0) ps)
+  where
+    ps = polyCirc 3 10
+
+lampCrSPic :: Float -> SPic
+lampCrSPic h =
+    colorSH blue (upperBox Small Undesired h $ rectWH 5 5)
+        ST.:!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)

src/Dodge/Creature/Radius.hs

@@ -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
-                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
-                   ]
-            & crActionPlan . apStrategy .~ MeleeStrike
+--                        `DoActionThen` DoImpulses
+--                            [ChangeStrategy (CloseToMelee $ _crID tcr)]
+--            & crActionPlan . apStrategy .~ MeleeStrike
     | otherwise = cr
   where
     cpos = cr ^. crPos . _xy
     tpos = tcr ^. crPos . _xy
 
-setMvPos :: World -> Creature -> Creature
-setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
+setMvPosToTargetCr :: World -> Creature -> Creature
+setMvPosToTargetCr w cr = cr & crIntention . mvToPoint .~ mpos
   where
     int = _crIntention cr
     mtpos = do
@@ -80,17 +81,17 @@ attentionViewPoint w cr = do
     guard $ visionCheck cr (tcr ^. crPos . _xy) > 0
     tcr ^? crPos . _xy
 
-setTargetMv ::
-    -- | Function for determining target
-    (World -> Creature -> Maybe Creature) ->
-    World ->
-    Creature ->
-    Creature
-setTargetMv targFunc w cr =
-    maybe
-        cr
-        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
-        (targFunc w cr)
+--setTargetMv ::
+--    -- | Function for determining target
+--    (World -> Creature -> Maybe Creature) ->
+--    World ->
+--    Creature ->
+--    Creature
+--setTargetMv targFunc w cr =
+--    maybe
+--        cr
+--        (\ctarg -> cr & crIntention . mvToPoint ?~ (ctarg ^. crPos . _xy))
+--        (targFunc w cr)
 
 -- ugly
 flockACC :: World -> Creature -> Creature
@@ -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)]]
-                        )
-                & crVocalization . vcCoolDown .~ 10
+                        ) NoAction
+                & resetCrVocCoolDown w
                 & crActionPlan . apStrategy .~ WarningCry
       where
         thejitter = RandImpulseCircMove 3
         soundid = evalState (takeOne (crWarningSounds cr)) (_randGen w)
         numjits = fst $ randomR (15, 25) (_randGen w)
+    CloseToMelee _ | ma <- cr ^? crActionPlan . apAction , notpath ma -> cr
     _ -> case cr ^? crIntention . mvToPoint . _Just of
         Just p
             | dist (cr ^. crPos . _xy) p > crRad (cr ^. crType) ->
-                cr & crActionPlan . apAction .~ [PathTo p]
+                cr & crActionPlan . apAction .~ PathTo p (DoImpulses [ChangeStrategy Wander])
             | otherwise ->
-                cr & crActionPlan . apAction .~ [bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]]
-                    & crActionPlan . apStrategy .~ WatchAndWait
+                cr -- & crActionPlan . apAction .~ bfsThenReturn 500 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+                    & crActionPlan . apStrategy .~ Search
                     & crIntention . mvToPoint .~ Nothing
         _ -> viewTarget w cr
+  where
+    notpath = \case
+        Just NoAction -> False
+        Just PathTo {} -> False
+        Just AimAt {} -> False
+        _ -> True
 
-goToTarget :: World -> Creature -> Creature
-goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
-    Just p -> cr & crActionPlan . apAction .~ [PathTo p]
-    _ -> viewTarget w cr
+hoverCritMv :: World -> Creature -> Creature
+hoverCritMv w cr = case _apStrategy (_crActionPlan cr) of
+    WarningCry -> 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 x [] = [x]
-replaceNullWith _ xs = xs
-
-doStrategyActions :: Creature -> Creature
-doStrategyActions cr = case cr ^? crActionPlan . apStrategy of
-    Just (StrategyActions strat acs) ->
-        cr
-            & crActionPlan . apAction .~ acs
-            & crActionPlan . apStrategy .~ strat
-    _ -> cr
+--replaceNullWith :: a -> [a] -> [a]
+--replaceNullWith x [] = [x]
+--replaceNullWith _ xs = xs
 
 overrideInternal :: (Creature -> Bool) -> (Creature -> Creature) -> Creature -> Creature
 overrideInternal test update cr
@@ -215,16 +306,11 @@ searchIfDamaged cr
     | _crPain cr > 0
         && _apStrategy (_crActionPlan cr) == WatchAndWait =
         cr & crPerception . cpVigilance .~ Vigilant
-            & crActionPlan . apStrategy
-                .~ StrategyActions
-                    LookAround
-                    [ TurnToPoint (cr ^. crPos . _xy -.- unitVectorAtAngle (_crDir cr))
-                        `DoActionThen` 40 `WaitThen` bfsThenReturn 500
-                    ]
+            & crActionPlan . apStrategy .~ LookAround
     | otherwise = cr
 
-bfsThenReturn :: Int -> Action
-bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
+--bfsThenReturn :: Int -> Action
+--bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
 
 --    theaction
 --  where

src/Dodge/Creature/SentinelAI.hs

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

src/Dodge/Creature/Shape.hs

@@ -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
-    ChaseCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3) ChaseAI
-    SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3) SwarmAI
-    AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3) AutoAI
-    AvatarDead -> 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)
+    CrabCrit {} -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
+    HoverCrit {} -> Humanoid (greyN 0.9) (light blue) (greyN 0.3)
+    SwarmCrit -> Humanoid (greyN 0.9) (lightx4 yellow) (greyN 0.3)
+    AutoCrit -> Humanoid (greyN 0.9) (lightx4 red) (greyN 0.3)
+    SlinkCrit{} -> Humanoid (greyN 0.9) (dark . dark . dark $ orange) (greyN 0.3)
     BarrelCrit {} -> Barreloid
-    LampCrit {} -> NonDrawnCreature
+    LampCrit {} -> NoCreatureShape
+    SlimeCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)
+    BeeCrit {} -> NoCreatureShape
+    HiveCrit {} -> NoCreatureShape

src/Dodge/Creature/Slime.hs

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

src/Dodge/Creature/State.hs

@@ -4,6 +4,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
-applyPastDamages cr w
+crPainEffect :: Creature -> World -> World
+crPainEffect cr = case cr ^. crType of
+    HoverCrit {} -> hoverPainEffect cr
+    HiveCrit{} -> hivePainEffect cr
+    _ -> jitterPain cr
+
+
+hoverPainEffect :: Creature -> World -> World
+hoverPainEffect cr
+    | _crPain cr > 50 =
+                (cWorld . lWorld . creatures . ix (_crID cr) . crPain -~ 50)
+                . (cWorld . lWorld . creatures . ix (_crID cr) . crPos . _z %~ max 12 . subtract 1)
+    | otherwise = id
+
+
+hivePainEffect :: Creature -> World -> World
+hivePainEffect cr w
+    | _crPain cr > 0 = w & cWorld . lWorld . creatures . ix (cr ^. crID) . crPain %~ (max 0 . subtract 5)
+        & cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos & _xy +~ p & _z .~ 20) v 200
+        & randGen .~ g
+    | otherwise = w
+  where
+    (a,g') = randomR (0,2*pi) $ w ^. randGen
+    (b,g) = runState randOnUnitSphere g'
+    p = (crRad (cr ^. crType) + 5) *^ unitVectorAtAngle a
+    v = 3 *^ b
+
+jitterPain :: Creature -> World -> World
+jitterPain cr w
     | _crPain cr > 200 = dojitter 3 100
     | _crPain cr > 20 = dojitter 2 10
     | _crPain cr > 0 = dojitter 1 1
@@ -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 $
-        (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
-           . (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
-            . (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
+    return $ w
+       & (cWorld . lWorld . lights .:~ LSParam pos 150 0.3)
+       &     (cWorld . lWorld . lights .:~ LSParam (pos + V3 0 0 15) 50 0.3)
+       &      (cWorld . lWorld . items . ix itid . itConsumables . _Just -~ x)
   where
     itmtree = loc ^. locDT
-    (p, q) = locOrient loc cr
+    (p, q) = locOrient w loc cr
     x = 10
     isammolink AmmoMagSF{} = True
     isammolink _ = False
-    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
-updateWalkCycle cid w
-    | Just cr <- w ^? cWorld . lWorld . creatures . ix cid
-      , Walking x ff <- 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
+updateCarriage :: Int -> World -> World
+updateCarriage cid w = fromMaybe w $ do
+    cr <- w ^? cWorld . lWorld . creatures . ix cid
+    return $ updateCarriage' cid cr w (cr ^. crStance . carriage)
 
-resetStride :: Carriage -> Carriage
-resetStride = \case
-    Walking _ ff -> Walking 0 (normalGait ff)
-    x -> x
+updateCarriage' :: Int -> Creature -> World -> Carriage -> World
+updateCarriage' cid cr w = \case
+    Walking -> maybeTakeStep cid cr w 
+        & tocr . crPos . _xy +~ 0.5 *^ (cr ^. crOldPos - oop) ^. _xy
+        & chasmTestCliffPush walkCliffPush cr
+    Crawling -> w & chasmTestCliffPush walkCliffPush cr
+    Floating -> w
+    Flying {_zSpeed = dz} -> 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  cr = case cr ^. crType of
-    Avatar { _avIntelligence = x } -> x
-    AvatarDead -> 0
-    ChaseCrit {} -> 20
-    SwarmCrit -> 20
-    AutoCrit -> 20
-    BarrelCrit {} -> 0
-    LampCrit {} -> 0
+--crIntelligence :: Creature -> Int
+--crIntelligence  cr = case cr ^. crType of
+--    Avatar { _avIntelligence = x } -> x
+--    ChaseCrit {} -> 20
+--    CrabCrit {} -> 20
+--    HoverCrit {} -> 20
+--    SwarmCrit -> 20
+--    AutoCrit -> 20
+--    BarrelCrit {} -> 0
+--    LampCrit {} -> 0
+--    SlinkCrit{} -> 5
+--    SlimeCrit{} -> 1
+--    BeeCrit{} -> 20
     
 
-getCrMoveSpeed :: LWorld -> Creature -> Int
-getCrMoveSpeed lw cr = strFromHeldItem lw cr + strFromEquipment lw cr + crStrength cr
+getCrMoveSpeed :: World -> Creature -> Int
+getCrMoveSpeed w cr = strFromHeldItem w cr + strFromEquipment (w^.cWorld.lWorld) cr + crStrength cr
 
 strFromEquipment :: LWorld -> Creature -> Int
 strFromEquipment lw = sum . fmap equipmentStrValue . crCurrentEquipment lw
@@ -64,12 +70,12 @@ crCurrentEquipment lw = fmap f . _crEquipment
   where
     f i = lw ^?! items . ix (_unNInt i)
 
-strFromHeldItem :: LWorld -> Creature -> Int
-strFromHeldItem lw cr = fromMaybe 0 $ do
+strFromHeldItem :: World -> Creature -> Int
+strFromHeldItem w cr = fromMaybe 0 $ do
     Aiming {} <- cr ^? crStance . posture
-    is <- cr ^? crManipulation . manObject . imAttachedItems
+    is <- w^?hud . manObject . hiAttachedItems
     let js = IM.elems $ IM.restrictKeys  (cr ^. crInv . unNIntMap) is
-    return . negate . sum . fmap itemWeight $ IM.restrictKeys (lw ^. items) $ IS.fromList js
+    return . negate . sum . fmap itemWeight $ IM.restrictKeys (w ^.cWorld.lWorld. items) $ IS.fromList js
 
 itemWeight :: Item -> Int
 itemWeight it = case it ^. itType of

src/Dodge/Creature/Strategy.hs

@@ -1,27 +0,0 @@
-module Dodge.Creature.Strategy (
-    goToPostStrat,
-) where
-
-import Data.List
-import Dodge.Creature.Test
-import Dodge.Creature.Volition
-import Dodge.Data.Creature
-
-goToPostStrat :: Creature -> Strategy
-goToPostStrat cr = case find sentinelGoal $ _apGoal $ _crActionPlan cr of
-    Just (SentinelAt p _) ->
-        StrategyActions
-            (GetTo p)
-            [ DoActionThen (WaitThen 150 holsterIfAiming) $
-                DoActionThen
-                    (PathTo p)
-                    NoAction
-                    --     $ 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
-    Just (SentinelAt p _) -> dist p (cr ^. crPos . _xy) > 15
+crAwayFromPost cr = case _apGoal $ _crActionPlan cr of
+    SentinelAt p _ -> dist p (cr ^. crPos . _xy) > 15
     _ -> False
-  where
-    sentinelGoal (SentinelAt _ _) = True
-    sentinelGoal _ = False
 
-crInAimStance :: AimStance -> Creature -> Bool
-crInAimStance as cr = cr ^? crStance . posture . aimStance == Just as
+crInAimStance :: AimStance -> World -> Creature -> Bool
+crInAimStance as w cr = cr ^? crStance . posture == Just Aiming
+    && w ^? hud . manObject . hiAimStance == Just as
 
-oneH :: Creature -> Bool
+oneH :: World -> Creature -> Bool
 oneH = crInAimStance OneHand
 
-twoFlat :: Creature -> Bool
+twoFlat :: World -> Creature -> Bool
 twoFlat = crInAimStance TwoHandFlat
 
-twists :: Creature -> Bool
-twists cr = crInAimStance TwoHandUnder cr || crInAimStance TwoHandOver cr
+twists :: World -> Creature -> Bool
+twists = crInAimStance TwoHandTwist
 
 -- the use of crOldPos is because the damage position is calculated on the
 -- previous frame
 -- Not sure if it is a good idea
-crIsArmouredFrom :: IM.IntMap Item -> Point2 -> Creature -> Bool
-crIsArmouredFrom m p cr = fromMaybe False $ do
+crIsArmouredFrom :: IM.IntMap Item -> Point2 -> World -> Creature -> Bool
+crIsArmouredFrom m p w cr = fromMaybe False $ do
     NInt itid <- cr ^? crEquipment . ix OnChest
     ittype <- m ^? ix itid . itType
     return $
@@ -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 TwoHandUnder cr = negate 1
-        | crInAimStance TwoHandOver cr = negate 1
+        | crInAimStance OneHand w cr = 0.5
+        | crInAimStance TwoHandTwist w 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 qualified Data.List as List
+import Control.Monad
+import qualified IntMapHelp as IM
 import Data.Maybe
 import Dodge.Barreloid
--- import Dodge.Base.NewID
-import Dodge.Corpse.Make
+import Dodge.Base.You
 import Dodge.Creature.Action
-import Dodge.Creature.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
-    | CrIsCorpse _ <- cr ^. crHP = chasmTestCorpse cr
-    | null (cr ^? crHP . _HP) = id
-    | cr ^. crPos . _z < 0 = (tocr . crZVel -~ 0.5) . (tocr . crPos . _z +~ _crZVel cr)
-    | otherwise = updateLivingCreature cr
+    | cr ^. crPos . _z < negate 300 = (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature) 
+        . destroyAllInvItems cr
+    | otherwise = case cr ^. crHP of
+        CrIsCorpse{} -> cleardamage . updateCarriage (_crID cr) . applyCreatureDamage (_crID cr) cr
+        AvatarDestroyed{} -> id
+        HP{} -> cleardamage . updateLivingCreature cr
   where
-    tocr = cWorld . lWorld . creatures . ix (_crID cr)
+    cleardamage = cWorld . lWorld . creatures . ix (cr^.crID) . crDamage .~ mempty
 
 updateLivingCreature :: Creature -> World -> World
-updateLivingCreature cr =
-    chasmTestLiving cr . case _crType cr of
-        Avatar{} ->
-            (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
-                . crUpdate cid
-                . yourControl cr
-        LampCrit{} -> updateLampoid cr
-        BarrelCrit bt -> updateBarreloid bt cr
-        AvatarDead -> id
-        ChaseCrit{} -> \w ->
-            crUpdate cid . performActions cid $
-                over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
-        _ -> crUpdate cid
+updateLivingCreature cr = case cr ^. crType of
+    Avatar{} ->
+        (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
+            . crUpdate cid
+            . yourControl
+    LampCrit{} -> updateLampoid cr
+    BarrelCrit bt -> updateBarreloid bt cr
+    ChaseCrit{} -> crUpdate cid . performActions cid . setChaseCritKinematics cid . updateChaseCrit cid cr
+    CrabCrit{} -> crUpdate cid . performActions cid . crabCritInternal cid
+    AutoCrit{} -> crUpdate cid
+    SwarmCrit{} -> crUpdate cid
+    HoverCrit{} -> crUpdate cid . performActions cid . hoverCritHoverSound cr .
+            updateHoverCrit cid
+    SlinkCrit{} -> slinkCritUpdate cid
+    SlimeCrit{} -> updateSlimeCrit cid
+    BeeCrit{} -> crUpdate cid . performActions cid . updateBeeFromPheremones cr cid . updateBeeCrit cr cid
+    HiveCrit{} -> crUpdate cid . performActions cid . updateHiveCrit cr cid
   where
     cid = cr ^. crID
 
+updateHiveCrit :: Creature -> Int -> World -> World
+updateHiveCrit cr cid w
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees
+    , Just y <- cr ^? crType . hiveGestation
+    , y == 0 
+    , Just z <- cr ^? crType . hiveSlime
+    , z >= 400
+        = w 
+        & tocr . crType . hiveChildren %~ IS.insert nid
+        & tocr . crType . hiveGestation .~ 50
+        & cWorld . lWorld . creatures . at nid ?~ ncr
+        & tocr . crType . hiveSlime -~ 400
+    | Just x <- cr ^? crType . hiveChildren . to IS.size
+    , x < nbees = w
+        & tocr . crType . hiveGestation %~ (max 0 . subtract 1)
+    | otherwise = w
+  where
+    nbees = 15
+    tocr = cWorld . lWorld . creatures . ix cid
+    nid = IM.newKey $ w ^. cWorld . lWorld . creatures
+    ncr = beeCrit & crPos .~ (cr ^. crPos + (0 & _xy +~ 25))
+        & crID .~ nid
+        & crType . beeHive ?~ cid
+
+updateBeeFromPheremones :: Creature -> Int -> World -> World
+updateBeeFromPheremones cr cid w
+    | any f (w ^. cWorld . lWorld . beePheremones) = w 
+        & cWorld . lWorld . creatures . ix cid . crType . beeAggro .~ 300
+    | otherwise = w
+  where
+    f bp = distance (cr ^. crPos . _xy) (bp ^. bpPos . _xy) < 20
+
+updateBeeCrit :: Creature -> Int -> World -> World
+updateBeeCrit cr cid
+    | cr ^?! crType . beeAggro > 0 = updateAggroBee cr cid
+    | otherwise = beeLifespanCheck cr cid . updateCalmBee cr cid
+
+beeLifespanCheck :: Creature -> Int -> World -> World
+beeLifespanCheck cr cid
+    | Just ls <- cr ^? crType . beeLifespan
+    , Just x <- cr ^? crType . beeSlime
+    , ls < 1
+    , x < 5
+        = cWorld . lWorld . creatures . ix cid . crHP . _HP -~ 1
+    | otherwise = id
+
+updateAggroBee :: Creature -> Int -> World -> World
+updateAggroBee cr cid w
+    | Mounted{} <- cr ^. crStance . carriage = w & tocr . crStance . carriage .~ Flying 0 
+    | Just tcr <- atarget
+    , distance (tcr ^. crPos . _xy) (cr ^. crPos . _xy) < crRad (cr ^. crType) + crRad (tcr ^. crType) + 1
+    , nearZeroAngle (argV (tcr ^. crPos . _xy - cr ^. crPos . _xy) - cr ^. crDir) < pi / 2
+    , 0 <- cr ^?! crType . meleeCooldown
+        = w & tocr . crPos .~ (cr ^. crOldPos & _xy -~ 5 *^ unitVectorAtAngle (cr ^. crDir))
+            & tocr . crType . startStopMv .~ (cr ^?! to crMvType . mvPulseTime)
+            & cWorld . lWorld . creatures . ix (tcr ^. crID) . crDamage 
+                .:~ Blunt 50 (cxy + crRad (cr ^. crType) *^ vdir) vdir (CrMeleeO (cr ^. crID))
+            & tocr . crType . meleeCooldown .~ 20
+    | Just tcr <- atarget = w & tocr . crActionPlan . apStrategy .~ CloseToMelee (tcr ^. crID)
+        & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w & tocr . crType . beeAggro -~ 1
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+    | otherwise = w & tocr . crType . beeAggro -~ 1
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crType . meleeCooldown %~ (max 0 . subtract 1)
+        & randGen .~ g 
+  where
+    (p,g) = runState (randOnCirc 150) (w ^. randGen)
+    atarget = listToMaybe . sortOn (distance cxy . (^.crPos._xy)) . IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w
+    vdir = unitVectorAtAngle (cr ^. crDir)
+    cxy = cr ^. crPos . _xy
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = t (tcr ^. crType)
+        && isJust (tcr ^? crHP . _HP)
+        && hasLOS cxy (tcr ^. crPos . _xy) w
+    t = \case
+        Avatar{} -> True
+        ChaseCrit{} -> True
+        CrabCrit{} -> True
+        _ -> False
+
+-- do bees need to be able to see slime targets?
+-- if no path can be made, reset harvest action
+-- this should all be simplified
+-- should count how many are mounted on an individual slime, try for a different
+-- slime if too many
+updateCalmBee :: Creature -> Int -> World -> World
+updateCalmBee cr cid w 
+    | Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just x <- cr ^? crType . beeSlime 
+    , x >= 50 = w 
+        & tocr . crType . beeSlime -~ 50
+        & cWorld . lWorld . creatures . ix (hcr ^. crID) . crType . hiveSlime +~ 50
+    | Just x <- cr ^? crType . beeSlime 
+    , x < 50
+    , Just hcr <- gethive
+    , distance (cr ^. crPos . _xy) (hcr ^. crPos . _xy) < 30 
+    , Just ReturnToHive <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just ReturnToHive <- cr ^? crActionPlan . apStrategy = w 
+    | Just x <- cr ^? crType . beeSlime 
+    , x >= 1500 = starthivereturn
+        & randGen .~ gsa
+        & tocr . crType . beeLifespan %~ max 0 . subtract sa
+    | Just mid <- cr ^? crStance . carriage . mountID
+    , mountshakeoff mid = startsearch
+    | Nothing <- cr ^? crActionPlan . apStrategy . harvestTarget 
+    ,  xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g') <- runState (takeOne xs) (w ^. randGen) =
+         w & tocr . crActionPlan . apStrategy .~ HarvestFrom (tcr ^. crID)
+            & randGen .~ g'
+    | Just tid <- cr ^? crStance . carriage . mountID
+    , Just SlimeCrit{} <- w ^? cWorld . lWorld . creatures . ix tid . crType = w
+        & tocr . crType . beeSlime +~ sspeed
+        & cWorld . lWorld . creatures . ix tid . crType . slimeSlime -~ sspeed
+    | Just (tcr,ti) <- gettarg
+    , distance (cr ^. crPos . _xy) (tcr ^. crPos . _xy) < 0.8*crRad (tcr ^. crType) 
+    , Just d <- tcr ^? crType . slimeCompression
+        = w
+        & tocr . crStance . carriage .~ Mounted ti 
+            (oxyrot (tcr^.crDir) 
+                (oxyrot (-tcr^.crDir) (cr ^. crPos - tcr ^. crPos) & _x %~ (/d) & _y *~ d))
+        & tocr . crActionPlan . apAction .~ NoAction
+    | Just (tcr,_) <- gettarg = w
+            & tocr . crActionPlan . apAction .~ PathTo (tcr ^. crPos . _xy) NoAction
+    | Just (HarvestFrom{}) <- cr ^? crActionPlan . apStrategy = startsearch
+    | Just (SearchTimed 0) <- cr ^? crActionPlan . apStrategy = starthivereturn
+    | Just PathTo{} <- cr ^? crActionPlan . apAction = w
+        & tocr . crActionPlan . apStrategy . searchTimer %~ (max 0 . subtract 1)
+    | otherwise = startsearch
+  where
+    oxyrot a = over _xy (rotateV a)
+    (sa,gsa) = runState (takeOne [0,1]) (w ^. randGen)
+    starthivereturn = fromMaybe w $ do
+        hcr <- gethive
+        return $ w
+            & tocr . crActionPlan . apAction .~ PathTo (hcr ^. crPos . _xy) NoAction
+            & tocr . crActionPlan . apStrategy .~ ReturnToHive
+            & tocr . crStance . carriage %~ dounmount
+    dounmount x = case x of
+        Flying{} -> x
+        _ -> Flying 0
+    startsearch = w
+        & tocr . crActionPlan . apAction .~ PathTo (cxy + p) NoAction
+        & tocr . crStance . carriage %~ dounmount
+        & randGen .~ g
+        & tocr . crActionPlan . apStrategy .~ SearchTimed 200
+    (p,g) = runState (randOnCirc 200) (w ^. randGen)
+    cxy = cr ^. crPos . _xy
+    mountshakeoff mid = fromMaybe False $ do
+        mcr <- w ^? cWorld . lWorld . creatures . ix mid
+        x <- mcr ^? crType . slimeDistortion . sdTime
+        return $ x > 8
+    sspeed = 5
+    gettarg = do
+        i <- cr ^? crActionPlan . apStrategy . harvestTarget 
+        tcr <-  w ^? cWorld . lWorld . creatures . ix i
+        x <- tcr ^? crType . slimeSlime . to slimeToRad
+        guard $ x > 12
+        return (tcr,i)
+    gethive = do
+        i <- cr ^? crType . beeHive . _Just
+        w ^? cWorld . lWorld . creatures . ix i
+    tocr = cWorld . lWorld . creatures . ix cid
+    istarget tcr = fromMaybe False $ do
+        r <- tcr ^? crType . slimeSlime . to slimeToRad
+        return $ r > 12
+
+updateSlimeCrit :: Int -> World -> World
+updateSlimeCrit cid w 
+    | cr ^?! crType . slimeSlime < 2500 
+        = w & cWorld . lWorld . creatures . at cid .~ Nothing
+    | Just hitp <- w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmPos
+        , Just hitv <-  w ^? cWorld . lWorld . creatures . ix cid . crDamage . ix 0 . dmVector
+        , Just w' <- splitSlimeCrit' hitp hitv cid cr w = w'
+    | (cr ^?! crType . slimeIsCompressing) && 1 > p
+        = let (w',g) = runState (setSlimeDir cid cr w) (w ^. randGen)
+            in w' & randGen .~ g
+    | otherwise = updateCarriage cid $ w
+        & cWorld . lWorld . creatures . ix cid %~ mvslime
+        & cWorld . lWorld . creatures . ix cid . crDamage .~ []
+        & tocr %~ doSlimeRadChange
+        & tocr . crType . slimeDistortion %~ fsst
+        & tocr . crType . slimeEngulfProgress %~ (max 0 . subtract 0.5)
+  where
+    fsst (SlimeDistortion x ps t) | x > 0 = SlimeDistortion (x-1) ps t
+    fsst _ = NoSlimeDistortion
+    tocr = cWorld . lWorld . creatures . ix cid
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    mvslime cr' = cr' & crType . slimeCompression +~ f (0.1/r)
+        & crPos . _xy +~ 0.1 *^ unitVectorAtAngle (cr' ^. crDir)
+        & crType . slimeIsCompressing %~ f'
+    f | cr ^?! crType . slimeIsCompressing = negate
+      | otherwise = id
+    f'  | p > 1.5 = const True
+        | otherwise = id
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    p = cr ^?! crType . slimeCompression
+
+setSlimeDir :: Int -> Creature -> World -> State StdGen World
+setSlimeDir cid cr w = do
+    i <- state $ randomR (0,1)
+    d <- state $ randomR (0,2*pi)
+    if i < (r - 11) / 50
+        then do
+            x <- randInCirc 1
+            return $ fromMaybe w $ splitSlimeCrit' (x + cxy) (unitVectorAtAngle d) cid cr w
+        else return $ w & tocr . crDir .~ d
+                & tocr . crType . slimeIsCompressing .~ False
+                & tocr . crDamage .~ mempty
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+
+doSlimeRadChange :: Creature -> Creature
+doSlimeRadChange = crType . slimeSlimeChange %~ f
+  where
+    f x | x > 1000 = x - 1000
+        | x < -1000 = x + 1000
+        | otherwise = 0
+
+splitSlimeCrit' :: Point2 -> Point2 -> Int -> Creature -> World -> Maybe World
+splitSlimeCrit' p v cid cr w = do
+    (cr1,cr2) <- splitSlimeCrit p v cr
+    let cid' = IM.newKey $ w ^. cWorld . lWorld . creatures
+        (s,g) = runState (takeOne [popS,pop1S,pop2S,pop3S]) (w ^. randGen)
+    return $ w & cWorld . lWorld . creatures . ix cid .~ cr1
+            & cWorld . lWorld . creatures . at cid' ?~ (cr2 & crID .~ cid')
+            & soundStart (CrSound cid) (cr ^. crPos . _xy) s Nothing
+            & randGen .~ g
+
+splitSlimeCrit :: Point2 -> Point2 -> Creature -> Maybe (Creature, Creature)
+splitSlimeCrit p v cr = do
+    let mp = closestPointOnLine p (p+v) cxy
+        h = r - distance mp cxy
+    guard $ h > 0
+    let a1 = segmentArea r h
+        a2 = pi*r*r - a1
+        r1 = sqrt (a1/pi)
+        r2 = sqrt (a2/pi)
+        mvdir 
+            | isLHS p (p+v) cxy = normalize (vNormal v)
+            | otherwise = - normalize (vNormal v)
+        (ps',qs') 
+            | isLHS p (p+v) cxy = (ps,qs)
+            | otherwise = (qs,ps)
+        c1 = cr' & crPos . _xy .~ mp + r1 *^ mvdir
+                & crType . slimeSlime .~ round (r1 ^ (2 :: Int) * 100)
+                & crDir .~ argV mvdir
+        c2 = cr' & crPos . _xy .~ mp - r2 *^ mvdir
+                & crType . slimeSlime .~ round (r2^(2::Int) * 100)
+                & crDir .~ argV (-mvdir)
+        c1ps = qs' & each +~ cxy - (mp + r1 *^ mvdir) & each %~ rotateV (- c1 ^. crDir)
+        c2ps = ps' & each +~ cxy - (mp - r2 *^ mvdir) & each %~ rotateV (- c2 ^. crDir)
+    return (c1 & crType . slimeDistortion . sdShape .~ f c1ps c1
+        ,c2 & crType . slimeDistortion . sdShape .~ f c2ps c2
+        )
+  where
+    f xs@(_:_) c = polyInPoly (centroid xs) xs (slimeOutline c)
+    f _ _ = mempty
+    cxy = cr ^. crPos . _xy
+    r = cr ^?! crType . slimeSlime . to slimeToRad
+    cr' = cr & crDamage .~ []
+        & crType . slimeSlimeChange .~ 0
+        & crType . slimeDistortion .~ SlimeDistortion 10  mempty True
+        & crType . slimeIsCompressing .~ False
+        & crType . slimeCompression .~ 1
+    (ps,qs) = cutPoly (p-cxy) (p+v-cxy) $ slimeOutline cr & each %~ rotateV (cr ^. crDir)
+    
+-- h is the height of the segment, ie r - distance to center
+segmentArea :: Float -> Float -> Float
+segmentArea r h = r*r*acos(1-h/r) - (r-h)*sqrt(h*(2*r-h))
+
+slinkCritUpdate :: Int -> World -> World
+slinkCritUpdate cid w =
+    w
+        & cWorld
+        . lWorld
+        . creatures
+        . ix cid
+        . crType
+        . slinkSpine
+        . each
+        . _2
+        *~ Q.axisAngle (V3 0 1 0) (pi / 1000)
+
+setChaseCritKinematics :: Int -> World -> World
+setChaseCritKinematics cid w = w
+    & cWorld . lWorld . creatures . ix cid %~ setChaseCritKinematics' w
+
+ccAngles :: World -> Creature -> (Float,Float,Float,Float)
+ccAngles w cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f (-a) 0 0
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy = fromMaybe (0,0,0,0) $ do
+        tcr <- w ^? cWorld . lWorld . creatures . ix i
+        let tp = tcr ^. crPos + V3 0 0 (crMid tcr)
+            (np,_) = (cr ^. crPos, Q.qz (cr ^. crDir)) 
+                `Q.comp` (V3 8 0 14, Q.qid)
+            v = tp - np
+            a = angleVV3 v (v & _z .~ 0)
+        return $ f 
+            (0.45*pi - a)
+            (-0.9*pi)
+            (0.45*pi)
+    | otherwise = f (0.6*pi) (-0.2*pi) (-0.4*pi)
+  where
+    f a b c = (0,a,b,c)
+
+ccKState :: World -> Creature -> ChaseKState
+ccKState _ cr
+    | Eat i _ <- cr^?!crActionPlan.apAction = PeckingCK i
+    | CloseToMelee i <- cr^?!crActionPlan.apStrategy = AimingCK i
+    | otherwise = UprightCK
+
+setChaseCritKinematics' :: World -> Creature -> Creature
+setChaseCritKinematics' w = f . g
+  where
+    g cr | ccKState w cr == cr ^?! crType . chaseKState = cr
+        | PeckingCK i <- ccKState w cr = cr
+            & crType . chaseLerp .~ 3
+            & crType . chaseKState .~ PeckingCK i
+        | otherwise = cr & crType . chaseLerp .~ 20
+            & crType . chaseKState .~ ccKState w cr
+    f cr = 
+        let (a,b,c,d) = ccAngles w cr
+            x = cr ^?! crType . chaseLerp
+        in if x <= 1
+            then cr & crType . chaseqy0 .~ a
+              & crType . chaseqy1 .~ b
+              & crType . chaseqy2 .~ c
+              & crType . chaseqy3 .~ d
+            else cr 
+              & crType . chaseqy0 %~ h x a
+              & crType . chaseqy1 %~ h x b
+              & crType . chaseqy2 %~ h x c
+              & crType . chaseqy3 %~ h x d
+              & crType . chaseLerp -~ 1
+    h x a b = 1/fromIntegral x * a + (1-1/fromIntegral x) * b
+
+updateChaseCrit :: Int -> Creature -> World -> World
+updateChaseCrit cid cr 
+    | SearchForFood <- cr ^?! crActionPlan . apGoal = updateFoodSearchChaseCrit cid cr
+    | Flee <- cr^?!crActionPlan.apGoal
+        , NoAction <- cr^?!crActionPlan.apAction = tocr.crActionPlan.apGoal.~SearchForFood
+    | Flee <- cr^?!crActionPlan.apGoal = id
+    | otherwise = updateCalmChaseCrit cid
+  where
+    tocr = cWorld.lWorld.creatures.ix cid
+
+updateFoodSearchChaseCrit :: Int -> Creature -> World -> World
+updateFoodSearchChaseCrit cid cr w 
+    | (tcr:_) <- sortOn f . IM.elems . IM.filter avoidcr $ crsNearCirc cxy 60 w 
+        = let p = fleePoint cr cxy (20 *^ normalize (cxy - tcr^.crPos._xy)) w
+          in w &tocr.crActionPlan.apAction.~PathTo p NoAction
+                &tocr.crActionPlan.apGoal.~Flee
+    | Eat i 0 <- cr^?! crActionPlan.apAction = w
+            & cWorld .lWorld.creatures . at i .~ Nothing
+            & tocr . crActionPlan.apAction.~NoAction
+            & tocr . crActionPlan.apStrategy.~Search
+    | Eat i x <- cr^?! crActionPlan.apAction = w
+            & tocr .crActionPlan.apAction.acTimer-~1
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Nothing <- w ^?cWorld.lWorld.creatures.ix i = w & tocr . crActionPlan.apStrategy .~ Search
+    | CloseToMelee i<-cr^?!crActionPlan.apStrategy 
+        ,Just tcr <-w^?cWorld.lWorld.creatures.ix i
+        ,distance cxy (tcr^.crPos._xy) < 15 = w
+            & tocr.crActionPlan.apAction.~Eat i 5
+--            & tocr.crActionPlan.apAction.~NoAction
+--            & tocr.crActionPlan.apStrategy.~Search
+--            & cWorld.lWorld.creatures.at i.~Nothing
+    | CloseToMelee{}<-cr^?!crActionPlan.apStrategy 
+        ,PathTo{}<-cr^?!crActionPlan.apAction= w
+    | xs@(_:_) <- IM.elems . IM.filter istarget $ crsNearCirc cxy 100 w 
+    , (tcr,g) <- runState (takeOne xs) (w ^. randGen) = w&tocr.crActionPlan.apAction.~DoImpulses[MvForward]
+        &tocr.crActionPlan.apStrategy.~CloseToMelee (tcr^.crID)
+        &tocr.crActionPlan.apAction.~PathTo (tcr^.crPos._xy) NoAction
+        &randGen.~g
+    | otherwise = w
+  where
+    f c = fromMaybe 100 $ do
+        s <- cr^?crType.slimeSlime
+        return $ dist cxy (c^.crPos._xy) - sqrt(0.01*fromIntegral s)
+    tocr = cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    avoidcr c | ct@SlimeCrit{} <- c^.crType = distance cxy (c^.crPos._xy)-crRad ct < 10
+        | otherwise = False
+    istarget tcr 
+        | BeeCrit{} <- tcr^.crType 
+        , CrIsCorpse{} <- tcr^.crHP = True
+        | otherwise = False
+    
+fleePoint :: Creature -> Point2 -> Point2 -> World -> Point2
+fleePoint c p v w = g . minimum $ f <$> [p+v, p+0.9*^vNormal v, p-0.9*^vNormal v]
+  where
+    f ep = let q = walkablePoint c p ep w
+            in Semi.Arg (-distance q p) q
+    g (Semi.Arg _ x) = x
+
+
+updateCalmChaseCrit :: Int -> World -> World
+updateCalmChaseCrit cid w = w
+    & tocr %~ overrideMeleeCloseTarget w
+    & tocr %~ setViewPos w
+    & tocr %~ setMvPosToTargetCr w
+    & tocr %~ chaseCritMv w
+    & tocr %~ perceptionUpdate [0] w
+    & tocr %~ targetYouWhenCognizant w
+    & tocr %~ searchIfDamaged
+    & tocr . crType . meleeCooldown %~ max 0 . subtract 1
+    & tocr . crVocalization %~ updateVocTimer
+  where
+    tocr = cWorld . lWorld . creatures . ix cid
+
+
+hoverCritHoverSound :: Creature -> World -> World
+hoverCritHoverSound cr w
+    | 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 > -200 && _crDeathTimer cr > 0 ->
-            w
-                & tocr . crDamage .~ []
-                & tocr . crDeathTimer -~ 1
+    HP x | x > 0 -> w
+    HP x | x > -200 && null (cr ^. crDeathTimer) -> w & tocr %~ startDeathTimer
+    HP x
+        | x > -200
+        , Just y <- cr ^. crDeathTimer
+        , y > 0 -> w & tocr . crDeathTimer . _Just -~ 1
     HP _ ->
         w
             & dropAll cr -- the order of these is possibly important
             & stopSoundFrom (CrWeaponSound (_crID cr) 0)
             & corpseOrGib cr
+            & crDeathEffects cr
+            & tocr . crStance . carriage %~ toDeathCarriage
     _ -> w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
+crDeathEffects :: Creature -> World -> World
+crDeathEffects cr w = case cr ^. crType of
+    BeeCrit {_beeHive = mhid} -> beepheremone $ fromMaybe w $ do
+        hid <- mhid
+        return $ w & cWorld . lWorld . creatures . ix hid . crType . hiveChildren %~ IS.delete (cr ^. crID)
+    _ -> w
+  where
+    beepheremone 
+        | Just x <- cr ^? crType . beeLifespan
+        ,   x < 1 = id
+        | otherwise = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos) (cr ^. crPos - cr ^. crOldPos) 200
+
+startDeathTimer :: Creature -> Creature
+startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of
+            HoverCrit{} -> 0
+            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
-    Just CookingDamage ->
-        sethp (CrIsCorpse $ scorchSPic thecorpse)
-            . dodeathsound CookDeath
-    Just PoisonDamage ->
-        sethp (CrIsCorpse $ poisonSPic thecorpse)
-            . dodeathsound PoisonDeath
-    Just PhysicalDamage
-        | _crPain cr > 200 ->
-            addCrGibs cr
-                . sethp CrIsGibs
-                . dodeathsound GibsDeath
-    _ ->
-        sethp (CrIsCorpse thecorpse)
-            . dodeathsound PlainDeath
+corpseOrGib cr w =
+    w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
+        Just CookingDamage ->
+            sethp (CrIsCorpse $ scorchSPic thecorpse)
+                . dodeathsound CookDeath
+        Just PoisonDamage ->
+            sethp (CrIsCorpse $ poisonSPic thecorpse)
+                . dodeathsound PoisonDeath
+        Just PhysicalDamage
+            | _crPain cr > 300 ->
+                makeCrGibs cr
+                    . (cWorld . lWorld . creatures . at (cr ^. crID) %~ destroyCreature)
+                    . dodeathsound GibsDeath
+        _ ->
+            sethp (CrIsCorpse thecorpse)
+                . dodeathsound PlainDeath
   where
     dodeathsound dt = f dt . stopSoundFrom (CrMouth cid)
-    f dt w = fromMaybe w $ do
-        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w)
+    f dt w' = fromMaybe w' $ do
+        let (msid, g) = runState (maybeTakeOne (crDeathSounds cr dt)) (_randGen w')
         sid <- msid
         return $
-            w
+            w'
                 & soundStart (CrMouth cid) (cr ^. crPos . _xy) sid Nothing
-                & randGen .~ g
+                & randGen
+                .~ g
     cid = cr ^. crID
     sethp x = cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ x
-    thecorpse = makeCorpse cr
+    thecorpse = makeCorpse w (w ^. randGen) cr
 
 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)
@@ -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
-vocalizationTest cr = case cr ^? crVocalization . vcCoolDown of
-    Just 0 -> crVocalizationSound cr
-    _ -> Nothing
+hoverDeathSounds :: DeathType -> [SoundID]
+hoverDeathSounds = \case
+    CookDeath -> mempty
+    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
-    Just (i, j) -> cr & crVocalization . vcCoolDown .~ x
-      where
-        x = fst $ randomR (i, j) (_randGen w)
-    Nothing -> cr
+resetCrVocCoolDown w cr = cr & crVocalization .~ VocTimer 0 (crVocalResetTime cr (w ^. randGen))

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 _ w
+yourControl :: World -> World
+yourControl w
     | inTextInputFocus w = w
-    | Just x <- w ^? hud . subInventory
-      , f x =
+    | NoSubInventory <- w ^. hud . subInventory =
         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
-      , Just invid <- lw ^? creatures . ix 0 . crManipulation . manObject . imSelectedItem
-      , Just itid <- lw ^? creatures . ix 0 . crInv . ix invid =
+    , (hk : _) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
+    , Just (Sel 0 invid) <- w ^. hud .diSelection
+    , Just itid <- lw ^? creatures . ix 0 . crInv . ix (NInt invid) =
         w & cWorld . lWorld %~ assignHotkey (NInt itid) hk
     | ispressed SDL.ScancodeLCtrl || ispressed SDL.ScancodeRCtrl
-      , (hk:_) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
-      , Just itid <- lw ^? hotkeys . ix hk . unNInt
-      , Just invid <- lw ^? items . ix itid . itLocation . ilInvID =
+    , (hk : _) <- mapMaybe scancodeToHotkey . M.keys $ pkeys
+    , Just itid <- lw ^? hotkeys . ix hk . unNInt
+    , Just invid <- lw ^? items . ix itid . itLocation . ilInvID =
         w & invSetSelectionPos 0 (_unNInt invid)
-    | otherwise =
-        M.foldl'
-            useHotkey
-            w
-            (M.intersectionWith (,) thehotkeys (w ^. input . pressedKeys))
+    | otherwise = M.foldl' useHotkey w pressedhotkeys
   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
-
---modifierKeys :: S.Set SDL.Scancode
---modifierKeys = S.fromList 
---    [ SDL.ScancodeLShift
---    , SDL.ScancodeRShift
---    , SDL.ScancodeRCtrl
---    , SDL.ScancodeLCtrl
---    ]
+    pressedhotkeys = M.intersectionWith (,) thehotkeys (w ^. input . pressedKeys)
 
 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
-      , Nothing <- inp ^? mouseButtons . ix SDL.ButtonLeft =
-        setAimPosture (w ^. cWorld . lWorld . items) cr
-    | SDL.ButtonRight `M.member` _mouseButtons inp =
-        aimTurn (w ^. cWorld . lWorld) mousedir cr
-    | Aiming {} <- cr ^. crStance . posture = removeAimPosture cr
-    | otherwise = creatureTurnTowardDir (_crMvAim cr) 0.2 cr
+    | SDL.ButtonRight `M.member` _mouseButtons inp
+    , AtEase <- cr ^. crStance . posture = setposture Aiming (-twistAmount)
+    | SDL.ButtonRight `M.member` _mouseButtons inp = aimTurn w mousedir cr
+    | Aiming{} <- cr ^. crStance . posture = setposture AtEase twistAmount
+    | otherwise = creatureTurnTowardDir (_crMvDir cr) 0.2 cr
   where
+    setposture x r =
+        cr
+            & crStance . posture .~ x
+            & doAimTwist (w ^? hud . manObject . hiAimStance) r
     mousedir = argV $ w ^. cWorld . lWorld . lAimPos - (cr ^. crPos . _xy)
 
-setAimPosture :: IM.IntMap Item -> 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 :: Maybe AimStance -> Float -> Creature -> Creature
 doAimTwist as x
-    | as == TwoHandOver || as == TwoHandUnder = crDir +~ x
+    | as == Just TwoHandTwist = crDir +~ x
     | otherwise = id
 
-removeAimPosture :: Creature -> Creature
-removeAimPosture cr = fromMaybe cr $ do
-    as <- cr ^? crStance . posture . aimStance
-    return $ cr
-        & crStance . posture .~ AtEase
-        & doAimTwist as twoHandTwistAmount
+twistAmount :: Float
+twistAmount = 1.6 * pi
 
-twoHandTwistAmount :: Float
-twoHandTwistAmount = 1.6 * pi
-
-wasdMovement :: LWorld -> Input -> Camera -> Float -> Creature -> Creature
-wasdMovement lw inp cam speed = theMovement . setMvAim
+wasdMovement :: World -> Input -> Camera -> Float -> Creature -> Creature
+wasdMovement w inp cam speed = theMovement -- . setMvAim
   where
-    setMvAim = fromMaybe id $ do
-        dir <- safeArgV movDir
-        return $ crMvAim .~ (cam ^. camRot + dir)
+--    setMvAim = fromMaybe id $ do
+--        dir <- safeArgV movDir
+--        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
-        fmap itemBulkiness $ cr ^? crInv . ix itRef >>= \k -> lw ^? items . ix k . itType
+        itRef <- lw ^? hud . manObject . hiRootSelectedItem
+        fmap itemBulkiness $ cr ^? crInv . ix itRef >>= \k -> lw ^?cWorld.lWorld. items . ix k . itType
 
 itemBulkiness :: ItemType -> Float
 itemBulkiness = \case
@@ -238,11 +207,6 @@ tryClickUse pkeys w = fromMaybe w $ do
     ltime <- pkeys ^? ix SDL.ButtonLeft
     rtime <- pkeys ^? ix SDL.ButtonRight
     guard $ ltime <= rtime
-    case w
-        ^? cWorld . lWorld . creatures . ix 0
-            . crManipulation
-            . manObject
-            . imSelectedItem
-            . unNInt of
-        Just invid -> useItem invid ltime w
-        Nothing -> interactWithCloseObj <$> getSelectedCloseObj w ?? w
+    case w ^.hud.diSelection of
+        Just (Sel 0 invid) -> useItem invid ltime w
+        _ -> interactWithCloseObj <$> getSelectedCloseObj w ?? w

src/Dodge/CreatureEffect.hs

@@ -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
-doCrAc ca = case ca of
-    CrTurnAround -> \cr -> TurnToPoint 
-        (cr ^. crPos . _xy -.- 10 *.* unitVectorAtAngle (_crDir cr))
---    CrFleeFromTarget -> fleeFromTarget
-
---fleeFromTarget :: Creature -> Action
---fleeFromTarget cr = fleeFrom cr (_targetCr (_crIntention cr))
-
-doCrWdAc :: CrWdAc -> Creature -> World -> Action
-doCrWdAc cw = case cw of
-    CrWdBFSThenReturn _ -> const $ const NoAction
+--doCrWdAc :: CrWdAc -> Creature -> World -> Action
+--doCrWdAc cw = case cw of
+--    CrWdBFSThenReturn _ -> const $ const NoAction
 --    CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
 --        n <- walkableNodeNear w (cr ^. crPos . _xy)
 --        let as = take 20 $ map PathTo $ bfsNodePoints n w
@@ -54,30 +46,30 @@ doCrWdAc cw = case cw of
 --            $
 --            DoReplicate t $
 --                foldr DoActionThen NoAction as
-    ChooseMovementSpreadGun -> chooseMovementSpreadGun
-    ChooseMovementLtAuto -> chooseMovementLtAuto
+--    ChooseMovementSpreadGun -> chooseMovementSpreadGun
+--    ChooseMovementLtAuto -> chooseMovementLtAuto
 
-chooseMovementSpreadGun :: Creature -> World -> Action
-chooseMovementSpreadGun cr w
-    | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi =
-        DoImpulses [UseItem, MoveForward (-3)]
-    | d < 30 = DoImpulses [UseItem, TurnToward p 0.06]
-    | d < 60 = DoImpulses [UseItem, 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]
-    | otherwise =
-        DoImpulses [TurnToward p 0.26, MoveForward 3]
-  where
-    d = dist cpos p
-    cpos = cr ^. crPos . _xy
-    --tcr = _creatures (_cWorld w) IM.! 0
-    tcr = w ^?! cWorld . lWorld . creatures . ix 0
-    p = tcr ^. crPos . _xy
+--chooseMovementSpreadGun :: Creature -> World -> Action
+--chooseMovementSpreadGun cr w
+--    | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi =
+--        DoImpulses [UseItem, MoveForward (-3)]
+--    | d < 30 = DoImpulses [UseItem, TurnToward p 0.06]
+--    | d < 60 = DoImpulses [UseItem, 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]
+--    | otherwise =
+--        DoImpulses [TurnToward p 0.26, MoveForward 3]
+--  where
+--    d = dist cpos p
+--    cpos = cr ^. crPos . _xy
+--    --tcr = _creatures (_cWorld w) IM.! 0
+--    tcr = w ^?! cWorld . lWorld . creatures . ix 0
+--    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 < 80 = 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)]
     | 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 cr mtcr = case mtcr of
-    Just tcr -> DoImpulses 
-        [MoveForward 3
-        , TurnToward ((2 *.* (cr ^. crPos ._xy)) -.- (tcr ^. crPos . _xy)) (pi / 4)]
-    Nothing -> NoAction
+--fleeFrom :: Creature -> Maybe Creature -> Action
+--fleeFrom cr mtcr = case mtcr of
+--    Just tcr -> DoImpulses 
+--        [MoveForward 3
+--        , TurnToward ((2 *.* (cr ^. crPos ._xy)) -.- (tcr ^. crPos . _xy)) (pi / 4)]
+--    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
-        , _apStrategy :: Strategy -- current strategy
-        , _apGoal :: [Goal] -- particular ordered goals
+         _apAction :: Action -- updated per frame, likely persist across frames
+        , _apStrategy :: Strategy
+        , _apGoal :: Goal
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     deriving (Eq, Ord, Show) --Generic, Flat)
 
 data Impulse
     = Move Point2
+    | Walk Point2
     | MoveForward Float
     | MoveNoStride Point2
     | Turn Float
@@ -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
-    | TwoHandOver
+    = TwoHandTwist
     | 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,7 +38,8 @@ data ItemSF -- Structural Function
     | GrenadeHitEffectSF
     | ToggleSF
     | MapperSF
-    | LaserWeaponSF
+--    | LaserWeaponSF
+    | LaserWeaponXSF {_lasWepXSF :: Int}
     | PulseLaserSF
     | CapacitorSF
     | TransformerSF
@@ -45,6 +47,7 @@ data ItemSF -- Structural Function
     | 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
-    | CrIsPitted
+    | AvatarDestroyed
+--    | CrDestroyed CrDestructionType
+
+destroyCreature :: Maybe Creature -> Maybe Creature
+destroyCreature mcr
+    | Just cr <- mcr
+    , _crID cr == 0 = Just cr{_crHP = AvatarDestroyed}
+    | otherwise = Nothing
+
+data CrDestructionType = Gibbed | Pitted | Swallowed
 
 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.CamouflageStatus,
-) where
+module Dodge.Data.Creature.Misc (module Dodge.Data.Creature.Misc) where
 
+import Dodge.Data.Creature.Stance
 import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
-import Dodge.Data.CamouflageStatus
 import Dodge.Data.FloatFunction
 import Dodge.Data.Material
 import Geometry.Data
+import qualified Data.IntSet as IS
 
 data Vocalization
-    = Mute
-    | Vocalization
-        { _vcMaxCoolDown :: (Int, Int)
-        , _vcCoolDown :: Int
-        }
+    = VocTimer {_vcTime :: Int ,_vcMaxTime :: Int }
+    | VocReady
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CrMvType
     = NoMvType
-    | MvWalking {_mvSpeed :: Float}
-    | CrMvType
+    | MvWalking {_mvSpeed :: Float} -- note this may interact with a friction element
+    -- so currently 26.04.03 the actual max speed when walking is twice this
+    | JitMvType
         { _mvSpeed :: Float
         , _mvTurnRad :: FloatFloat
         , _mvTurnJit :: Float
-        , _mvAimSpeed :: FloatFloat
         }
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
-data HumanoidAI
-    = ChaseAI
-    | InanimateAI
-    | SpreadGunAI
-    | PistolAI
-    | LtAutoAI
-    | LauncherAI
-    | SwarmAI
-    | AutoAI
-    | FlockArmourChaseAI
-    | MiniGunAI
-    | LongAI
-    | MultGunAI
+    | StartStopMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
+    | BeeMvType
+        { _mvSpeed :: Float
+        , _mvTurnSpeed :: Float
+        , _mvPulseTime :: Int
+        }
     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
-    = Aiming {_aimStance :: AimStance}
-    | AtEase
+data Posture = Aiming | 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
-    = CrWdBFSThenReturn Int
-    | ChooseMovementSpreadGun
-    | ChooseMovementLtAuto
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+--data CrWdAc
+--    = CrWdBFSThenReturn Int
+----    | ChooseMovementSpreadGun
+----    | ChooseMovementLtAuto
+--    deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 deriveJSON defaultOptions ''CrImp
 deriveJSON defaultOptions ''CrBl
 deriveJSON defaultOptions ''WdCrBl
 deriveJSON defaultOptions ''CrAc
-deriveJSON defaultOptions ''CrWdAc
+--deriveJSON defaultOptions ''CrWdAc

src/Dodge/Data/Damage.hs

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

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

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

src/Dodge/Data/EnergyBall/Type.hs

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

src/Dodge/Data/Flame.hs

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

src/Dodge/Data/GenWorld.hs

@@ -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}

src/Dodge/Data/HUD.hs

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

src/Dodge/Data/Input.hs

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

src/Dodge/Data/Item/Location.hs

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

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

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

src/Dodge/Data/LWorld.hs

@@ -96,6 +96,7 @@ data LWorld = LWorld
     , _creatureGroups :: IM.IntMap CrGroupParams
     , _items :: IM.IntMap Item
     , _clouds :: [Cloud]
+    , _beePheremones :: [BeePheremone]
     , _dusts :: [Dust]
     , _gasses :: [Gas]
     , _gusts :: IM.IntMap Gust
@@ -145,7 +146,7 @@ data LWorld = LWorld
     , _hotkeys :: M.Map Hotkey (NewInt ItmInt)
     , _imHotkeys :: NewIntMap ItmInt Hotkey
     , _lAimPos :: Point2
-    , _lInvLock :: Bool
+    , _lInvLock :: Bool -- used eg burstRifle fire
     , _respawnPos :: (Point2, Float)
     }
 

src/Dodge/Data/Laser.hs

@@ -3,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/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/PlasmaBall.hs

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

src/Dodge/Data/Projectile.hs

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

src/Dodge/Data/Prop.hs

@@ -21,6 +21,8 @@ data Prop = ShapeProp
 data DebrisType
     = Gib { _gibSize :: Float , _gibColor :: Color }
     | BlockDebris {_bdColor :: Color}
+    | MetalDebris {_bdColor :: Color}
+    | GlassDebris
 
 data Debris = DebrisChunk
     { _dbPos :: Point3

src/Dodge/Data/PulseLaser.hs

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

src/Dodge/Data/Room.hs

@@ -31,8 +31,8 @@ data RoomLink = RoomLink
 data RoomType
     = DefaultRoomType
     | RectRoomType
-        { _numLinkEW :: Int
-        , _numLinkNS :: Int
+        { _numLinkEW :: Int  -- note this is ONE LESS than might be expected
+        , _numLinkNS :: Int  -- note this is ONE LESS than might be expected
         , _linkGapEW :: Float
         , _linkGapNS :: Float
         , _rmWidth :: Float

src/Dodge/Data/ScreenPos.hs

@@ -10,7 +10,7 @@ import Control.Lens
 -- a spScreenOff of 1 is the full length of the screen
 -- for eg see fromTopLeft
 data ScreenPos = ScreenPos
-    { _spScreenOff :: Point2
+    { _spScreenOff :: Point2 -- from bottom left
     , _spPixelOff :: Point2
     }
 makeLenses ''ScreenPos