Add slime crit, start work on slink crit

src/Dodge/Base/CardinalPoint.hs

@@ -21,6 +21,9 @@ cardVec = \case
     East -> V2 1 0
     West -> V2 (-1) 0
 
+vecCard :: Point2 -> CardinalPoint
+vecCard (V2 x y) = undefined
+
 card8Vec :: Cardinal8 -> Point2
 card8Vec cp = case cp of
     North8 -> V2 0 1

src/Dodge/Base/Collide.hs

@@ -180,6 +180,8 @@ crHeight cr = case cr ^. crHP of
         ChaseCrit {} -> 25
         Avatar {} -> 25
         CrabCrit {} -> 25
+        SlinkCrit {} -> 25
+        SlimeCrit {_slimeRad = r} -> r
         _ -> error "Need to define crHeight for this crType"
     CrIsCorpse{} -> Just 5
     CrDestroyed{} -> Nothing

src/Dodge/Creature/ChaseCrit.hs

@@ -4,9 +4,12 @@ module Dodge.Creature.ChaseCrit (
     crabCrit,
     chaseCrit,
     hoverCrit,
+    slinkCrit,
+    slimeCrit,
 ) where
 
---import Dodge.Data.Equipment.Misc
+import qualified Quaternion as Q
+import Linear
 import Dodge.Data.FloatFunction
 import Control.Lens
 import Dodge.Data.Creature
@@ -48,6 +51,25 @@ crabCrit = defaultCreature
         & 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))
+            }
+        & crFaction .~ ColorFaction red
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
+slimeCrit :: Creature
+slimeCrit = defaultCreature
+        & crName .~ "slimeCrit"
+        & crHP .~ HP 1000
+        & crType .~ SlimeCrit 40 (V2 30 0) False
+        & crFaction .~ ColorFaction (light green)
+        & crPerception . cpVision . viFOV .~ FloatFOV pi
+
 hoverCrit :: Creature
 hoverCrit =
     defaultCreature

src/Dodge/Creature/Mass.hs

@@ -11,4 +11,6 @@ crMass = \case
     SwarmCrit -> 2
     AutoCrit -> 10
     BarrelCrit{} -> 10
+    SlinkCrit{} -> 100
     LampCrit {} -> 3
+    SlimeCrit {_slimeRad = r} -> r

src/Dodge/Creature/Material.hs

@@ -13,5 +13,7 @@ crMaterial = \case
     HoverCrit {} -> Metal
     SwarmCrit -> Flesh
     AutoCrit -> Flesh
+    SlinkCrit{} -> Flesh
     BarrelCrit{} -> Metal
     LampCrit{} -> Glass
+    SlimeCrit{} -> Flesh

src/Dodge/Creature/MaxHP.hs

@@ -13,4 +13,5 @@ crMaxHP = \case
     AutoCrit -> 100
     BarrelCrit{} -> 100
     LampCrit {} -> 50
-
+    SlinkCrit {} -> 1000
+    SlimeCrit {} -> 1000

src/Dodge/Creature/MoveType.hs

@@ -7,6 +7,7 @@ import Control.Lens
 crMvType :: Creature -> CrMvType
 crMvType cr = case _crType cr of
     Avatar {} -> MvWalking 1.5
+    SlinkCrit {} -> NoMvType
     ChaseCrit {} -> defaultChaseMvType & mvSpeed .~ 1.8
     CrabCrit {} -> defaultChaseMvType & mvSpeed .~ 0.5
         & mvTurnJit .~ 0.01
@@ -15,6 +16,7 @@ crMvType cr = case _crType cr of
     AutoCrit -> defaultAimMvType
     BarrelCrit {} -> defaultAimMvType
     LampCrit {} -> defaultAimMvType
+    SlimeCrit {} -> NoMvType
 
 defaultAimMvType :: CrMvType
 defaultAimMvType =

src/Dodge/Creature/Picture.hs

@@ -3,16 +3,12 @@ Drawing of creatures.
 Takes into account damage etc.
 -}
 module Dodge.Creature.Picture (
-    basicCrPict,
-    deadScalp,
-    deadUpperBody,
-    deadFeet,
-    drawChaseCrit,
-    drawHoverCrit,
-    drawCrabCrit,
     makeCorpse,
+    drawCreature,
 ) where
 
+import Data.Foldable
+import qualified Data.Strict.Tuple as ST
 import RandomHelp
 import Dodge.Base.Collide
 import Control.Monad
@@ -37,6 +33,42 @@ import Shape
 --import Shape
 import ShapePicture
 
+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 m cr
+        SwarmCrit -> basicCrPict m cr
+        AutoCrit -> basicCrPict m cr
+        CrabCrit {} -> noPic $ drawCrabCrit w cr
+        HoverCrit{} -> noPic $ drawHoverCrit cr
+        SlinkCrit{} -> noPic $ drawSlinkCrit cr
+        SlimeCrit{} -> noPic $ drawSlimeCrit cr
+  where
+    fallrot = case cr ^? crStance . carriage . carDir of
+        Just q -> _1 . each . sfVs . each %~ Q.rotate q
+        _ -> id
+
+drawSlimeCrit :: Creature -> Shape
+drawSlimeCrit cr = colorSH green $ upperPrismPolyHalf Medium Undesired r $ polyCirc 6 r
+    & each %~ scaleAlong d s
+    & each %~ scaleAlong (vNormal d) (1 / s)
+    & each %~ rotateV (-cr ^. crDir)
+  where
+    r = cr ^?! crType . slimeRad
+    p = cr ^?! crType . slimeCompression
+    d = normalize p
+    s = norm p / r
+
+-- assumes d is a unit vector
+scaleAlong :: Point2 -> Float -> Point2 -> Point2
+scaleAlong d s p = ((s - 1) * dot d p) *^ d + p
+
+
 basicCrPict :: IM.IntMap Item -> Creature -> SPic
 basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)
 
@@ -58,6 +90,14 @@ basicCrShape 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)
+    & each . sfColor .~ cskin ^?! skinUpper
+  where
+    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 10
+
 drawHoverCrit :: Creature -> Shape
 drawHoverCrit cr = colorSH (_skinHead cskin) 
     (overPosSH (Q.apply tpq) $ upperBoxHalf Medium Typical 1 $ square 4)
@@ -332,3 +372,14 @@ upperBody cr = arms cr <> torso cr
 drawEquipment :: IM.IntMap Item -> Creature -> SPic
 {-# INLINE drawEquipment #-}
 drawEquipment m cr = foldMap (itemEquipPict 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

@@ -15,3 +15,5 @@ crRad = \case
     AutoCrit -> 10
     BarrelCrit{} -> 10
     LampCrit {} -> 3
+    SlinkCrit {} -> 10
+    SlimeCrit {_slimeRad = r} -> r

src/Dodge/Creature/Shape.hs

@@ -13,5 +13,7 @@ crShape = \case
     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
+    SlimeCrit {} -> Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3)

src/Dodge/Creature/Statistics.hs

@@ -48,6 +48,8 @@ crIntelligence  cr = case cr ^. crType of
     AutoCrit -> 20
     BarrelCrit {} -> 0
     LampCrit {} -> 0
+    SlinkCrit{} -> 5
+    SlimeCrit{} -> 1
     
 
 getCrMoveSpeed :: LWorld -> Creature -> Int

src/Dodge/Creature/Update.hs

@@ -1,16 +1,18 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Dodge.Creature.Update (updateCreature) where
 
-import qualified Quaternion as Q
+import Dodge.Base.Collide
-import Dodge.Creature.Picture
+import Dodge.Creature.Radius
-import Dodge.Base.You
-import Control.Monad
 import Color
+import Control.Monad
 import qualified Data.IntMap.Strict as IM
 import Data.Maybe
 import Dodge.Barreloid
+import Dodge.Base.You
 -- import Dodge.Base.NewID
 import Dodge.Creature.Action
+import Dodge.Creature.Picture
 import Dodge.Creature.State
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Vocalization
@@ -28,6 +30,7 @@ import Geometry
 import LensHelp
 import Linear
 import NewInt
+import qualified Quaternion as Q
 import RandomHelp
 import Shape
 import ShapePicture.Data
@@ -44,8 +47,7 @@ updateCreature cr
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
 updateLivingCreature :: Creature -> World -> World
-updateLivingCreature cr =
+updateLivingCreature cr = case _crType cr of
-    case _crType cr of
     Avatar{} ->
         (cWorld . lWorld . creatures . ix 0 . crType . avatarPulse %~ updatePulse)
             . crUpdate cid
@@ -57,14 +59,62 @@ updateLivingCreature cr =
             over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w
     CrabCrit{} ->
         crUpdate cid . performActions cid . crabCritInternal cid
-        AutoCrit {} -> crUpdate cid
+    AutoCrit{} -> crUpdate cid
-        SwarmCrit {} -> crUpdate cid
+    SwarmCrit{} -> crUpdate cid
-        HoverCrit {} -> \w ->
+    HoverCrit{} -> \w ->
         crUpdate cid . performActions cid . hoverCritHoverSound cr $
             over (cWorld . lWorld . creatures . ix cid) (hoverCritInternal w) w
+    SlinkCrit{} -> slinkCritUpdate cid
+    SlimeCrit{} -> slimeCritUpdate cid
   where
     cid = cr ^. crID
 
+slimeCritUpdate :: Int -> World -> World
+slimeCritUpdate cid w = w
+        & cWorld . lWorld . creatures . ix cid .~ mvslime
+  where
+    txy = w ^?! cWorld . lWorld . creatures . ix 0 . crPos . _xy
+    cr = w ^?! cWorld . lWorld . creatures . ix cid
+    cxy = cr ^. crPos . _xy
+    mvslime 
+        | hasLOS cxy txy w = mvslime'
+        | otherwise = cr
+    mvslime' = cr & crType . slimeCompression .~ p' + x
+        & crPos . _xy +~ g (0.5*x)
+        & crType . slimeIsCompressing %~ (f . f')
+        & crDir .~ argV (txy-cxy)
+    g | cr ^?! crType . slimeIsCompressing = negate
+      | otherwise = id
+    s | cr ^?! crType . slimeIsCompressing = 2/3
+      | otherwise = 1.5
+    f | abs (norm v - norm p') < 0.1 = not
+      | otherwise = id
+    v = (s * r) *^ unitVectorAtAngle (cr ^. crDir)
+    r = crRad (cr ^. crType)
+    p = cr ^?! crType . slimeCompression
+    (p',f')  
+        | dot p v > 0 && dot p v > dot p (vNormal v) && dot p v > dot p (-vNormal v) = (p, id)
+        | dot p (-v) > dot p (vNormal v) && dot p (-v) > dot p (-vNormal v) = (-p, id)
+        | dot p (vNormal v) > dot p (-vNormal v) = ((r*r/norm p) *^ normalize (vNormal p), not)
+        | otherwise = (-(r*r/norm p) *^ normalize (vNormal p), not)
+    x = 0.1 *^ normalize (v - p')
+
+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)
+
+-- spineWalk :: [Point3Q]
+-- spineWalk = replicate 15 (V3
+
 hoverCritHoverSound :: Creature -> World -> World
 hoverCritHoverSound cr w = fromMaybe w $ do
     guard $ d < 100
@@ -101,39 +151,52 @@ checkDeath cid w = maybe id checkDeath' (w ^? cWorld . lWorld . creatures . ix c
 checkDeath' :: Creature -> World -> World
 checkDeath' cr w = case cr ^. crHP of
     HP x | x > 0 -> w & tocr . crDamage .~ []
-    HP x | x > -200 && null (cr ^. crDeathTimer)
+    HP x
-        -> w & tocr %~ startDeathTimer
+        | x > -200 && null (cr ^. crDeathTimer) ->
-    HP x | x > -200 
+            w & tocr %~ startDeathTimer
-        ,Just y <- cr ^. crDeathTimer
+    HP x
+        | x > -200
+        , Just y <- cr ^. crDeathTimer
         , y > 0 ->
             w
-                & tocr . crDamage .~ []
+                & tocr
-                & tocr . crDeathTimer . _Just -~ 1
+                . crDamage
+                .~ []
+                & tocr
+                . crDeathTimer
+                . _Just
+                -~ 1
     HP _ ->
         w
             & dropAll cr -- the order of these is possibly important
             & stopSoundFrom (CrWeaponSound (_crID cr) 0)
             & corpseOrGib cr
-            & tocr . crStance . carriage %~ toDeathCarriage
+            & tocr
+            . crStance
+            . carriage
+            %~ toDeathCarriage
     _ -> w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
 startDeathTimer :: Creature -> Creature
-startDeathTimer cr = cr
+startDeathTimer cr =
-    & crDeathTimer ?~ case cr ^. crType of
+    cr
-        HoverCrit {} -> 0
+        & crDeathTimer
+        ?~ case cr ^. crType of
+            HoverCrit{} -> 0
             _ -> 5
 
 toDeathCarriage :: Carriage -> Carriage
 toDeathCarriage = \case
-    Flying {} -> Falling Q.qid Q.qid
+    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 w = w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
+corpseOrGib cr w =
+    w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
         Just CookingDamage ->
             sethp (CrIsCorpse $ scorchSPic thecorpse)
                 . dodeathsound CookDeath
@@ -156,7 +219,8 @@ corpseOrGib cr w = w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
         return $
             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 (w ^. randGen) cr
@@ -171,8 +235,8 @@ poisonSPic = _1 %~ overColSH (mixColors 0.5 0.5 green . normalizeColor)
 dropAll :: Creature -> World -> World
 dropAll cr w = foldl' (flip (dropItem cr)) w . reverse . IM.keys . _unNIntMap $ _crInv cr
 
---startFalling :: Creature -> Creature
+-- startFalling :: Creature -> Creature
---startFalling cr = case cr ^. crStance . carriage of
+-- startFalling cr = case cr ^. crStance . carriage of
 --    Walking -> cr & crStance . carriage .~ Falling
 --    _ -> cr & crStance . carriage .~ Falling
 

src/Dodge/Creature/Vocalization.hs

@@ -26,6 +26,8 @@ crWarningSounds cr = case cr ^. crType of
         , seagullCry1S
         , seagullCry2S
         ]
+    SlinkCrit{} -> mempty
+    SlimeCrit{} -> mempty
     CrabCrit {} -> mempty
     HoverCrit {} -> mempty
     SwarmCrit -> mempty
@@ -39,6 +41,8 @@ crDeathSounds cr dt = case cr ^. crType of
     ChaseCrit{} -> defaultDeathSounds dt
     CrabCrit{} -> defaultDeathSounds dt
     HoverCrit{} -> hoverDeathSounds dt
+    SlinkCrit{} -> defaultDeathSounds dt
+    SlimeCrit{} -> defaultDeathSounds dt
     SwarmCrit -> mempty
     AutoCrit -> mempty
     BarrelCrit{} -> mempty

src/Dodge/Data/Creature/Misc.hs

@@ -66,6 +66,15 @@ data CreatureType
         , _rFootPos :: Point2
         }
     | HoverCrit {_meleeCooldown :: Int}
+    | SlinkCrit 
+        { _meleeCooldown :: Int
+        , _slinkSpine :: [Point3Q]
+        }
+    | SlimeCrit
+        { _slimeRad :: Float
+        , _slimeCompression :: Point2
+        , _slimeIsCompressing :: Bool
+        } 
     | SwarmCrit
     | AutoCrit
     | BarrelCrit {_barrelType :: BarrelType}

src/Dodge/Machine/Draw.hs

@@ -1,6 +1,5 @@
-module Dodge.Machine.Draw (drawMachine,mcColor) where
+module Dodge.Machine.Draw (drawMachine, mcColor) where
 
-import Linear
 import Control.Lens
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -11,6 +10,7 @@ import Dodge.Placement.TopDecoration
 import Dodge.Room.Foreground
 import Dodge.Terminal.Color
 import Geometry
+import Linear
 import Picture
 import Shape
 import ShapePicture
@@ -60,23 +60,16 @@ terminalShape lw mc = fold $ do
             <> screenbackground (getcol term)
   where
     tps = [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10]
+    sps = [V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10]
     getcol term = fromMaybe black $ termScreenColor term
     screenbackground col =
         colorSH
             col
-            $ prismBox
+            $ prismBox Small Typical sps (sps & each . _z -~ 1)
-                Small
-                Typical
-                [V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10]
-                [V3 8 8 19, V3 (-8) 8 19, V3 0 (-8) 9]
 
 drawBaseMachine :: Float -> Machine -> SPic
 drawBaseMachine h mc =
-    noPic
+    noPic . colorSH (mcColor mc) . upperBox Medium Typical h . square $ 10
-        . colorSH (mcColor mc)
-        . upperBox Medium Typical h
-        . square
-        $ 10
 
 mcColor :: Machine -> Color
 mcColor mc = case mc ^. mcType of

src/Dodge/Render/ShapePicture.hs

@@ -1,7 +1,6 @@
 --{-# LANGUAGE LambdaCase #-}
 module Dodge.Render.ShapePicture (worldSPic) where
 
-import qualified Quaternion as Q
 import Dodge.Debug
 import Control.Lens
 import Data.Foldable
@@ -109,34 +108,6 @@ drawPlasmaBall pb =
         . setLayer BloomLayer
         $ circleSolidCol green white 5
 
-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 m cr
-        SwarmCrit -> basicCrPict m cr
-        AutoCrit -> basicCrPict m cr
-        CrabCrit {} -> noPic $ drawCrabCrit w cr
-        HoverCrit{} -> noPic $ drawHoverCrit cr
-  where
-    fallrot = case cr ^? crStance . carriage . carDir of
-        Just q -> _1 . each . sfVs . each %~ Q.rotate q
-        _ -> id
-
-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)
-        :!: setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-
 shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
 shiftDraw fpos fdir fdraw x =
     uncurryV translateSPxy (fpos x)

src/Dodge/Room/Tutorial.hs

@@ -56,8 +56,8 @@ tutAnoTree :: State LayoutVars MTRS
 tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
-        , corDoor
+--        , corDoor
-        , chasmSpitTerminal
+--        , chasmSpitTerminal
         , corDoor
         , loadAmmoTut
         , corDoor
@@ -431,7 +431,7 @@ tutLight = do
 
 crabRoom :: State LayoutVars Room
 crabRoom = (putSingleLight =<< roomNgon 6 150)
-    <&> rmPmnts .:~ psPtPl (PS 100 0) (PutCrit crabCrit)
+    <&> rmPmnts .:~ psPtPl (PS 40 0) (PutCrit slimeCrit)
 
 loadAmmoTut :: State LayoutVars (MetaTree Room String)
 loadAmmoTut = do

src/Dodge/TestString.hs

@@ -41,9 +41,10 @@ tocrs :: (IM.IntMap Creature
 tocrs = uvWorld . cWorld . lWorld . creatures
 
 testStringInit :: Universe -> [String]
-testStringInit u = u ^.. tocrs . ix 3 . crPos . _xy . to show
+testStringInit u = u ^.. tocrs . ix 1 . crPos . _xy . to show
-    <> u ^.. tocrs . ix 3 . crType . lFootPos . to show
+    <> u ^.. tocrs . ix 1 . crType . slimeCompression . to show
-    <> u ^.. tocrs . ix 3 . crType . rFootPos . to show
+    <> u ^.. tocrs . ix 1 . crType . slimeIsCompressing . to show
+    <> u ^.. tocrs . ix 1 . crDir . to show
 --  where
 --    tocr = uvWorld . cWorld . lWorld . creatures . ix 0
 --    f = fromMaybe 0

src/Shader/Poke.hs

@@ -133,11 +133,12 @@ pokeShapeObj ::
     IO (Int, Int, Int)
 {-# INLINE pokeShapeObj #-}
 pokeShapeObj shadowtest ptr iptr ieptr counts surf@(Surface shtype shVerts col _ _) = case shtype of
-    FlatFaces size -> pokeBox blockshadows col size ptr iptr ieptr counts shVerts
+    FlatFaces size -> pokeBox t col size ptr iptr ieptr counts shVerts
-    RoundedFaces size -> pokeRoundedFaces blockshadows col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces t col size ptr iptr ieptr counts shVerts
-    Cylinder size -> pokeCylinder blockshadows col size ptr iptr ieptr counts shVerts
+    Cylinder size -> pokeCylinder t col size ptr iptr ieptr counts shVerts
+    Cone n -> pokeCone t col n ptr iptr ieptr counts shVerts
   where
-    blockshadows = shadowtest surf
+    t = shadowtest surf
 
 pokeRoundedFaces ::
     Bool ->
@@ -167,7 +168,7 @@ pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = d
   where
     xdata
         | sfid = 0 -- this records whether the shadow should be shown or not
-        -- honestly, I think things where faster without this
+        -- honestly, I think things were faster without this
         | otherwise = 1
 pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined
 
@@ -211,11 +212,19 @@ pokeRoundedCurve xdata col ptr tc bc = go True
     go False (x : xs) n = pokeJustV xdata bc col ptr n x >>= go True xs
     go _ [] n = return n
 
+pokeCone :: Bool -> Color -> Int -> Ptr Float -> Ptr GLuint -> Ptr GLuint 
+    ->  (Int,Int,Int) -> [Point3] -> IO (Int,Int,Int)
+pokeCone t c n ptr iptr ieptr (nv,nsi,nei) (p:ps) = do
+    nv' <- undefined t c n ptr iptr ieptr (nv,nsi,nei) (p:ps)
+    nsi' <- undefined
+    nei' <- undefined
+    return (nv', nsi', nei')
+pokeCone _ _ _ _ _ _ _ _ = undefined
+
 -- I am not completely sure the normals are correct here
 -- they assume that we do actually have a cylinder, with normals for the caps
 -- that can be determined by the first two vertices
-pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> [Point3] -> Int 
+pokeCylinderCaps :: Float -> Point4 -> Ptr Float -> [Point3] -> Int -> IO Int
-    -> IO Int
 {-# INLINE pokeCylinderCaps #-}
 pokeCylinderCaps xdata col ptr (a:b:as) = go True (a:b:as)
   where

src/Shape/Data.hs

@@ -12,6 +12,7 @@ data ShapeType
     = FlatFaces { _topBoxSize :: Int }
     | RoundedFaces { _shapeHalfSize :: Int }
     | Cylinder { _cylinderSize :: Int }
+    | Cone {_coneBaseNum :: Int}
     deriving (Eq, Ord, Show, Read)
 -- for RoundedFaces, the first vertex in _sfVs should be the center of the top
 -- plane, the second should be the center of the bottom plane.