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