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

Simplify clouds

Browse Source
This commit is contained in:
justin
2025-06-24 09:42:51 +01:00
parent 366b998989
commit b1041d1eb0
12 changed files with 110 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Bullet.hs
+9 -9
View File
@@ -1,5 +1,6 @@
module Dodge.Bullet (updateBullet) where
import Dodge.Damage
import Data.Bifunctor
import Data.Foldable
import Data.Maybe
@@ -167,21 +168,20 @@ hitEffFromBul w bu = case _buEffect bu of
sp = _buPos bu
hitstream = thingsHit sp (sp + _buVel bu) w
setFromToDams :: Bullet -> Point2 -> [Damage]
setFromToDams bu p = case _buPayload bu of
getBulHitDams :: Bullet -> Point2 -> [Damage]
getBulHitDams bu p = case _buPayload bu of
BulPlain x -> [Piercing x p v]
_ -> []
where
v = _buVel bu
-- f = (dmFrom .~ _buPos bu) . (dmAt .~ p) . (dmTo .~ _buPos bu +.+ _buVel bu)
damageThingHit :: Bullet -> (Point2, Either Creature Wall) -> World -> World
damageThingHit bu (p, crwl) = case crwl of
Left cr -> cWorld . lWorld . creatures . ix (_crID cr) . crDamage <>~ dams
Right wl -> cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty <>~ dams
where
dams = setFromToDams bu p
damageThingHit bu (p, crwl) = damageCrWl (getBulHitDams bu p) crwl
-- case crwl of
-- Left cr -> cWorld . lWorld . creatures . ix (_crID cr) . crDamage <>~ dams
-- Right wl -> cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty <>~ dams
-- where
-- dams = setFromToDams bu p
expireAndDamage ::
Bullet ->
src/Dodge/Damage.hs
+4 -4
View File
@@ -20,13 +20,13 @@ import Geometry.Vector
import LensHelp
import ListHelp
damageCrWlID :: Damage -> CrWlID -> World -> World
damageCrWlID :: [Damage] -> CrWlID -> World -> World
damageCrWlID dam = \case
NothingID -> id
CrID cid -> cWorld . lWorld . creatures . ix cid . crDamage .:~ dam
WlID wlid -> cWorld . lWorld . wallDamages . at wlid . non mempty .:~ dam
CrID cid -> cWorld . lWorld . creatures . ix cid . crDamage <>~ dam
WlID wlid -> cWorld . lWorld . wallDamages . at wlid . non mempty <>~ dam
damageCrWl :: Damage -> Either Creature Wall -> World -> World
damageCrWl :: [Damage] -> Either Creature Wall -> World -> World
damageCrWl dam = \case
Left cr -> damageCrWlID dam (CrID (_crID cr))
Right wl -> damageCrWlID dam (WlID (_wlID wl))
src/Dodge/Data/Cloud.hs
+3 -3
View File
@@ -12,14 +12,14 @@ import Data.Aeson.TH
import Geometry
data CloudDraw
= CloudColor Float Float Color -- radius-multiply fade-time color
= 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
-- , _clPict :: CloudDraw
-- , _clRad :: Float
, _clAlt :: Float
, _clTimer :: Int
, _clType :: CloudType
src/Dodge/Material/Damage.hs
+7 -7
View File
@@ -29,10 +29,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 20 200 1 (addZ 20 (outTo p t))
. smokeCloudAt white 200 1 (addZ 20 (outTo p t))
. randsound p [slapS, slap1S]
Blunt _ p t -> smokeCloudAt white 20 200 1 (addZ 20 (outTo p t))
Shattering _ p t -> smokeCloudAt white 20 200 1 (addZ 20 (outTo p t))
Blunt _ p t -> smokeCloudAt white 200 1 (addZ 20 (outTo p t))
Shattering _ p t -> smokeCloudAt white 200 1 (addZ 20 (outTo p t))
Crushing{} -> id
Explosive{} -> id
Sparking{} -> id
@@ -101,7 +101,7 @@ damageFlesh dm _ w = w & case dm of
, bloodShort7S
, bloodShort8S
]
. smokeCloudAt red 20 200 1 (addZ 20 (outTo p t))
. smokeCloudAt red 200 1 (addZ 20 (outTo p t))
Blunt _ p _ -> randsound p [hitS]
Shattering _ _ _ -> id
Crushing{} -> id
@@ -124,10 +124,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 20 200 1 (addZ 20 (outTo p t))
smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
. randsound p [slapS, slap1S]
Blunt _ p t -> smokeCloudAt orange 20 200 1 (addZ 20 (outTo p t))
Shattering _ p t -> smokeCloudAt orange 20 200 1 (addZ 20 (outTo p t))
Blunt _ p t -> smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
Shattering _ p t -> smokeCloudAt orange 200 1 (addZ 20 (outTo p t))
Crushing{} -> id
Explosive{} -> id
Sparking{} -> id
src/Dodge/Spark.hs
+4 -4
View File
@@ -36,11 +36,11 @@ updateSpark w sk
sparkDam :: Spark -> Either Creature Wall -> World -> World
sparkDam = damageCrWl . sparkToDamage
sparkToDamage :: Spark -> Damage
sparkToDamage :: Spark -> [Damage]
sparkToDamage sp = case _skType sp of
ElectricSpark -> Electrical 10
FireSpark -> Flaming 1
NormalSpark -> Sparking 10
ElectricSpark -> [Electrical 10]
FireSpark -> [Flaming 1]
NormalSpark -> [Sparking 10]
makeSpark :: SparkType -> Point2 -> Float -> World -> World
makeSpark st p d =
src/Dodge/Update.hs
+3 -2
View File
@@ -577,7 +577,7 @@ updateTeslaArc w pt
, randWallReflect ld' wl
)
| ArcStep lp' ld' _ <- last thearc = (lp', rp ld')
damthings (ArcStep _ _ crwl) = damageCrWlID (Electrical 50) crwl
damthings (ArcStep _ _ crwl) = damageCrWlID [Electrical 50] crwl
randWallReflect :: RandomGen g => Float -> Wall -> State g Float
randWallReflect a wl = randPeaked a1 outa a2
@@ -766,7 +766,8 @@ clClSpringVel a v b
where
pa = _clPos a
pb = _clPos b
radDist = (_clRad a + _clRad b) / 2
radDist = 10
--radDist = (_clRad a + _clRad b) / 2
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldl' (flip crSpring) w $ w ^. cWorld . lWorld . creatures
src/Dodge/Update/Cloud.hs
+1 -1
View File
@@ -12,5 +12,5 @@ cloudPoisonDamage c w = foldl' (flip doDam) w (filter f $ crsNearPoint clpos w)
where
doDam cr =
cWorld . lWorld . creatures . ix (_crID cr) . crDamage .:~ Poison 1
f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < crRad (cr ^. crType) + _clRad c + 10
f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < crRad (cr ^. crType) + 20
clpos = stripZ $ _clPos c
src/Dodge/Wall/Dust.hs
+2 -2
View File
@@ -8,7 +8,7 @@ import Geometry
import RandomHelp
wlDustAt :: Wall -> Point2 -> World -> World
wlDustAt wl = smokeCloudAt dustcol 20 200 1 . addZ 20
wlDustAt wl = smokeCloudAt dustcol 200 1 . addZ 20
where
dustcol = _wlColor wl & _4 .~ 1
@@ -17,7 +17,7 @@ muchWlDustAt wl p = flip (foldl' f) [10, 20 .. 100]
where
f w h =
w
& smokeCloudAt dustcol 20 200 1 (addZ h (p +.+ off))
& smokeCloudAt dustcol 200 1 (addZ h (p +.+ off))
& randGen .~ g
where
(off, g) = runState (randInCirc 1) (_randGen w)
src/Dodge/WorldEvent/Cloud.hs
+21 -21
View File
@@ -1,8 +1,8 @@
module Dodge.WorldEvent.Cloud (
makeFlamerSmokeAt,
smokeCloudAt,
makeThinSmokeAt,
makeThickSmokeAt,
-- makeThinSmokeAt,
-- makeThickSmokeAt,
shellTrailCloud,
spawnSmokeAtCursor,
makeStartCloudAt,
@@ -13,12 +13,12 @@ import Dodge.Data.World
import Geometry.Data
import LensHelp
import Picture
import System.Random
--import System.Random
makeCloudAt ::
CloudDraw ->
-- | radius
Float ->
-- CloudDraw ->
-- -- | radius
-- Float ->
-- | timer
Int ->
-- | resting altitude
@@ -26,13 +26,13 @@ makeCloudAt ::
Point3 -> -- start position
World ->
World
makeCloudAt drawFunc rad t alt p =
makeCloudAt t alt p =
cWorld . lWorld . clouds
.:~ Cloud
{ _clPos = p
, _clVel = V3 0 0 0
, _clPict = drawFunc
, _clRad = rad
-- , _clPict = drawFunc
-- , _clRad = rad
, _clAlt = alt
, _clTimer = t
, _clType = SmokeCloud
@@ -41,7 +41,7 @@ makeCloudAt drawFunc rad t alt p =
smokeCloudAt ::
Color ->
-- | radius
Float ->
-- Float ->
-- | timer
Int ->
-- | resting altitude
@@ -49,26 +49,26 @@ smokeCloudAt ::
Point3 -> -- start position
World ->
World
smokeCloudAt col = makeCloudAt (CloudColor (4 / 3) 800 col)
smokeCloudAt col = makeCloudAt
makeThickSmokeAt :: Point3 -> World -> World
makeThickSmokeAt = makeCloudAt (CloudColor 4 50 black) 3 50 30
makeThinSmokeAt :: Point3 -> World -> World
makeThinSmokeAt = makeCloudAt (CloudColor 4 400 (withAlpha 0.05 black)) 5 400 50
--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 (CloudColor 2 200 white) 10 400 50
makeStartCloudAt = makeCloudAt 400 50
shellTrailCloud :: Int -> Float -> Point3 -> World -> World
shellTrailCloud age fadet = makeCloudAt (CloudColor (3 / 2) fadet (greyN 0.5)) 15 age 30
shellTrailCloud age fadet = makeCloudAt age 30
makeFlamerSmokeAt :: Point3 -> World -> World
makeFlamerSmokeAt p w = makeCloudAt (CloudColor 4 300 (greyN x)) 6 200 40 p w
where
x = fst $ randomR (0.5, 0.8) (_randGen w)
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
src/Dodge/WorldEvent/SpawnParticle.hs
+8 -9
View File
@@ -1,13 +1,11 @@
-- | Creation of particles in the world.
module Dodge.WorldEvent.SpawnParticle (
makeGasCloud,
) where
module Dodge.WorldEvent.SpawnParticle (makeGasCloud) where
import Dodge.Data.World
import Geometry
import LensHelp
import Picture
import RandomHelp
--import Picture
--import RandomHelp
-- | At writing the radius is half the size of the effect area
makeGasCloud ::
@@ -20,18 +18,19 @@ makeGasCloud ::
makeGasCloud pos vel w =
w
& cWorld . lWorld . clouds .:~ theCloud
& randGen .~ g
where
-- & randGen .~ g
theCloud =
Cloud
{ _clPos = addZ 20 pos
, _clVel = addZ 0 vel
, _clPict = CloudColor 3 50 (withAlpha 0.5 col)
, _clRad = 10
-- , _clPict = CloudColor 50 -- (withAlpha 0.5 col)
, _clAlt = 25
, _clTimer = 400
, _clType = GasCloud
}
(col, g) = runState (takeOne [green, yellow]) $ _randGen w
-- (col, g) = runState (takeOne [green, yellow]) $ _randGen w
{- Attach poison cloud damage to creatures near cloud. -}
src/Shader/Poke/Cloud.hs
+23 -9
View File
@@ -1,7 +1,9 @@
module Shader.Poke.Cloud (
pokeCloud,
) where
{-# LANGUAGE LambdaCase #-}
module Shader.Poke.Cloud (pokeCloud) where
import Color
import Control.Lens
import qualified Data.Vector.Unboxed as UV
import Dodge.Data.Cloud
import Foreign
@@ -9,7 +11,7 @@ import Geometry
import Graphics.GL.Core45
pokeCloud :: Ptr Float -> Ptr GLushort -> (Int, Int) -> Cloud -> IO (Int, Int)
pokeCloud vptr iptr (nv,ni) cl = do
pokeCloud vptr iptr (nv, ni) cl = do
UV.imapM_ (pokeCloudVerx vptr cl nv) $ UV.fromList [(1, 1), (-1, 1), (-1, -1), (1, -1)]
UV.imapM_ (pokeCloudIndex iptr nv ni) $ UV.fromList [0, 1, 2, 2, 0, 3]
return (nv + 4, ni + 6)
@@ -17,14 +19,26 @@ pokeCloud vptr iptr (nv,ni) cl = do
pokeCloudVerx :: Ptr Float -> Cloud -> Int -> Int -> (Float, Float) -> IO ()
{-# INLINE pokeCloudVerx #-}
pokeCloudVerx ptr cl nv i (dx, dy) =
UV.imapM_ (pokeCloudFloat ptr (nv + i)) $ UV.fromList
[x, y, cz, 1, r, g, b, a, cx, cy, cz, rad, dx, dy, 0, 0]
UV.imapM_ (pokeCloudFloat 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 = _clPos cl
V2 x y = V2 cx cy - rad *.* V2 dx dy
CloudColor rad' fadet col = _clPict cl
(rad,V4 r g b a') = (rad'*_clRad cl, col)
a = a' * min 1 (fromIntegral (_clTimer cl) / fadet)
--CloudColor fadet col = _clPict cl
-- CloudColor fadet = _clPict cl
(rad, V4 r g b a') = (20, clColor $ cl ^. clType)
-- (rad,V4 r g b a') = (_clRad cl*rad', col)
a = a' * min 1 (fromIntegral (_clTimer cl) / 100)
clColor :: CloudType -> Color
clColor = \case
SmokeCloud -> white
FlamerSmokeCloud -> black
RocketCloud -> greyN 0.5
CryoReleaseCloud -> blue
GasCloud -> green
StoneDust -> white
pokeCloudFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
{-# INLINE pokeCloudFloat #-}