Refactor clouds

src/Dodge/Cloud.hs

@@ -1,13 +1,24 @@
-module Dodge.Cloud where
+module Dodge.Cloud (clAlt) where
 
 import Dodge.Data.Cloud
 
-cRad :: Cloud -> Float
-cRad cl = case _clType cl of
-    SmokeCloud -> 0
-    FlamerSmokeCloud -> 6
-    RocketCloud -> 15
-    StoneDust -> 15
-    CryoReleaseCloud -> 10
-    GasCloud -> 15
+clAlt :: Cloud -> Float
+clAlt cl = case _clType cl of
+    SmokeCloud -> 30
+    FlamerSmokeCloud -> 30
+    RocketCloud -> 30
+    StoneDust -> 1
+    DirtDust -> 1
+    CryoReleaseCloud -> 50
+    GasCloud -> 20
+    BloodCloud -> 1
 
+--clRad :: Cloud -> Float
+--clRad cl = case _clType cl of
+--    SmokeCloud -> 15
+--    FlamerSmokeCloud -> 6
+--    RocketCloud -> 15
+--    StoneDust -> 15
+--    CryoReleaseCloud -> 10
+--    GasCloud -> 15
+--    BloodCloud -> 10

src/Dodge/Data/Cloud.hs

@@ -5,7 +5,6 @@
 
 module Dodge.Data.Cloud where
 
-import Color
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -20,7 +19,7 @@ data Cloud = Cloud
     , _clVel :: Point3
 --    , _clPict :: CloudDraw
 --    , _clRad :: Float
-    , _clAlt :: Float
+--    , _clAlt :: Float
     , _clTimer :: Int
     , _clType :: CloudType
     }
@@ -33,6 +32,8 @@ data CloudType
     | CryoReleaseCloud
     | GasCloud
     | StoneDust
+    | DirtDust
+    | BloodCloud
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''Cloud

src/Dodge/Flame.hs

@@ -18,7 +18,7 @@ import RandomHelp
 
 updateFlame :: World -> Flame -> (World, Maybe Flame)
 updateFlame w pt
-    | _flTimer pt <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
+    | _flTimer pt <= 0 = (makeCloudAt FlamerSmokeCloud 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

@@ -1,6 +1,5 @@
 module Dodge.Material.Damage (damMatSideEffect) where
 
-import Color
 import Control.Lens
 import Dodge.Data.World
 import Dodge.SoundLogic
@@ -29,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)
-                . smokeCloudAt white 200 1 (addZ 20 (outTo p t))
+                . makeCloudAt StoneDust 200 (addZ 20 (outTo p t))
                 . randsound p [slapS, slap1S]
-        Blunt _ p t -> smokeCloudAt white 200 1 (addZ 20 (outTo p t))
-        Shattering _ p t -> smokeCloudAt white 200 1 (addZ 20 (outTo p t))
+        Blunt _ p t -> makeCloudAt StoneDust 200 (addZ 20 (outTo p t))
+        Shattering _ p t -> makeCloudAt StoneDust 200 (addZ 20 (outTo p t))
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id
@@ -101,7 +100,7 @@ damageFlesh dm _ w = w & case dm of
             , bloodShort7S
             , bloodShort8S
             ]
-                . smokeCloudAt red 200 1 (addZ 20 (outTo p t))
+                . makeCloudAt BloodCloud 50 (addZ 20 (outTo p t))
     Blunt _ p _ -> randsound p [hitS]
     Shattering _ _ _ -> id
     Crushing{} -> id
@@ -124,10 +123,10 @@ damageDirt dm ecw w =
     w & case dm of
         Lasering _ p t -> makeSpark FireSpark (outTo p t) (rdir p t)
         Piercing _ p t ->
-            smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
+            makeCloudAt DirtDust 200 (addZ 20 (outTo p t))
                 . randsound p [slapS, slap1S]
-        Blunt _ p t -> smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
-        Shattering _ p t -> smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
+        Blunt _ p t -> makeCloudAt DirtDust 200 (addZ 20 (outTo p t))
+        Shattering _ p t -> makeCloudAt DirtDust 200 (addZ 20 (outTo p t))
         Crushing{} -> id
         Explosive{} -> id
         Sparking{} -> id

src/Dodge/Projectile/Update.hs

@@ -154,16 +154,15 @@ 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
-        & shellTrailCloud
+        & makeCloudAt RocketCloud
             lifetime
-            trailfadetime
             (addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)))
   where
     lifetime = fst . randomR lt $ _randGen w
     lt
         | smoke == Just ReducedRocketSmoke = (50, 200)
         | otherwise = (300, 500)
-    trailfadetime = fst . randomR (100, 300) $ _randGen w
+--    trailfadetime = fst . randomR (100, 300) $ _randGen w
     accel = rotateV (pj ^. pjDir) (V2 3 0)
     i = _pjID pj
     oldPos = _pjPos pj

src/Dodge/Update.hs

@@ -7,6 +7,7 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
+import Dodge.Cloud
 import Dodge.Creature.Radius
 import Dodge.Creature.Mass
 import Dodge.Damage
@@ -748,7 +749,7 @@ updateCloud w c
   where
     newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel)
     newVel2 = stripZ newVel
-    vertVel = _clAlt c - opz
+    vertVel = clAlt c - opz
     springVels = foldl' (clClSpringVel c) (_clVel c) (clsNearPoint oldPos2 w)
     oldPos@(V3 _ _ opz) = _clPos c
     oldPos2 = stripZ oldPos

src/Dodge/Wall/Dust.hs

@@ -8,17 +8,17 @@ import Geometry
 import RandomHelp
 
 wlDustAt :: Wall -> Point2 -> World -> World
-wlDustAt wl = smokeCloudAt dustcol 200 1 . addZ 20
-  where
-    dustcol = _wlColor wl & _4 .~ 1
+wlDustAt _ = makeCloudAt StoneDust 200 . addZ 20
+--  where
+--    dustcol = _wlColor wl & _4 .~ 1
 
 muchWlDustAt :: Wall -> Point2 -> World -> World
 muchWlDustAt wl p = flip (foldl' f) [10, 20 .. 100]
   where
     f w h =
         w
-            & smokeCloudAt dustcol 200 1 (addZ h (p +.+ off))
+            & makeCloudAt StoneDust 200 (addZ h (p +.+ off))
             & randGen .~ g
       where
         (off, g) = runState (randInCirc 1) (_randGen w)
-    dustcol = _wlColor wl & _4 .~ 1
+--    dustcol = _wlColor wl & _4 .~ 1

src/Dodge/WorldEffect.hs

@@ -34,7 +34,7 @@ doWdWd we = case we of
     AccessTerminal mtmid -> accessTerminal mtmid
     WorldEffects wes -> \w -> foldr doWdWd w wes
     UnlockInv -> unlockInv
-    MakeStartCloudAt p -> makeStartCloudAt p
+    MakeStartCloudAt p -> makeCloudAt CryoReleaseCloud 400 p
     TorqueCr x cid -> torqueCr x cid
     SoundStart so p sid mi -> soundStart so p sid mi
     WdWdNegateTrig trid -> cWorld . lWorld . triggers . ix trid %~ not

src/Dodge/WorldEvent/Cloud.hs

@@ -1,76 +1,15 @@
-module Dodge.WorldEvent.Cloud (
-    makeFlamerSmokeAt,
-    smokeCloudAt,
---    makeThinSmokeAt,
---    makeThickSmokeAt,
-    shellTrailCloud,
-    spawnSmokeAtCursor,
-    makeStartCloudAt,
-) where
+module Dodge.WorldEvent.Cloud (makeCloudAt) where
 
-import Dodge.Base
 import Dodge.Data.World
 import Geometry.Data
 import LensHelp
-import Picture
---import System.Random
 
-makeCloudAt ::
---    CloudDraw ->
---    -- | radius
---    Float ->
-    -- | timer
-    Int ->
-    -- | resting altitude
-    Float ->
-    Point3 -> -- start position
-    World ->
-    World
-makeCloudAt t alt p =
+makeCloudAt :: CloudType -> Int -> Point3 -> World -> World
+makeCloudAt ct t p =
     cWorld . lWorld . clouds
         .:~ Cloud
             { _clPos = p
             , _clVel = V3 0 0 0
---            , _clPict = drawFunc
---            , _clRad = rad
-            , _clAlt = alt
             , _clTimer = t
-            , _clType = SmokeCloud
+            , _clType = ct
             }
-
-smokeCloudAt ::
-    Color ->
-    -- | radius
---    Float ->
-    -- | timer
-    Int ->
-    -- | resting altitude
-    Float ->
-    Point3 -> -- start position
-    World ->
-    World
-smokeCloudAt col = makeCloudAt
-
---makeThickSmokeAt :: Point3 -> World -> World
---makeThickSmokeAt = makeCloudAt 50 30
---
---makeThinSmokeAt :: Point3 -> World -> World
---makeThinSmokeAt = makeCloudAt 400 50
-
-makeStartCloudAt :: Point3 -> World -> World
---makeStartCloudAt = makeCloudAt (CloudColor 2 800 white) 10 400 5
---makeStartCloudAt = makeCloudAt (CloudColor 2 200 white) 10 400 50
-makeStartCloudAt = makeCloudAt 400 50
-
-shellTrailCloud :: Int -> Float -> Point3 -> World -> World
-shellTrailCloud age fadet = makeCloudAt age 30
-
-makeFlamerSmokeAt :: Point3 -> World -> World
-makeFlamerSmokeAt p w = makeCloudAt 200 40 p w
---  where
---    x = fst $ randomR (0.5, 0.8) (_randGen w)
-
-spawnSmokeAtCursor :: World -> World
-spawnSmokeAtCursor w = shellTrailCloud 400 100 (V3 x y 20) w
-  where
-    V2 x y = mouseWorldPos (w ^. input) (w ^. wCam)

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -15,22 +15,14 @@ makeGasCloud ::
     Point2 ->
     World ->
     World
-makeGasCloud pos vel w =
-    w
-        & cWorld . lWorld . clouds .:~ theCloud
+makeGasCloud pos vel = cWorld . lWorld . clouds .:~ theCloud
   where
-    --        & randGen .~ g
-
     theCloud =
         Cloud
             { _clPos = addZ 20 pos
             , _clVel = addZ 0 vel
---            , _clPict = CloudColor 50 -- (withAlpha 0.5 col)
-            , _clAlt = 25
             , _clTimer = 400
             , _clType = GasCloud
             }
 
---    (col, g) = runState (takeOne [green, yellow]) $ _randGen w
-
 {- Attach poison cloud damage to creatures near cloud.  -}

src/Shader/Poke/Cloud.hs

@@ -34,11 +34,13 @@ pokeCloudVerx ptr cl nv i (dx, dy) =
 clColor :: CloudType -> Color
 clColor = \case
     SmokeCloud -> white
-    FlamerSmokeCloud -> black
+    FlamerSmokeCloud -> greyN 0.7
     RocketCloud -> greyN 0.5
-    CryoReleaseCloud -> blue
+    CryoReleaseCloud -> mixColorsFrac blue cyan 0.5
     GasCloud -> green
     StoneDust -> white
+    DirtDust -> dark orange
+    BloodCloud -> red
 
 pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
 {-# INLINE pokeCloudFloat #-}