diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs new file mode 100644 index 000000000..22aa59d33 --- /dev/null +++ b/src/Dodge/WorldEvent.hs @@ -0,0 +1,422 @@ +module Dodge.WorldEvent + ( module Dodge.WorldEvent + , module Dodge.WorldEvent.Bullet + , module Dodge.WorldEvent.Flash + , module Dodge.WorldEvent.ThingsHit + , module Dodge.WorldEvent.HelperParticle + ) + where + +import Dodge.WorldEvent.Bullet +import Dodge.WorldEvent.Flash +import Dodge.WorldEvent.ThingsHit +import Dodge.WorldEvent.HelperParticle +import Dodge.LightSources + +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic +import Dodge.RandomHelp +import Geometry +import Picture + +import Control.Lens +import Control.Monad.State + +import System.Random + +import Data.Maybe +import Data.Function +import Data.List +import qualified Data.IntMap.Strict as IM + +makeExplosionAt :: Point2 -> World -> World +makeExplosionAt p w = soundOnce grenadeBang + $ over tempLightSources ((:) $ tLightFade 20 150 intensityF p) + $ fs + $ over particles (IM.insert n exp) + w + where n = newParticleKey w + exp = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = (0,0) + , _ptPict = blank + , _ptID = n + , _ptUpdate = explosionWaveDamage 6 p n + } + fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w + fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w + fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) + --fPs = map (pushAgainstWalls . (+.+) p . (*.*) 5) + fPs' + inversePushOut v = (15 - magV v) * 0.01 *.* v + fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' + sizes = randomRs (2,6) $ _randGen w + times = randomRs (20,25) $ _randGen w + mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time + newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times + fs w = foldr ($) w newFs + pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) + $ collidePointWalls p q $ wallsNearPoint q w + fadeFac x | x > 10 = 0 + | otherwise = 1 - fromIntegral x / 10 + intensityF x | x < 10 = 1 / (10 - fromIntegral x) + | otherwise = 1 + +explosionWaveDamage :: Int -> Point2 -> Int -> World -> World +explosionWaveDamage 0 p ptid = over particles (IM.delete ptid) +explosionWaveDamage time p ptid + = set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid) + . shockWaveDamage p rad 20 + . set (particles . ix ptid . ptPict) shockwavePic + . explosionFlashAt p + where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white) + $ thickCircle rad (thickness*2) + thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8 + rad = 40 - thickness + +shockWaveDamage :: Point2 -> Float -> Int -> World -> World +shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w + where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) + ((:) $ Concussive amount p 2 0.5 rad) cr + | otherwise = cr + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2))) + w + (_blIDs wall) + _ -> w + +makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color + -> World -> World +makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave) + where theShockwave = shockwaveAt p rad dam push col 10 + +shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' +shockwaveAt p rad dam push col maxtime + = Shockwave' + { _ptPict' = blank + , _ptUpdate' = mvShockwave' + , _btColor' = col + , _btPos' = p + , _btRad' = rad + , _btDam' = dam + , _btPush' = push + , _btMaxTime' = maxtime + , _btTimer' = maxtime + } + +mvShockwave' :: World -> Particle' -> (World, Maybe Particle') +mvShockwave' w pt + | _btTimer' pt <= 0 = (w, Nothing) + | otherwise + = (dams w , Just $ set btTimer' (t - 1) $ set ptPict' pic pt) + where r = _btRad' pt + p = _btPos' pt + push = _btPush' pt + dam = _btDam' pt + t = _btTimer' pt + tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) + pic = onLayer PtLayer $ uncurry translate p + $ color (_btColor' pt) $ thickCircle rad thickness + rad = r - (3/4) * r * tFraction + thickness = tFraction**2 * r + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr +moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp + newpic = set ptPict' (onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (3/40) * r * fromIntegral t + thickness = (fromIntegral t)**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr + +inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World +inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave) + where theShockwave + = Particle' + { _ptPict' = blank + , _ptUpdate' = moveInverseShockWave 10 p rad push pushexp + } +moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveInverseShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp + newpic = set ptPict' (onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (4/40) * r * fromIntegral (10 - t) + thickness = (fromIntegral (10 - t))**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) + cr + | otherwise = cr + +-- if the spark is created by another Particle', it cannot be directly added to +-- the list, hence the redirect through worldEvents +createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World +createSpark time colid pos dir maycid w = over worldEvents + ((.) $ ( over particles' ((:) spark) + . flareAt' white 0.02 0.05 pos') + -- . lowLightAt' pos) + ) w + where spark = Bul' { _ptPict' = blank + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = threeEff' sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt + +createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World +createBarrelSpark time colid pos dir maycid w = over worldEvents + ((.) $ ( over particles' ((:) spark) + . flareAt' white 0.005 0.03 pos') + -- . lowLightAt' pos) + ) w + where spark = Bul' { _ptPict' = blank + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = threeEff' sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt + + + + + +noEff _ _ _ = id + +threeEff' :: + ( Particle' -> Point2 -> Creature -> World -> World ) -> + ( Particle' -> Point2 -> Wall -> World -> World ) -> + ( Particle' -> Point2 -> ForceField -> World -> World ) -> + Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle') +threeEff' crEff wlEff ffEff pt hitThings w = case hitThings of + [] -> error "threeEff called without hitting anything" + ((p,E3x1 cr):_) -> (crEff pt p cr w, updatePt p) + ((p,E3x2 wl):_) -> (wlEff pt p wl w, updatePt p) + ((p,E3x3 ff):_) -> (ffEff pt p ff w, updatePt p) + where updatePt hitp = Just $ pt & btTrail' .~ (hitp : trl) + & ptPict' .~ bulLine col wth (hitp: trl) + & btTimer' .~ 3 + trl = _btTrail' pt + col = _btColor' pt + wth = _btWidth' pt + +makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World +makeFlameletTimed pos vel levelInt maycid size time w + = set randGen g $ over particles' ((:) theFlamelet) + $ flareAt' white 0.01 0.1 pos w + where theFlamelet = + Pt' { _ptPict' = blank + , _ptUpdate' = moveFlamelet levelInt rot + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = size + , _btTimer' = time + , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + } + (rot ,g) = randomR (0,3) $ _randGen w + +makeFlamelet :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> World -> World +makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' ((:) theFlamelet) w + where theFlamelet = + Pt' { _ptPict' = blank + , _ptUpdate' = moveFlamelet levelInt rot + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = size + , _btTimer' = 20 + , _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff + } + (rot ,g) = randomR (0.5,1.5) $ _randGen w +moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle') +moveFlamelet levelInt rot w pt = + case _btTimer' pt of + time | time <= 0 -> (w, Nothing) + | otherwise -> (damcrs, mvPt) + where sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + size = _btWidth' pt + siz2 = size + 0.2 + mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture + , _btPassThrough' = Nothing + ,_btVel' = 0.8 *.* vel} + damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w + closeCrs cr = dist ep (_crPos cr) < _crRad cr + size + dodam cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming 3 sp ep ep) + pic = onLayerL [levelInt,3] $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + white (dark red) + ) + $ rotate (0 - ( 0.1 * fromIntegral time + rot)) + $ scale sc sc + $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] + piu = onLayerL [levelInt,1] $ uncurry translate ep + $ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time)) + $ scale s1 s1 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + glow = onLayerL [levelInt,0] $ uncurry translate ep + $ color (withAlpha 0.01 red) + $ circleSolid 30 + sc = (*) 2 $ log $ 1 + fromIntegral time / 20 + s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 + s2 = 0.5 * (sc + s1) + thepicture = pictures [pic , piu , pi2 , glow] + pi2 = onLayerL [levelInt,2] $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + orange (dark red) + ) + $ rotate (0 - (rot + 0.2 * fromIntegral time)) + $ scale s2 s2 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + + +doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World +doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming amount sp p ep) + where sp = _btPos' pt + ep = sp +.+ _btVel' pt + +makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World +makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w + where smokeP = Particle' + --{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1 + { _ptPict' = onLayerL [levLayer PtLayer ] $ uncurry translate p $ color black $ circleSolid 1 + , _ptUpdate' = moveSmoke'' scal time p vel + } + +moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle') +moveSmoke'' scal time p vel w pt + | time > 0 = (w, Just $ pt { _ptPict' = pic + , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel + }) + | time > -50 = (w, Just $ pt { _ptPict' = pi1 + , _ptUpdate' = moveSmoke'' scal (time-1) pNew vel + }) + | otherwise = (w, Nothing) + where pNew = p +.+ vel + pic = onLayerL [levLayer PtLayer] + --pic = onLayerL [levLayer PtLayer - 1] + $ uncurry translate pNew + $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal + pi1 = pictures $ reverse + [(onLayerL [levLayer PtLayer] + $ uncurry translate pNew + $ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5)) + $ circleSolid $ 21 * scal) + , + --(onLayerL [levLayer BgLayer+1] + (onLayerL [levLayer PtLayer] + $ uncurry translate pNew + $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) + $ circleSolid $ 21 * scal) + ] + +makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World +makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w + where n = newParticleKey w + smP = Particle + { _ptPos = p + , _ptStartPos = p + , _ptVel = vel + , _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1 + , _ptID = n + , _ptUpdate = moveColorSmoke col scal time n + } + +moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World +moveColorSmoke col scal time i w + | time > 0 + = set (particles . ix i . ptPict) pic + . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | time > -50 + = set (particles . ix i . ptPict) pi1 + . set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i) + . set (particles . ix i . ptPos) newPos + . setVel + $ w + | otherwise + = over particles (IM.delete i) w + where oldPos = _ptPos $ _particles w IM.! i + newPos = oldPos +.+ (_ptVel $ _particles w IM.! i) + setVel = over (particles . ix i . ptVel) $ (*.*) 0.99 + pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal + pi1 = onLayer PtLayer $ uncurry translate newPos + $ color (withAlpha (1 + fromIntegral time /50) col) + $ circleSolid $ 21 * scal + +damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World +damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine) + where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) + = over crHP (\hp -> hp - dam) cr + | otherwise = cr + +tempLightForAt :: Int -> Point2 -> World -> World +tempLightForAt i p w = w & tempLightSources %~ (:) (tLightAt i p) diff --git a/src/Dodge/WorldEvent/Bullet.hs b/src/Dodge/WorldEvent/Bullet.hs new file mode 100644 index 000000000..21e595fc0 --- /dev/null +++ b/src/Dodge/WorldEvent/Bullet.hs @@ -0,0 +1,140 @@ +module Dodge.WorldEvent.Bullet + where +import Dodge.Data +import Dodge.Base + +import Dodge.WorldEvent.ThingsHit + +import Picture +import Geometry + +import Control.Lens + +import Data.Maybe +import Data.List +import Data.Function (on) +import Data.Bifunctor +import qualified Data.IntMap.Strict as IM + +mvBulletTrajectory :: (Int -> [Point2]) -> World -> Particle' -> (World, Maybe Particle') +mvBulletTrajectory velF w bt + | t <= 0 = (w, Nothing) + | t < 4 = (w, Just $ set btPassThrough' Nothing + $ set btTrail' (replicate numPs p ++ (p:ps) ) + $ set ptPict' (bulLineLen numPs col wth (replicate numPs p ++ (p:ps) ) ) + $ set btTimer' (t-1) + bt + ) + | otherwise = (w, Just $ set btPassThrough' Nothing + $ set btVel' newVel -- this may be useful for hit effects + $ set btTrail' (init (reverse newPs) ++ (p:ps)) + $ set ptPict' (bulLineLen numPs col wth (init (reverse newPs) ++ (p:ps))) + $ set btTimer' (t-1) bt + ) +-- | otherwise = case firstThingHit $ thingsHitExceptCrCurve mcr (p:newPs) w of +-- (_,Nothing) -> (w, Just $ set btPassThrough' Nothing +-- $ set btVel' newVel -- this may be useful for hit effects +-- $ set btTrail' (init (reverse newPs) ++ (p:ps)) +-- $ set ptPict' (bulLineLen numPs col wth (init (reverse newPs) ++ (p:ps))) +-- $ set btTimer' (t-1) bt +-- ) +-- (mvPs,Just (hitp,thing)) +-- -> let newMvPs = leftPad numPs hitp (init $ reverse mvPs) +-- hitVel = speed *.* normalizeV ( hitp -.- (head $ reverse mvPs) ) +-- in ( hiteff bt (hitp,thing) w +-- --in ( w +-- , Just $ set btPassThrough' Nothing +-- $ set btVel' hitVel -- this may be useful for hit effects +-- $ set btTrail' (newMvPs ++ (p:ps)) +-- $ set ptPict' (bulLineLen numPs col wth (newMvPs ++ (p:ps)) ) +-- $ set btTimer' 3 bt +-- ) + where mcr = _btPassThrough' bt + col = _btColor' bt + (p:ps) = _btTrail' bt + hiteff = _btHitEffect' bt + wth = _btWidth' bt + t = _btTimer' bt + newPs = velF t + numPs = (length $ newPs) - 1 + firstThingHit :: [[(Point2,(Either3 Creature Wall ForceField))]] + -> ([Point2], Maybe (Point2,Either3 Creature Wall ForceField)) + firstThingHit hitList = second last $ unzip $ zip newPs + $ takeUntil isJust + $ map listToMaybe hitList + newVel = speed *.* ( last newPs -.- (last $ init newPs) ) + speed = sum . map magV $ zipWith (-.-) (init newPs) (tail newPs) + + +thingsHitExceptCrCurve :: Maybe Int -> [Point2] -> World + -> [ [(Point2, (Either3 Creature Wall ForceField))] + ] +thingsHitExceptCrCurve mcid ps@(a:b:_) w + = zipWith (\x y -> thingsHitExceptCr mcid x y w) ps $ tail ps +thingsHitExceptCrLine _ _ _ = [] + +thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World + -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHitExceptCr Nothing sp ep = thingsHit sp ep +thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep + where crNotCid (_,(E3x1 cr)) = _crID cr /= cid + crNotCid _ = True + +mvGenBullet' :: World -> Particle' -> (World, Maybe Particle') +mvGenBullet' w bt + | t <= 0 = (w, Nothing) + | t < 4 = (w, Just $ set btPassThrough' Nothing + $ set btTrail' (p:p:ps) + $ set ptPict' (bulLine col wth (p:p:ps)) + $ set btTimer' (t-1) bt + ) + | otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of + [] -> (w, Just $ set btPassThrough' Nothing + $ set btTrail' (p +.+ vel :p:ps) + $ set ptPict' (bulLine col wth (p +.+ vel:p:ps)) + $ set btTimer' (t-1) bt + ) + hits -> hiteff bt hits w + where mcr = _btPassThrough' bt + col = _btColor' bt + (p:ps) = _btTrail' bt + vel = _btVel' bt + hiteff = _btHitEffect' bt + wth = _btWidth' bt + t = _btTimer' bt + +bulLineLen :: Int -> Color -> Float -> [Point2] -> Picture +bulLineLen n c w ps = + setLayer 1 . onLayer HPtLayer $ color c $ thickLine (take (n * 2) ps) w + +bulLine c w = setLayer 1 . bulLineb w + +bulLineb :: Float -> [Point2] -> Picture +bulLineb w ps = color white $ thickLine (take 2 ps) w + +bulLinea :: Color -> Float -> [Point2] -> Picture +bulLinea _ _ [] = blank +bulLinea _ _ (x:[]) = blank +bulLinea col width (a:b:[]) -- (a:b:[]) + = onLayer HPtLayer $ pictures $ reverse + [polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white] + ,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col] + ] +bulLinea col width (a:b:c:[]) -- (a:b:[]) + = onLayer HPtLayer $ pictures $ reverse + [polygonCol $ zip (wedgeGeom width b a) $ repeat white + ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] + ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] + ] +bulLinea col width (a:b:_:c:[]) -- (a:b:[]) + = onLayer HPtLayer $ pictures $ reverse + [polygonCol $ zip (wedgeGeom width b a) $ repeat white + ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] + ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] + ] +bulLinea col width (a:b:_:_:c:_) -- (a:b:[]) + = onLayer HPtLayer $ pictures $ reverse + [polygonCol $ zip (wedgeGeom width b a) $ repeat white + ,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white] + ,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col] + ] diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs new file mode 100644 index 000000000..2e78c000a --- /dev/null +++ b/src/Dodge/WorldEvent/Flash.hs @@ -0,0 +1,137 @@ +module Dodge.WorldEvent.Flash + where +import Dodge.Data +import Dodge.Base + +import Dodge.WorldEvent.ThingsHit +import Dodge.WorldEvent.HelperParticle + +import Picture +import Geometry + +import Control.Lens + +flareAt' :: Color -> Float -> Float -> Point2 -> World -> World +flareAt' col alphax alphay p + = -- over particles' ((:) (flashColAt col alphax p)) + -- . + lowLightColAt col alphay p + +lowLightColAt :: Color -> Float -> Point2 -> World -> World +lowLightColAt col alphay p w = foldr (lowLightWidthHit 10 5 col alphay p) w ps + where ps = map ((+.+) p) $ nRaysRad 20 30 + +lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World +lowLightWidthHit len wdth col alphay a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w + ((p, E3x1 cr):_) + -> over particles' ((:) (crGlareWidth wdth col alphay p cr)) w + _ -> w + +flashColAt :: Color -> Float -> Point2 -> Particle' +flashColAt col alphax (x,y) = + Particle' + { _ptPict' = pictures $ + map (\i -> onLayerL [levLayer PtLayer] + $ color (withAlpha alphax col) $ translate x y $ circleSolid i + ) + [20,25,30,35,40,45,50] + , _ptUpdate' = ptTimer' 1 + } + +wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle' +wallGlareWidth len wdth col alphay p wl = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l + , _ptUpdate' = ptTimer' 1 + } + where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x] + x = len *.* ( normalizeV $ a -.- b) + (a:b:_) = _wlLine wl + +crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle' +crGlareWidth wdth col alphay p cr = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp + , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w + ,_ptUpdate' = ptTimer' 0 + } + ) + } + where l x = uncurry translate x + $ rotate (-0.25*pi + argV (p -.- x)) + $ color (withAlpha alphay col) + $ thickArc 0 (pi/2) (_crRad cr) wdth + cp = _crPos cr + cid = _crID cr + upp cid' w' = case w' ^? creatures . ix cid . crPos of + Just y -> l y + _ -> blank + +flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World +flareWidth len wdth rad rays col ax ay p + = over particles' ((:) (flashRadAt rad col ax p)) + . lowLightWidthAt len wdth col ay rays rad p + +flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World +flareRad rad rays col ax ay p + = over particles' ((:) (flashRadAt rad col ax p)) + . lowLightWidthAt 10 5 col ay rays rad p + +flashRadAt :: Float -> Color -> Float -> Point2 -> Particle' +flashRadAt rad col alphax (x,y) = + Particle' + { _ptPict' = pictures $ + map (\i -> onLayerL [levLayer PtLayer] + $ color (withAlpha alphax col) $ translate x y $ circleSolid i + ) + [rad/5,2*rad/5,3*rad/5,4*rad/5,rad] + , _ptUpdate' = ptTimer' 1 + } + +lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World +lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps + where ps = map ((+.+) p) $ nRaysRad rays rad + +explosionFlashAt = lowLightWidthAt 10 5 white 0.3 75 150 + +flameGlareAt = lowLightWidthAt 10 5 orange 0.05 8 50 + +lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World +lowLightDirected col alpha a b angles w + = foldr (\angle w' -> lowLightWidthHit 10 5 col alpha a (a +.+ rotateV angle b) w') w angles + + +muzFlareAt :: Point2 -> World -> World +muzFlareAt p = over particles' ((:) (muzzleFlareAt p)) + . lowLightAt p + +muzzleFlareAt :: Point2 -> Particle' +muzzleFlareAt (x,y) = + Particle' + { _ptPict' = setDepth 0 + . setLayer 1 + . translate x y + $ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20 + , _ptUpdate' = ptTimer' 1 + } + + +lowLightAt :: Point2 -> World -> World +lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w + +lowLightAt' :: Point2 -> World -> World +lowLightAt' p w = foldr (lowLightHit' p) w ps + where ps = map ((+.+) p) $ nRaysRad 20 30 + +lowLightHit' :: Point2 -> Point2 -> World -> World +lowLightHit' a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlare' p wall)) w + _ -> w + +wallGlare' :: Point2 -> Wall -> Particle' +wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl diff --git a/src/Dodge/WorldEvent/HelperParticle.hs b/src/Dodge/WorldEvent/HelperParticle.hs new file mode 100644 index 000000000..1d5d2c4b4 --- /dev/null +++ b/src/Dodge/WorldEvent/HelperParticle.hs @@ -0,0 +1,8 @@ +module Dodge.WorldEvent.HelperParticle + where + +import Dodge.Data + +ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle') +ptTimer' 0 w pt = (w, Nothing) +ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)}) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs new file mode 100644 index 000000000..f2e084b62 --- /dev/null +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -0,0 +1,60 @@ +module Dodge.WorldEvent.ThingsHit + where +import Dodge.Data +import Dodge.Base + +import Geometry + +import qualified Data.IntMap.Strict as IM +import Data.List +import Data.Maybe +import Data.Function (on) + +thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World + -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep +thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep + where crNotCid (_,(E3x1 cr)) = _crID cr /= cid + crNotCid _ = True + +thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHitLongLine sp ep w + | sp == ep = [] + | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) + where + crs = zip crPs (map E3x1 hitCrs) + hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + $ _creatures w + -- $ creaturesAlongLine sp ep w + crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs + + walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w + hitPoint wl = intersectSegSeg' sp ep (_wlLine wl !! 0) (_wlLine wl !! 1) + + hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) + ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs + +thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] +thingsHit sp ep w + | sp == ep = [] + | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) + where + hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) + $ _creatures w + crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs + crs = zip crPs (map E3x1 hitCrs) + + hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] + , b<-[y-1,y,y+1]]) + (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) + f i m = case IM.lookup i m of Just val -> val + _ -> IM.empty + walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) + hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) + ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs + +thingsHitOnPath :: [Point2] -> World -> [ [ ( Point2, (Either3 Creature Wall ForceField) ) ] ] +thingsHitOnPath [] _ = error "tried to find thingsHitOnPath containing no points" +thingsHitOnPath ps w = map (flip (uncurry thingsHit) w) . zip ps $ tail ps