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

Working cloud shadows (slow)

Browse Source
This commit is contained in:
justin
2021-09-01 12:20:01 +01:00
parent f3ea46d7d0
commit ecaa5c48d0
12 changed files with 90 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+3 -2
View File
@@ -126,10 +126,11 @@ data Corpse = Corpse
, _cpRes :: Creature
}
data Cloud = Cloud
{ _clPos :: Point2
, _clVel :: Point2
{ _clPos :: Point3
, _clVel :: Point3
, _clPict :: Cloud -> Picture
, _clRad :: Float
, _clAlt :: Float
, _clTimer :: Int
, _clType :: CloudType
, _clEffect :: Cloud -> World -> World
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -40,7 +40,7 @@ initialWorld = defaultWorld
, _testString = []
, _yourID = 0
, _worldEvents = soundOncePos foamSprayFadeOutSound (V2 0 0) . foldr ((.) . makeStartCloudAt) id
[V2 x y | x <- [-5,-3..5] , y <- [-5,-3..5]]
[V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
, _pressPlates = IM.empty
, _buttons = IM.empty
, _sounds = M.empty
src/Dodge/Item/Weapon.hs
+2 -1
View File
@@ -30,6 +30,7 @@ import Dodge.Item.Weapon.Grenade
import Dodge.Item.Attachment.Data
import Dodge.Item.Attachment
import Geometry
import Geometry.Vector3D
import Picture
import qualified IntMapHelp as IM
@@ -940,7 +941,7 @@ moveRemoteShell cid itid pj w
hitWl = fst <$> collideCircWalls' oldPos newPos 2 (wallsNearPoint newPos w)
thingHit = hitCr <|> hitWl
r1 = _randGen w & evalState (randInCirc 10)
smokeGen = makeSmokeCloudAt $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
smokeGen = makeSmokeCloudAt $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
doExplosion = explodeRemoteRocket itid i
explodeRemoteRocket
src/Dodge/Item/Weapon/Launcher.hs
+2 -1
View File
@@ -17,6 +17,7 @@ import Dodge.WorldEvent.SpawnParticle
import Dodge.WorldEvent.Cloud
import Dodge.RandomHelp
import Geometry
import Geometry.Vector3D
import Picture
import qualified IntMapHelp as IM
import Padding
@@ -117,7 +118,7 @@ doThrust pj w = w
(frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.2,0.2) $ _randGen w
r1 = randInCirc 10 & evalState $ _randGen w
smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos))
smokeGen = makeSmokeCloudAt $ addZ 20 (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos))
flameLauncher :: Item
flameLauncher = launcher & wpAmmo . amPayload .~ makeFlameExplosionAt
src/Dodge/Item/Weapon/TriggerType.hs
+7 -6
View File
@@ -43,6 +43,7 @@ import Dodge.Item.Attachment.Data
import Dodge.Item.Data
import Dodge.Default
import Geometry
import Geometry.Vector3D
import System.Random
import Control.Lens
@@ -65,18 +66,18 @@ trigDoAlso
trigDoAlso afterEff eff item cr = afterEff item cr . eff item cr
withThinSmokeI :: ChainEffect
withThinSmokeI eff item cr w = eff item cr $ foldl' (flip $ makeThinSmokeAt . (+.+ pos)) w ps
withThinSmokeI eff item cr w = eff item cr $ foldl' (flip $ makeThinSmokeAt . (+.+.+ pos) . (* 8)) w ps
where
dir = _crDir cr
pos = _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir
ps = (replicateM 5 . randInCirc) 8 & evalState $ _randGen w
pos = addZ 0 $ _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir
ps = replicateM 5 randOnUnitSphere & evalState $ _randGen w
withThickSmokeI :: ChainEffect
withThickSmokeI eff item cr w = eff item cr $ foldl' (flip $ makeThickSmokeAt . (+.+ pos)) w ps
withThickSmokeI eff item cr w = eff item cr $ foldl' (flip $ makeThickSmokeAt . (+.+.+ pos) . (*8)) w ps
where
dir = _crDir cr
pos = _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir
ps = (replicateM 20 . randInCirc) 8 & evalState $ _randGen w
pos = addZ 0 $ _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir
ps = replicateM 20 randOnUnitSphere & evalState $ _randGen w
-- TODO create a trigger that does different things on first and continued
-- fire.
src/Dodge/Render.hs
+4 -2
View File
@@ -139,14 +139,16 @@ doDrawing pdata w = do
drawBuffers $= [FBOColorAttachment 0,NoBuffers]
clear [ColorBuffer]
renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints
--renderWindows pdata windowPoints
----render transparency depths
depthMask $= Enabled
blend $= Disabled
drawBuffers $= [NoBuffers,FBOColorAttachment 1]
clearColor $= Color4 0 0 0 0
clear [ColorBuffer]
renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints
--renderWindows pdata windowPoints
depthMask $= Disabled
blend $= Enabled
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -73,7 +73,7 @@ btDraw :: Button -> Picture
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
clDraw :: Cloud -> Picture
clDraw c = uncurryV translate (_clPos c) (_clPict c c)
clDraw c = translate3 (_clPos c) (_clPict c c)
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
src/Dodge/Update.hs
+18 -13
View File
@@ -21,6 +21,7 @@ import Dodge.Initialisation
import Dodge.Layout
import Dodge.Floor
import Geometry
import Geometry.Vector3D
import Data.List
import Data.Maybe
@@ -86,7 +87,7 @@ functionalUpdate w = case _menuLayers w of
zoneClouds = set cloudsZone (foldl' (flip cloudInZone) IM.empty (_clouds w))
cloudInZone cl = insertInZoneWith x y (++) [cl]
where
(x,y) = cloudZoneOfPoint $ _clPos cl
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
-- | Note the explict use of record syntax. Using lens creates a space leak.
resetWorldEvents :: World -> World
@@ -171,11 +172,11 @@ checkEndGame w
updateClouds :: World -> World
updateClouds w = w' & clouds .~ catMaybes mclouds
where
(w',mclouds) = mapAccumR updateCloud' w (_clouds w)
(w',mclouds) = mapAccumR updateCloud w (_clouds w)
-- did i write a mapMaybeAccumR ?
updateCloud' :: World -> Cloud -> (World,Maybe Cloud)
updateCloud' w c
updateCloud :: World -> Cloud -> (World,Maybe Cloud)
updateCloud w c
| _clTimer c < 1 = (w, Nothing)
| otherwise = (_clEffect c c w, Just $ c
& clPos .~ finalPos
@@ -183,13 +184,17 @@ updateCloud' w c
& clTimer -~ 1
)
where
newVel = 0.95 *.* springVels
springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
oldPos = _clPos c
newPos = oldPos +.+ newVel
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
finalPos = maybe newPos fst hitWl
finalVel = maybe newVel snd hitWl
newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ (V3 0 0 (0.01 * vertVel))
newVel2 = stripZ newVel
vertVel = _clAlt c - opz
springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos2 w)
oldPos@(V3 _ _ opz) = _clPos c
oldPos2 = stripZ oldPos
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
newPos2 = stripZ newPos
hitWl = collideCircWalls' oldPos2 newPos2 5 $ wallsNearPoint newPos2 w
finalPos = addZ npz $ maybe newPos2 fst hitWl
finalVel = addZ nvz $ maybe newVel2 snd hitWl
--updateCloud :: World -> Cloud -> Maybe Cloud
--updateCloud w c
@@ -207,9 +212,9 @@ updateCloud' w c
-- finalPos = maybe newPos fst hitWl
-- finalVel = maybe newVel snd hitWl
clClSpringVel :: Cloud -> Point2 -> Cloud -> Point2
clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3
clClSpringVel a v b
| dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb)
| dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb)
| otherwise = v
where
pa = _clPos a
src/Dodge/WorldEvent/Cloud.hs
+24 -14
View File
@@ -9,14 +9,22 @@ import Picture
import Control.Lens
makeCloudAt :: Float -> Int -> (Cloud -> Picture) -> Point2 -> World -> World
makeCloudAt rad t drawFunc p w = w & clouds %~ (theCloud :)
makeCloudAt
:: Float -- ^ radius
-> Int -- ^ timer
-> Float -- ^ resting altitude
-> (Cloud -> Picture) -- ^ draw function
-> Point3 -- start position
-> World
-> World
makeCloudAt rad t alt drawFunc p w = w & clouds %~ (theCloud :)
where
theCloud = Cloud
{ _clPos = p
, _clVel = V2 0 0
, _clVel = V3 0 0 0
, _clPict = drawFunc
, _clRad = rad
, _clAlt = alt
, _clTimer = t
, _clType = SmokeCloud
, _clEffect = const id
@@ -30,22 +38,24 @@ drawCloudWith radMult fadet col cl
where
a = min 1 $ fromIntegral (_clTimer cl) / fadet
makeThickSmokeAt :: Point2 -> World -> World
makeThickSmokeAt = makeCloudAt 3 50 (drawCloudWith 4 50 black)
makeThickSmokeAt :: Point3 -> World -> World
makeThickSmokeAt = makeCloudAt 3 50 30 (drawCloudWith 4 50 black)
makeThinSmokeAt :: Point2 -> World -> World
makeThinSmokeAt = makeCloudAt 5 400 (drawCloudWith 4 400 (withAlpha 0.05 black))
makeThinSmokeAt :: Point3 -> World -> World
makeThinSmokeAt = makeCloudAt 5 400 50 (drawCloudWith 4 400 (withAlpha 0.05 black))
makeStartCloudAt :: Point2 -> World -> World
makeStartCloudAt :: Point3 -> World -> World
--makeSmokeCloudAt = makeCloudAt 10 200 (drawCloudWith 2 200 (greyN 0.5))
makeStartCloudAt = makeCloudAt 10 400 (drawCloudWith 2 800 white)
makeStartCloudAt = makeCloudAt 10 400 5 (drawCloudWith 2 800 white)
makeSmokeCloudAt :: Point2 -> World -> World
makeSmokeCloudAt :: Point3 -> World -> World
--makeSmokeCloudAt = makeCloudAt 10 200 (drawCloudWith 2 200 (greyN 0.5))
makeSmokeCloudAt = makeCloudAt 15 400 (drawCloudWith (4/3) 800 (greyN 0.5))
makeSmokeCloudAt = makeCloudAt 15 400 40 (drawCloudWith (4/3) 800 (greyN 0.5))
makeFlamerSmokeAt :: Float -> Point2 -> World -> World
makeFlamerSmokeAt x = makeCloudAt 6 200 (drawCloudWith 4 300 (greyN x))
makeFlamerSmokeAt :: Float -> Point3 -> World -> World
makeFlamerSmokeAt x = makeCloudAt 6 200 40 (drawCloudWith 4 300 (greyN x))
spawnSmokeAtCursor :: World -> World
spawnSmokeAtCursor w = makeSmokeCloudAt (mouseWorldPos w) w
spawnSmokeAtCursor w = makeSmokeCloudAt (V3 x y 20) w
where
V2 x y = mouseWorldPos w
src/Dodge/WorldEvent/SpawnParticle.hs
+7 -5
View File
@@ -23,6 +23,7 @@ import Dodge.RandomHelp
--import Dodge.Debug
import Picture
import Geometry
import Geometry.Vector3D
--import Geometry.Data
import qualified IntMapHelp as IM
@@ -132,7 +133,7 @@ moveFlame rotd w pt
reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
+.+ (0.2 *.* vel)
smokeCol = fst $ randomR (0.2,0.5) (_randGen w)
smokeGen = makeFlamerSmokeAt smokeCol ep
smokeGen = makeFlamerSmokeAt smokeCol (addZ 20 ep)
makeFlameletTimed
:: Point2 -- ^ Position
@@ -279,11 +280,12 @@ makeGasCloud pos vel w = w
& randGen .~ g
where
theCloud = Cloud
{ _clPos = pos
, _clVel = vel
{ _clPos = addZ 20 pos
, _clVel = addZ 0 vel
, _clPict = \_ -> setLayer 2 . setDepth 30 $ color (withAlpha 0.05 col)
$ circleSolid 20
, _clRad = 10
, _clAlt = 25
, _clTimer = 400
, _clType = GasCloud
, _clEffect = cloudPoisonDamage
@@ -296,8 +298,8 @@ Attach poison cloud damage to creatures near cloud.
cloudPoisonDamage :: Cloud -> World -> World
cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
where
damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w
f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (stripZ $ _clPos c) w
f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
makeTeslaArcAt :: Point2 -> Float -> Particle
makeTeslaArcAt pos dir = LinearParticle
src/Geometry/Vector3D.hs
+11
View File
@@ -52,17 +52,28 @@ rotate3 a (V3 x y z) = V3 x' y' z
(V2 x' y') = rotateV a (V2 x y)
magV3 :: Point3 -> Float
{-# INLINE magV3 #-}
magV3 (V3 x y z) = sqrt $ x^i + y^i + z^i
where
i = 2 :: Int
normalizeV3 :: Point3 -> Point3
{-# INLINE normalizeV3 #-}
normalizeV3 (V3 0 0 0) = V3 0 0 0
normalizeV3 p = (1 / magV3 p) *.*.* p
addZ :: Float -> Point2 -> Point3
{-# INLINE addZ #-}
addZ z (V2 x y) = V3 x y z
stripZ :: Point3 -> Point2
{-# INLINE stripZ #-}
stripZ (V3 x y _) = V2 x y
dist3 :: Point3 -> Point3 -> Float
{-# INLINE dist3 #-}
dist3 !p1 !p2 = magV3 (p2 -.-.- p1)
orderAround3
:: Point3 -- ^ Vector to order around
-> [Point3]
src/Picture.hs
+10 -5
View File
@@ -27,6 +27,7 @@ module Picture
, appendPic
, tranRot
, translate
, translate3
, rotate
, scale
, color
@@ -161,17 +162,21 @@ color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c = map $ overCol (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 !a !b (V3 x y z) = V3 (x+a) (y+b) z
translateH :: Float -> Float -> Point3 -> Point3
{-# INLINE translateH #-}
translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x = map . overPos . translate3 x
translate x = map . overPos . translateH x
translate3 :: Point3 -> Picture -> Picture
{-# INLINE translate3 #-}
translate3 v = map $ overPos (+.+.+ v)
tranRot :: V2 Float -> Float -> Picture -> Picture
{-# INLINE tranRot #-}
tranRot (V2 x y) r = map $ overPos (translate3 x y . rotate3 r)
tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r)
setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}