justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Separate Clouds and Dust

Browse Source
This commit is contained in:
justin
2025-06-25 14:51:15 +01:00
parent d61ea304ad
commit d4b2f23c9d
19 changed files with 341 additions and 213 deletions
Download Patch File Download Diff File Expand all files Collapse all files
saveSlot/LevelStart0
+1 -1
View File
File diff suppressed because one or more lines are too long
src/Dodge/Cloud.hs
+2 -3
View File
@@ -4,9 +4,8 @@ import Dodge.Data.Cloud
clAlt :: Cloud -> Float
clAlt cl = case _clType cl of
FlamerSmokeCloud -> 90
RocketCloud -> 30
Dust _ -> 1
Smoke -> 90
RocketSmoke -> 30
CryoReleaseCloud -> 50
GasCloud -> 20
src/Dodge/Data/Cloud.hs
+12 -12
View File
@@ -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
FlamerSmokeCloud
| RocketCloud
= Smoke
| RocketSmoke
| 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
+1
View File
@@ -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
+1
View File
@@ -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
+2
View File
@@ -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
+3 -3
View File
@@ -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
+1 -1
View File
@@ -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
+10 -10
View File
@@ -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))
Shattering _ 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 -> 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))
Shattering _ 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 -> makeDustAt Dirt 200 (addZ 20 (outTo p t))
Crushing{} -> id
Explosive{} -> id
Sparking{} -> id
src/Dodge/Projectile/Update.hs
+1 -1
View File
@@ -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
+9 -2
View File
@@ -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
+1 -1
View File
@@ -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
+39 -4
View File
@@ -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
+1 -1
View File
@@ -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
+11 -1
View File
@@ -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
+1
View File
@@ -2,3 +2,4 @@ module Dodge.Zone.Size where
clZoneSize :: Float
clZoneSize = 20
src/Dodge/Zoning/Cloud.hs
+21
View File
@@ -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
+41 -10
View File
@@ -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
RocketCloud -> greyN 0.5
Smoke -> greyN 0.7
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 ()
{-# INLINE pokeCloudFloat #-}
pokeCloudFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)
pokeDustFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
{-# INLINE pokeDustFloat #-}
pokeDustFloat 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)
pokeDustIndex :: Ptr GLushort -> Int -> Int -> Int -> Int -> IO ()
{-# INLINE pokeDustIndex #-}
pokeDustIndex ptr nv ni ioff voff = pokeElemOff ptr (ni + ioff) (fromIntegral $ nv + voff)
tags
+183 -163
View File
File diff suppressed because it is too large Load Diff