Separate Clouds and Dust

src/Dodge/Cloud.hs

@@ -4,9 +4,8 @@ import Dodge.Data.Cloud
 
 clAlt :: Cloud -> Float
 clAlt cl = case _clType cl of
-    FlamerSmokeCloud -> 90
+    Smoke -> 90
-    RocketCloud -> 30
+    RocketSmoke -> 30
-    Dust _ -> 1
     CryoReleaseCloud -> 50
     GasCloud -> 20
 

src/Dodge/Data/Cloud.hs

@@ -11,31 +11,31 @@ import Data.Aeson
 import Data.Aeson.TH
 import Geometry
 
-data CloudDraw
-    = CloudColor Float-- Color -- radius-multiply fade-time color
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
 data Cloud = Cloud
     { _clPos :: Point3
     , _clVel :: Point3
---    , _clPict :: CloudDraw
---    , _clRad :: Float
---    , _clAlt :: Float
     , _clTimer :: Int
     , _clType :: CloudType
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data CloudType
-    = --SmokeCloud
+    = Smoke
-     FlamerSmokeCloud
+    | RocketSmoke
-    | RocketCloud
     | CryoReleaseCloud
     | GasCloud
-    | Dust Material
+    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+
+data Dust = Dust
+    { _dsPos :: Point3
+    , _dsVel :: Point3
+    , _dsTimer :: Int
+    , _dsType :: Material
+    }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''Cloud
-deriveJSON defaultOptions ''CloudDraw
 deriveJSON defaultOptions ''CloudType
 deriveJSON defaultOptions ''Cloud
+makeLenses ''Dust
+deriveJSON defaultOptions ''Dust

src/Dodge/Data/LWorld.hs

@@ -99,6 +99,7 @@ data LWorld = LWorld
     , _creatureGroups :: IM.IntMap CrGroupParams
     , _itemLocations :: IM.IntMap ItemLocation
     , _clouds :: [Cloud]
+    , _dusts :: [Dust]
     , _gusts :: IM.IntMap Gust
     , _props :: IM.IntMap Prop
     , _projectiles :: IM.IntMap Projectile

src/Dodge/Data/World.hs

@@ -46,6 +46,7 @@ data World = World
     , _worldEventFlags :: Set WorldEventFlag
     , _crZoning :: IntMap (IntMap IntSet)
     , _clZoning :: IntMap (IntMap [Cloud])
+    , _dsZoning :: IntMap (IntMap [Dust])
     , _wlZoning :: IntMap (IntMap IntSet) -- Zoning IM.IntMap Wall
     , _pnZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
     , _peZoning :: IntMap (IntMap (Set PathEdgeNodes))

src/Dodge/Default/World.hs

@@ -48,6 +48,7 @@ defaultWorld =
         , _worldEventFlags = mempty
         , _crZoning = mempty
         , _clZoning = mempty
+        , _dsZoning = mempty
         , _wlZoning = mempty
         , _pnZoning = mempty
         , _peZoning = mempty
@@ -101,6 +102,7 @@ defaultLWorld =
         , _creatures = IM.empty
         , _creatureGroups = IM.empty
         , _clouds = mempty
+        , _dusts = mempty
         , _gusts = IM.empty
         , _itemLocations = IM.empty
         , _props = IM.empty

src/Dodge/EnergyBall/Draw.hs

@@ -45,7 +45,7 @@ drawFlamelet size rot pt =
     siz2 = size + 0.2
     time = _ebTimer pt
     piu =
-        setDepth (z + 25)
+        setDepth (z + 5)
             . uncurryV translate sp
             . color
                 ( mixColors
@@ -61,7 +61,7 @@ drawFlamelet size rot pt =
             . polygon
             $ reverse (rectNSWE siz2 (- siz2) (- siz2) siz2)
     pi2 =
-        setDepth (z + 25)
+        setDepth (z + 5)
             . uncurryV translate sp
             . color
                 ( mixColors
@@ -78,7 +78,7 @@ drawFlamelet size rot pt =
             . reverse
             $ rectNSWE siz2 (- siz2) (- siz2) siz2
     pic =
-        setDepth (z + 20)
+        setDepth (z + 2)
             . uncurryV translate sp
             . color
                 ( mixColors

src/Dodge/Flame.hs

@@ -18,7 +18,7 @@ import RandomHelp
 
 updateFlame :: World -> Flame -> (World, Maybe Flame)
 updateFlame w pt
-    | _flTimer pt <= 0 = (makeCloudAt FlamerSmokeCloud 200 (addZ 20 ep) w, Nothing)
+    | _flTimer pt <= 0 = (makeCloudAt Smoke 200 (addZ 20 ep) w, Nothing)
     | Just (_, Right wl) <- thit = (doupdate, Just $ reflame wl)
     -- might want to move differently if we hit a creature?
     | otherwise = (flFlicker pt doupdate, Just mvflame)

src/Dodge/Material/Damage.hs

@@ -28,10 +28,10 @@ damageStone dm ecw w =
         Lasering _ p t -> makeSpark FireSpark (outTo p t) (rdir p t)
         Piercing _ p t ->
             makeSpark NormalSpark (outTo p t) (rdir p t)
-                . makeCloudAt (Dust Stone) 200 (addZ 20 (outTo p t))
+                . makeDustAt Stone 200 (addZ 20 (outTo p t))
                 . randsound p [slapS, slap1S]
-        Blunt _ p t -> makeCloudAt (Dust Stone) 200 (addZ 20 (outTo p t))
+        Blunt _ p t -> makeDustAt Stone 200 (addZ 20 (outTo p t))
-        Shattering _ p t -> makeCloudAt (Dust Stone) 200 (addZ 20 (outTo p t))
+        Shattering _ p t -> makeDustAt Stone 200 (addZ 20 (outTo p t))
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id
@@ -62,7 +62,7 @@ damageMetal dm ecw w =
         Blunt _ p t ->
             makeSpark NormalSpark (outTo p t) (rdir p t)
                 . randsound p [clangS,clang1S,clang2S]
-        Shattering _ _ _ -> id
+        Shattering {} -> id
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id
@@ -85,7 +85,7 @@ damageMetal dm ecw w =
 
 damageFlesh :: Damage -> ECW -> World -> World
 damageFlesh dm _ w = w & case dm of
-    Lasering _ _ _ -> id
+    Lasering {} -> id
     Piercing _ p t ->
         randsound
             p
@@ -98,7 +98,7 @@ damageFlesh dm _ w = w & case dm of
             , bloodShort7S
             , bloodShort8S
             ]
-                . makeCloudAt (Dust Flesh) 50 (addZ 20 (outTo p t))
+                . makeDustAt Flesh 50 (addZ 20 (outTo p t))
     Blunt _ p _ -> randsound p [hitS]
     Shattering _ _ _ -> id
     Crushing{} -> id
@@ -120,12 +120,12 @@ damageDirt :: Damage -> ECW -> World -> World
 damageDirt dm _ w =
     w & case dm of
         Lasering _ p t -> --  makeSpark FireSpark (outTo p t) (rdir p t)
-            makeCloudAt (Dust Dirt) 200 (addZ 20 (outTo p t))
+            makeDustAt Dirt 200 (addZ 20 (outTo p t))
         Piercing _ p t ->
-            makeCloudAt (Dust Dirt) 200 (addZ 20 (outTo p t))
+            makeDustAt Dirt 200 (addZ 20 (outTo p t))
                 . randsound p [slapS, slap1S]
-        Blunt _ p t -> makeCloudAt (Dust Dirt) 200 (addZ 20 (outTo p t))
+        Blunt _ p t -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
-        Shattering _ p t -> makeCloudAt (Dust Dirt) 200 (addZ 20 (outTo p t))
+        Shattering _ p t -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id

src/Dodge/Projectile/Update.hs

@@ -154,7 +154,7 @@ doThrust pj smoke w =
         & soundContinue (ShellSound i) newPos missileLaunchS (Just 1)
         --        & makeFlamelet (oldPos -.- vel) (vel + 2 * rotateV (pi + sparkD) accel) 3 10
         & makeFlamelet (oldPos -.- vel) (vel +.+ rotateV (pi + sparkD) accel) 3 10
-        & makeCloudAt RocketCloud
+        & makeCloudAt RocketSmoke
             lifetime
             (addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)))
   where

src/Dodge/Render.hs

@@ -86,12 +86,19 @@ doDrawing' win pdata u = do
                 (0, 0, 0)
                 ws
             )
-    (nCloudVs, nCloudIs) <-
+    (nCloudVs', nCloudIs') <-
     -- Might want to sort the clouds based on z depth, not sure
         V.foldM'
             (pokeCloud (pdata ^. cloudVBO . vboPtr) (pdata ^. cloudEBO . eboPtr))
             (0, 0)
             (V.fromList $ w ^. cWorld . lWorld . clouds)
+    (nCloudVs, nCloudIs) <-
+    -- Might want to sort the clouds based on z depth, not sure
+        V.foldM'
+            (pokeDust (pdata ^. cloudVBO . vboPtr) (pdata ^. cloudEBO . eboPtr))
+            (nCloudVs', nCloudIs')
+            (V.fromList $ w ^. cWorld . lWorld . dusts)
+    
             --(sortOn (^. clPos . _3) $ w ^. cWorld . lWorld . clouds)
     -- bind wall points, silhouette data, surface geometry
     bufferShaderLayers shadV pokeCounts
@@ -224,7 +231,7 @@ doDrawing' win pdata u = do
     renderLayer BloomLayer shadV pokeCounts
     -- draw clouds, transparency blocks some alpha
     glDepthMask GL_FALSE
-    glBlendColor 0 0 0 0.2 -- using this and GL_CONSTANT_ALPHA below
+    glBlendColor 0 0 0 0.1 -- using this and GL_CONSTANT_ALPHA below
                            -- can allow for some underlighting of the clouds
     glBlendFuncSeparate GL_ZERO GL_ONE GL_CONSTANT_ALPHA GL_ONE_MINUS_SRC_ALPHA
     glUseProgram (pdata ^. cloudShader . shaderUINT)

src/Dodge/SoundLogic/LoadSound.hs

@@ -25,7 +25,7 @@ loadSounds = do
     putStrLn $ show y <> " channels assigned to group 1"
     fmap IM.fromList $ mapM loadSound $ zip [0..] soundPathList
   where
-    nchans = (64::Int)
+    nchans = 64::Int
 
 loadMusic :: IO (IM.IntMap Mix.Music)
 loadMusic = do

src/Dodge/Update.hs

@@ -280,6 +280,7 @@ functionalUpdate u =
         . over uvWorld (updateIMl' (_props . _lWorld . _cWorld) updateProp)
         . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile)
         . over uvWorld updateClouds
+        . over uvWorld updateDusts
         . over uvWorld updateGusts
         . over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) tmUpdate)
         --    . updateIMl _machines mcChooseUpdate
@@ -296,6 +297,7 @@ functionalUpdate u =
         . over uvWorld updateWheelEvents
         --        . over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
         . over uvWorld zoneClouds
+        . over uvWorld zoneDusts
         . over uvWorld zoneCreatures
         -- . over uvWorld updateInventorySelectionList
         . set (uvWorld . cWorld . lWorld . flares) []
@@ -444,6 +446,9 @@ updateLasers w = w' & cWorld . lWorld . flares <>~ concat ls
 zoneClouds :: World -> World
 zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds)
 
+zoneDusts :: World -> World
+zoneDusts w = w & dsZoning .~ foldl' (flip zoneDust) mempty (w ^. cWorld . lWorld . dusts)
+
 displayTerminalLineString :: TerminalLineString -> World -> (String, Color)
 displayTerminalLineString (TerminalLineConst str col) = const (str, col)
 
@@ -610,6 +615,9 @@ updateSparks = updateObjCatMaybes sparks updateSpark
 updateClouds :: World -> World
 updateClouds = updateObjCatMaybes clouds updateCloud
 
+updateDusts :: World -> World
+updateDusts = updateObjCatMaybes dusts updateDust
+
 --updateBeams :: World -> World
 --updateBeams w =
 --    w
@@ -730,8 +738,6 @@ mvGust _ gu
 cloudEffect :: Cloud -> World -> World
 cloudEffect cl = case _clType cl of
     GasCloud -> cloudPoisonDamage cl
-    RocketCloud -> id
-    CryoReleaseCloud -> id
     _ -> id
 
 updateCloud :: World -> Cloud -> (World, Maybe Cloud)
@@ -755,11 +761,31 @@ updateCloud w c
     newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
     newPos2 = stripZ newPos
     hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w
-    --finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl
-    -- allowing clouds at/above height 75 causes graphical glitches 22.05.23
     finalPos = addZ (max 1 $ min 90 npz) $ maybe newPos2 fst hitWl
     finalVel = addZ nvz $ maybe newVel2 snd hitWl
 
+updateDust :: World -> Dust -> (World, Maybe Dust)
+updateDust w c
+    | _dsTimer c < 1 = (w, Nothing)
+    | otherwise =
+        ( w
+        , Just $
+            c
+                & dsPos .~ finalpos
+                & dsVel .~ newvel
+                & dsTimer -~ 1
+        )
+  where
+    springvel = foldl' (dustSpringVel c) (_dsVel c) (dssNearPoint oldPos2 w)
+    v@(V3 _ _ vz) = springvel
+    newvel = 0.9 * (maybe v (addZ vz . snd) hitWl - V3 0 0 0.05)
+    oldPos = _dsPos c
+    oldPos2 = stripZ oldPos
+    newPos@(V3 _ _ npz) = oldPos + v
+    newPos2 = stripZ newPos
+    hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w
+    finalpos = addZ (max 1 $ min 90 npz) $ maybe newPos2 fst hitWl
+
 clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3
 clClSpringVel a v b
     | dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb)
@@ -770,6 +796,15 @@ clClSpringVel a v b
     radDist = 10
     --radDist = (_clRad a + _clRad b) / 2
 
+dustSpringVel :: Dust -> Point3 -> Dust -> Point3
+dustSpringVel a v b
+    | dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb)
+    | otherwise = v
+  where
+    pa = _dsPos a
+    pb = _dsPos b
+    radDist = 10
+
 simpleCrSprings :: World -> World
 simpleCrSprings w = IM.foldl' (flip crSpring) w $ w ^. cWorld . lWorld . creatures
 

src/Dodge/Wall/Dust.hs

@@ -12,7 +12,7 @@ muchWlDustAt wl p = flip (foldl' f) [10, 20 .. 100]
   where
     f w h =
         w
-            & makeCloudAt (Dust (_wlMaterial wl)) 200 (addZ h (p +.+ off))
+            & makeDustAt (_wlMaterial wl) 200 (addZ h (p +.+ off))
             & randGen .~ g
       where
         (off, g) = runState (randInCirc 1) (_randGen w)

src/Dodge/WorldEvent/Cloud.hs

@@ -1,4 +1,4 @@
-module Dodge.WorldEvent.Cloud (makeCloudAt) where
+module Dodge.WorldEvent.Cloud (makeCloudAt,makeDustAt) where
 
 import Dodge.Data.World
 import Geometry.Data
@@ -13,3 +13,13 @@ makeCloudAt ct t p =
             , _clTimer = t
             , _clType = ct
             }
+
+makeDustAt :: Material -> Int -> Point3 -> World -> World
+makeDustAt ct t p =
+    cWorld . lWorld . dusts
+        .:~ Dust
+            { _dsPos = p
+            , _dsVel = V3 0 0 0
+            , _dsTimer = t
+            , _dsType = ct
+            }

src/Dodge/Zone/Size.hs

@@ -2,3 +2,4 @@ module Dodge.Zone.Size where
 
 clZoneSize :: Float
 clZoneSize = 20
+

src/Dodge/Zoning/Cloud.hs

@@ -26,3 +26,24 @@ zoneOfCl = zoneOfPoint clZoneSize . xyV3 . _clPos
 
 zoneCloud :: Cloud -> IM.IntMap (IM.IntMap [Cloud]) -> IM.IntMap (IM.IntMap [Cloud])
 zoneCloud cl = zoneMonoid (zoneOfCl cl) [cl]
+
+dssNearPoint :: Point2 -> World -> [Dust]
+dssNearPoint = nearPoint dsZoneSize _dsZoning
+
+dssNearSeg :: Point2 -> Point2 -> World -> [Dust]
+dssNearSeg = nearSeg dsZoneSize _dsZoning
+
+dssNearRect :: Point2 -> Point2 -> World -> [Dust]
+dssNearRect = nearRect dsZoneSize _dsZoning
+
+dssNearCirc :: Point2 -> Float -> World -> [Dust]
+dssNearCirc p r = dssNearRect (p +.+ V2 r r) (p -.- V2 r r)
+
+dsZoneSize :: Float
+dsZoneSize = 20
+
+zoneOfDs :: Dust -> Int2
+zoneOfDs = zoneOfPoint dsZoneSize . xyV3 . _dsPos
+
+zoneDust :: Dust -> IM.IntMap (IM.IntMap [Dust]) -> IM.IntMap (IM.IntMap [Dust])
+zoneDust cl = zoneMonoid (zoneOfDs cl) [cl]

src/Shader/Poke/Cloud.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Shader.Poke.Cloud (pokeCloud) where
+module Shader.Poke.Cloud (pokeCloud,pokeDust) where
 
 import Dodge.Data.Material
 import Color
@@ -34,11 +34,42 @@ pokeCloudVerx ptr cl nv i (dx, dy) =
 
 clColor :: CloudType -> Color
 clColor = \case
-    FlamerSmokeCloud -> greyN 0.7
+    Smoke -> greyN 0.7
-    RocketCloud -> greyN 0.5
+    RocketSmoke -> greyN 0.5
     CryoReleaseCloud -> white
     GasCloud -> green
-    Dust mt -> materialColor mt
+
+pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
+{-# INLINE pokeCloudFloat #-}
+pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
+
+pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
+{-# INLINE pokeCloudIndex #-}
+pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)
+
+pokeDust :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Dust -> IO (Int, Int)
+pokeDust vptr iptr (nv, ni) cl = do
+    UV.imapM_ (pokeDustVerx vptr cl nv) $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
+    UV.imapM_ (pokeDustIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
+    return (nv + 4, ni + 6)
+
+pokeDustVerx :: Ptr Float -> Dust -> Int -> Int -> (Float, Float) -> IO ()
+{-# INLINE pokeDustVerx #-}
+pokeDustVerx ptr cl nv i (dx, dy) =
+    UV.imapM_ (pokeDustFloat ptr (nv + i)) $
+        UV.fromList
+            [x, y, cz, 1, r, g, b, a, cx, cy, cz, rad, dx, dy, 0, 0]
+  where
+    V3 cx cy cz = _dsPos cl
+    V2 x y = V2 cx cy - rad *.* V2 dx dy
+    --CloudColor fadet col = _clPict cl
+--    CloudColor fadet = _clPict cl
+    (rad, V4 r g b a') = (20, dustColor cl)
+    --    (rad,V4 r g b a') = (_clRad cl*rad', col)
+    a = a' * min 1 (fromIntegral (_dsTimer cl) / 100)
+
+dustColor :: Dust -> Color
+dustColor = materialColor . _dsType
 
 materialColor :: Material -> Color
 materialColor = withAlpha 0.5 . \case
@@ -52,10 +83,10 @@ materialColor = withAlpha 0.5 . \case
     Electronics-> greyN 0.2
 
 
-pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
+pokeDustFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
-{-# INLINE pokeCloudFloat #-}
+{-# INLINE pokeDustFloat #-}
-pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
+pokeDustFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
 
-pokeCloudIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
+pokeDustIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
-{-# INLINE pokeCloudIndex #-}
+{-# INLINE pokeDustIndex #-}
-pokeCloudIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)
+pokeDustIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)