Add bee pheremones

src/Dodge/Creature/Update.hs

@@ -331,18 +331,20 @@ checkDeath' cr w = case cr ^. crHP of
             & dropAll cr -- the order of these is possibly important
             & stopSoundFrom (CrWeaponSound (_crID cr) 0)
             & corpseOrGib cr
-            & crEffectsOnDeath cr
+            & crDeathEffects cr
             & tocr . crStance . carriage %~ toDeathCarriage
     _ -> w
   where
     tocr = cWorld . lWorld . creatures . ix (_crID cr)
 
-crEffectsOnDeath :: Creature -> World -> World
-crEffectsOnDeath cr w = case cr ^. crType of
-    BeeCrit {_beeHive = mhid} -> fromMaybe w $ do
+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 = cWorld . lWorld . beePheremones .:~ BPheremone (cr ^. crPos . _xy) 200
 
 startDeathTimer :: Creature -> Creature
 startDeathTimer cr = cr & crDeathTimer ?~ case cr ^. crType of

src/Dodge/Data/Cloud.hs

@@ -42,9 +42,16 @@ data Gas = Gas
 data GasType = PoisonGas
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
+data BeePheremone = BPheremone
+    { _bpPos :: Point2
+    , _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/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

src/Dodge/Default/World.hs

@@ -114,6 +114,7 @@ defaultLWorld =
         , _creatures = IM.empty
         , _creatureGroups = IM.empty
         , _clouds = mempty
+        , _beePheremones = mempty
         , _gasses = mempty
         , _dusts = mempty
         , _gusts = IM.empty

src/Dodge/Render.hs

@@ -77,10 +77,15 @@ doDrawing' win pdata u = do
                 (0, 0, 0)
                 ws
             )
+    ncvs'' <- -- foldM (pokeCloud $ pdata ^. cloudVBO . vboPtr) 0 (w ^. cWorld . lWorld . clouds)
+        V.foldM'
+            (pokeBeePheremone (pdata ^. cloudVBO . vboPtr))
+            0
+            (V.fromList $ w ^. cWorld . lWorld . beePheremones)
     nCloudVs' <- -- foldM (pokeCloud $ pdata ^. cloudVBO . vboPtr) 0 (w ^. cWorld . lWorld . clouds)
         V.foldM'
             (pokeCloud (pdata ^. cloudVBO . vboPtr))
-            0
+            ncvs''
             (V.fromList $ w ^. cWorld . lWorld . clouds)
     nCloudVs <-
         V.foldM'

src/Dodge/Update.hs

@@ -316,6 +316,7 @@ functionalUpdate =
             (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave)
         . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
         . over uvWorld updateClouds
+        . over uvWorld updateBeePheremones
         . over uvWorld updateGasses
         . over uvWorld updateDusts
         . over uvWorld updateGusts
@@ -779,6 +780,15 @@ updateSparks = updateObjCatMaybes sparks updateSpark
 updateClouds :: World -> World
 updateClouds w = updateObjMapMaybe clouds (updateCloud w) w
 
+updateBeePheremones :: World -> World
+updateBeePheremones w = updateObjMapMaybe beePheremones updateBeePheremone w
+
+updateBeePheremone :: BeePheremone -> Maybe BeePheremone
+updateBeePheremone bp 
+    | x <- bp ^. bpTimer
+    , x <= 0 = Nothing
+    | otherwise = Just $ bp & bpTimer -~ 1
+
 updateGasses :: World -> World
 updateGasses = updateObjCatMaybes gasses updateGas
 

src/Shader/Poke/Cloud.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Shader.Poke.Cloud (pokeCloud, pokeDust) where
+module Shader.Poke.Cloud (pokeCloud, pokeDust, pokeBeePheremone) where
 
+import Linear
 import Shader.Parameters
 import Color
 import Control.Lens
@@ -18,6 +19,15 @@ pokeDust :: Ptr Float -> Int -> Dust -> IO Int
 {-# INLINE pokeDust #-}
 pokeDust vptr nv = pokeCloudLike vptr nv . mkDustCloudLike
 
+pokeBeePheremone :: Ptr Float -> Int -> BeePheremone -> IO Int
+{-# INLINE pokeBeePheremone #-}
+pokeBeePheremone vptr nv = pokeCloudLike vptr nv . mkBeePheremoneCloudLike
+
+mkBeePheremoneCloudLike :: BeePheremone -> (Point3, Point4)
+mkBeePheremoneCloudLike x = (20 & _xy .~ (x ^. bpPos), V4 1 1 0 a)
+  where
+    a = 0.8 * min 1 (fromIntegral (_bpTimer x) / 100)
+
 mkCloudCloudLike :: Cloud -> (Point3, Point4)
 mkCloudCloudLike x = (x ^. clPos, V4 r g b a)
   where