Creature springs checks for heights

src/Dodge/Barreloid.hs

@@ -31,7 +31,7 @@ updateExpBarrel ps cr w = case cr ^. crHP of
     HP _ ->
         w
             & makeExplosionAt ((cr ^. crPos) & _z +~ 20) 0
-            & cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ CrIsGibs
+            & cWorld . lWorld . creatures . ix (_crID cr) . crHP .~ CrDestroyed Gibbed
     _ -> w
   where
     f w' p = makeSpark NormalSpark (p + normalizeV p + cr ^. crPos . _xy) (argV p) w'
@@ -44,7 +44,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 . ix (_crID cr) . crHP .~ CrDestroyed Gibbed
     _ -> id
 
 damsToExpBarrel :: [Damage] -> Creature -> Creature

src/Dodge/Base/Collide.hs

@@ -32,6 +32,7 @@ module Dodge.Base.Collide (
     anythingHitCirc,
     collide3WallsFloor,
     collide3,
+    crHeight,
 ) where
 
 import Data.Foldable
@@ -174,10 +175,13 @@ collide3Creature sp cr (ep, m) = fromMaybe (ep, m) $ do
 
 crHeight :: Creature -> Maybe Float
 crHeight cr = case cr ^. crHP of
-    HP{} -> Just 25
+    HP{} -> Just $ case cr ^. crType of
+        HoverCrit {} -> 10
+        ChaseCrit {} -> 25
+        Avatar {} -> 25
+        _ -> error "Need to define crHeight for this crType"
     CrIsCorpse{} -> Just 5
-    CrIsGibs -> Nothing
-    CrIsPitted -> Nothing
+    CrDestroyed{} -> Nothing
 
 wallToSurface :: Wall -> (Point3, Point3, [(Point3, Point3)])
 wallToSurface wl = (g x, g $ vNormal (x - y), [(g x, g (y - x)), (g y, g (x - y))])

src/Dodge/Creature/Test.hs

@@ -139,6 +139,5 @@ hasAutoDoorBody :: Creature -> Bool
 hasAutoDoorBody cr = case cr ^. crHP of
     HP {} -> True
     CrIsCorpse {} -> True
-    CrIsGibs -> False
-    CrIsPitted -> False
+    CrDestroyed {} -> False
     

src/Dodge/Creature/Update.hs

@@ -39,7 +39,7 @@ import ShapePicture.Data
 -- allow for knockbacks etc to be determined as well as intended movements
 updateCreature :: Creature -> World -> World
 updateCreature cr
-    | cr ^. crPos . _z < negate 300 = (tocr . crHP .~ CrIsPitted) . destroyAllInvItems cr
+    | cr ^. crPos . _z < negate 300 = (tocr . crHP .~ CrDestroyed Pitted) . destroyAllInvItems cr
     | CrIsCorpse _ <- cr ^. crHP = updateCarriage (_crID cr) . chasmTestCorpse cr
     | null (cr ^? crHP . _HP) = id
     | otherwise = updateLivingCreature cr
@@ -143,7 +143,7 @@ corpseOrGib cr = case cr ^? crDamage . to maxDamageType . _Just . _1 of
     Just PhysicalDamage
         | _crPain cr > 200 ->
             makeCrGibs cr
-                . sethp CrIsGibs
+                . sethp (CrDestroyed Gibbed)
                 . dodeathsound GibsDeath
     _ ->
         sethp (CrIsCorpse thecorpse)

src/Dodge/Data/Creature.hs

@@ -59,11 +59,13 @@ data Creature = Creature
     , _crWallTouch :: IM.IntMap Point2
     }
 
+-- Prisms, not lenses
 data CrHP
     = HP Int
     | CrIsCorpse SPic
-    | CrIsGibs
-    | CrIsPitted
+    | CrDestroyed CrDestructionType
+
+data CrDestructionType = Gibbed | Pitted
 
 data DeathType = CookDeath | PoisonDeath | PlainDeath | GibsDeath
 
@@ -93,4 +95,5 @@ concat
         [ ''Creature
         , ''Intention
         , ''CrHP
+        , ''CrDestructionType
         ]

src/Dodge/Data/Creature/Misc.hs

@@ -23,7 +23,8 @@ data Vocalization
 
 data CrMvType
     = NoMvType
-    | MvWalking {_mvSpeed :: Float}
+    | MvWalking {_mvSpeed :: Float} -- note this may interact with a friction element
+    -- so currently 26.04.03 the actual max speed when walking is twice this
     | CrMvType
         { _mvSpeed :: Float
         , _mvTurnRad :: FloatFloat

src/Dodge/TestString.hs

@@ -1,50 +1,58 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
+
 module Dodge.TestString where
 
-import Dodge.Creature.Picture
-import Dodge.WallCreatureCollisions
-import Data.List ((\\))
-import ShortShow
-import Geometry
-import qualified SDL
-import Linear
-import Dodge.ListDisplayParams
-import Dodge.SelectionSections
-import qualified Control.Foldl as L
-import Dodge.DoubleTree
-import Dodge.Data.DoubleTree
-import Dodge.Item.Grammar
-import Dodge.Item.Display
 import AesonHelp
-import Dodge.SmoothScroll
-import HelpNum
-import Dodge.Base.Coordinate
-import Geometry.Vector
-import Data.Maybe
-import Dodge.Render.Lights
-import Data.Aeson (ToJSON)
-import Data.ByteString.Lazy.Char8 (unpack)
-import qualified Data.Aeson.Encode.Pretty as AEP
+import qualified Control.Foldl as L
 import Control.Lens
-import Dodge.Data.Universe
-import qualified IntMapHelp as IM
-import qualified Data.Map.Strict as M
-import NewInt
+import Data.Aeson (ToJSON)
+import qualified Data.Aeson.Encode.Pretty as AEP
+import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Foldable
+import Data.List ((\\))
+import qualified Data.Map.Strict as M
+import Data.Maybe
 import Data.Monoid
+import Dodge.Base.Coordinate
+import Dodge.Creature.Picture
+import Dodge.Data.DoubleTree
+import Dodge.Data.Universe
+import Dodge.DoubleTree
+import Dodge.Item.Display
+import Dodge.Item.Grammar
+import Dodge.ListDisplayParams
+import Dodge.Render.Lights
+import Dodge.SelectionSections
+import Dodge.SmoothScroll
+import Dodge.WallCreatureCollisions
+import Geometry
+import Geometry.Vector
+import HelpNum
+import qualified IntMapHelp as IM
+import Linear
+import NewInt
 import RandomHelp
+import qualified SDL
+import ShortShow
+
+tocrs ::
+    ( IM.IntMap Creature ->
+      Const (Endo [String]) (IM.IntMap Creature)
+    ) ->
+    Universe ->
+    Const (Endo [String]) Universe
+tocrs = uvWorld . cWorld . lWorld . creatures
 
 testStringInit :: Universe -> [String]
-testStringInit u = [show p, show op', show oop, show (op' - oop), show . norm $ op' - oop, show d]
-    <> u ^.. tocr . crStance . carriage . to show
-    <> u ^.. tocr . crMvDir  . to show
-  where
-    tocr = uvWorld . cWorld . lWorld . creatures . ix 0
-    f = fromMaybe 0
-    p = f $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
-    op' = f $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crOldPos
-    oop = fromMaybe 0 $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crOldOldPos
-    d = fromMaybe 0 $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crDir
+testStringInit u = u ^.. tocrs . each . crStance . carriage . to show
+
+--  where
+--    tocr = uvWorld . cWorld . lWorld . creatures . ix 0
+--    f = fromMaybe 0
+--    p = f $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crPos
+--    op' = f $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crOldPos
+--    oop = fromMaybe 0 $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crOldOldPos
+--    d = fromMaybe 0 $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crDir
 --    u ^.. uvWorld . cWorld . lWorld . creatures . ix 1 . crActionPlan . apStrategy . to show
 --    <> u ^.. uvWorld . cWorld . lWorld . creatures . ix 1 . crActionPlan . apAction . to show
 --    <> u ^.. uvWorld . cWorld . lWorld . creatures . ix 1 . crPerception . cpAttention . to show
@@ -58,7 +66,7 @@ testStringInit u = [show p, show op', show oop, show (op' - oop), show . norm $
 -- a    <> fromMaybe [] (do
 -- a    w1 <- u ^? uvWorld . cWorld . lWorld . walls . ix 18
 -- a    w2 <- u ^? uvWorld . cWorld . lWorld . walls . ix 61
--- a    let 
+-- a    let
 -- a        f = uncurry (-) . (^. wlLine)
 -- a        g = argV . f
 -- a        h = normalizeV . uncurry (-) . (^. wlLine)
@@ -72,29 +80,37 @@ testStringInit u = [show p, show op', show oop, show (op' - oop), show . norm $
 -- a        ]
 -- a    )
 --    <> (fmap show $ u ^.. uvWorld . cWorld . lWorld . machines . each . mcMaterial)
---testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
---testStringInit u =  map show
+-- testStringInit u = map show (u ^.. uvWorld . cWorld . lWorld . machines . traverse . mcDir)
+-- testStringInit u =  map show
 --    (u ^.. uvWorld . cWorld . lWorld . machines . traverse .mcType . _McDistributer)
 --    <>
 --    map f (u ^.. uvWorld . cWorld . lWorld . machines . traverse)
 --  where
 --    f mc = show (mc ^. mcID) <> shortShow (mc ^. mcType)
---    [show $ foldMap (foldMap (Sum . length . (^. seObstacles))) 
+--    [show $ foldMap (foldMap (Sum . length . (^. seObstacles)))
 --    $ u ^. uvWorld . cWorld . incGraph]
-    -- foldMap prettyShort $ u ^? uvWorld . cWorld . lWorld . machines . ix 0 . mcType . _McProxSensor
---testStringInit u = foldMap prettyShort $ u ^.. uvWorld . cWorld . lWorld . machines
+-- foldMap prettyShort $ u ^? uvWorld . cWorld . lWorld . machines . ix 0 . mcType . _McProxSensor
+-- testStringInit u = foldMap prettyShort $ u ^.. uvWorld . cWorld . lWorld . machines
 
 --    showh _ = ""
 --    shortShow
 
 topTestPart :: Universe -> [String]
-topTestPart u = [maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
+topTestPart u =
+    [ maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
     ]
 
 showManObj :: ManipulatedObject -> String
 showManObj SortInventory = "SortInventory"
-showManObj (SelectedItem x y as z) = "SelItem: "++ show x++ " Root: "++show y++" Attached: "++show z
-    ++ " AimStance: " ++ show as
+showManObj (SelectedItem x y as z) =
+    "SelItem: "
+        ++ show x
+        ++ " Root: "
+        ++ show y
+        ++ " Attached: "
+        ++ show z
+        ++ " AimStance: "
+        ++ show as
 showManObj SelNothing = "SelNothing"
 showManObj SortCloseItem = "SortCloseItem"
 showManObj (SelCloseItem x) = "CloseItem " ++ show x
@@ -103,10 +119,10 @@ showManObj (SelCloseButton x) = "CloseButton " ++ show x
 
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of
-    RespawnDelay i -> "Respawndelay"++show i
+    RespawnDelay i -> "Respawndelay" ++ show i
     NormalTimeFlow -> "NormalTimeFlow"
-    ItemScrollTimeFlow {_reverseAmount = ra } -> "ItemScrollTimeFlow" ++ show ra
-    CameraScrollTimeFlow {_reverseAmount = ra } -> "CameraScrollTimeFlow" ++ show ra
-    RewindLeftClick {_reverseAmount = ra } -> "RewindLeftClick" ++ show ra
-    PausedTimeFlow {_timeFlowCharge = ra } -> "PausedTimeFlow" ++ show ra
-    PauseTimeMessage {} -> "PausedTimeMessage"
+    ItemScrollTimeFlow{_reverseAmount = ra} -> "ItemScrollTimeFlow" ++ show ra
+    CameraScrollTimeFlow{_reverseAmount = ra} -> "CameraScrollTimeFlow" ++ show ra
+    RewindLeftClick{_reverseAmount = ra} -> "RewindLeftClick" ++ show ra
+    PausedTimeFlow{_timeFlowCharge = ra} -> "PausedTimeFlow" ++ show ra
+    PauseTimeMessage{} -> "PausedTimeMessage"

src/Dodge/Update.hs

@@ -975,16 +975,23 @@ canSpring cr =
     cr ^. crPos . _z >= 0 && case cr ^. crHP of
         HP{} -> True
         CrIsCorpse{} -> True
-        CrIsGibs -> False
-        CrIsPitted -> False
+        CrDestroyed{} -> False
 
+-- should possibly limit how big this can get
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2
     | id1 == id2 = id
     | vec == V2 0 0 = id
     | diff >= comRad = id
+    | diffheight = id
     | otherwise = cWorld . lWorld . creatures %~ ( olap c1 c2 . olap' c2 c1)
   where
+    z c = c ^. crPos . _z
+    h c = fmap (+ z c) (crHeight c)
+    diffheight = fromMaybe True $ do
+        h1 <- h c1
+        h2 <- h c2
+        return $ (z c1 > h2 || z c2 > h1)
     olap a b = ix (a ^. crID) . crPos . _xy +~ overlap b
     olap' a b = ix (a ^. crID) . crPos . _xy -~ overlap b
     id1 = _crID c1