From ecaa5c48d0bb172cf3b70fc21e0c3868adb108b8 Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 1 Sep 2021 12:20:01 +0100 Subject: [PATCH] Working cloud shadows (slow) --- src/Dodge/Data.hs | 5 ++-- src/Dodge/Initialisation.hs | 2 +- src/Dodge/Item/Weapon.hs | 3 ++- src/Dodge/Item/Weapon/Launcher.hs | 3 ++- src/Dodge/Item/Weapon/TriggerType.hs | 13 ++++----- src/Dodge/Render.hs | 6 +++-- src/Dodge/Render/Picture.hs | 2 +- src/Dodge/Update.hs | 31 +++++++++++++--------- src/Dodge/WorldEvent/Cloud.hs | 38 +++++++++++++++++---------- src/Dodge/WorldEvent/SpawnParticle.hs | 12 +++++---- src/Geometry/Vector3D.hs | 11 ++++++++ src/Picture.hs | 15 +++++++---- 12 files changed, 90 insertions(+), 51 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ad3cd4e2a..09e909189 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 62dd2c418..b8cf790e7 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -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 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index dfacc6f7f..d3cd2154d 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index 5a40ca0e9..134bff237 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -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 diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index bb9bf5842..ce8ac15b1 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -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. diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 3c621496c..3e4fa9a9f 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 5d22d3d7a..c1a41c4e0 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 46832dfef..be07db4d2 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index 4664ba49f..4662f54ca 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 656a8818d..c1c150614 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -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 diff --git a/src/Geometry/Vector3D.hs b/src/Geometry/Vector3D.hs index 6abefeff2..a646b97b1 100644 --- a/src/Geometry/Vector3D.hs +++ b/src/Geometry/Vector3D.hs @@ -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] diff --git a/src/Picture.hs b/src/Picture.hs index 4672c4c07..ac4b471f1 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -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 #-}