module Dodge.WorldActions where 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 . lowLightRadAt white 0.3 75 150 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 -- makeTremorAt :: Int -> Point -> Float -> Particle -- makeTremorAt i pos d = Particle -- { _ptPos = (0,0) -- , _ptStartPos = (0,0) -- , _ptVel = (0,0) -- , _ptPict = Line [(0,0),(0,0)] -- , _ptID = i -- , _ptUpdate = moveTremor [pos] 200 pos d i -- } -- -- moveTremor :: [Point] -> Int -> Point -> Float -> Int -> World -> World -- moveTremor ps t p1 d i w -- | t <= -30 = over particles (IM.delete i) . over partUnder (IM.delete i) $ w -- | t <= 0 = set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 d i) -- . over partUnder -- (IM.insert i (lineOfThickness (0.1*(fromIntegral t + 30)) ps)) $ w -- | otherwise = case hitWall of -- Nothing -> upUndPict . set randGen g . shakeCrs . -- shatterAt p1 pl $ shatterAt p1 pr -- $ set (particles . ix i . ptUpdate) (moveTremor (p3:ps) (t-1) p3 d i) -- $ damCrsOnLine 10 p1 p3 w -- Just (pw,pRef) -> set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 (argV pRef) i) w -- where p2 = p1 +.+ 5 *.* unitVectorAtAngle d -- pl = p1 +.+ rotateV (d + pi/4) (75,0) -- pr = p1 +.+ rotateV (d - pi/4) (75,0) -- hitWall = collidePointWalls p1 p3 $ wallsAlongLine p1 p3 w -- (d1,g) = randomR (0,2*pi) $ _randGen w -- v = unitVectorAtAngle d1 -- p3 = p2 +.+ 5 *.* v -- shakeCrs = over creatures (IM.map shCr) -- shCr cr | dist p1 (_crPos cr) < 75 = over crPos (+.+ v) cr -- | otherwise = cr -- upUndPict = over partUnder (IM.insert i pic) -- pic = pictures [color white $ lineOfThickness 3 [p3,head ps] -- ,lineOfThickness 3 ps] -- -- makeTremorAt' :: Int -> Point -> Particle -- makeTremorAt' i pos = Particle -- { _ptPos = (0,0) -- , _ptStartPos = (0,0) -- , _ptVel = (0,0) -- , _ptPict = Line [(0,0),(0,0)] -- , _ptID = i -- , _ptUpdate = rotateTremorAround 10 pos i -- } -- -- rotateTremorAround :: Int -> Point -> Int -> World -> World -- rotateTremorAround 0 p i w = over particles (IM.delete i) w -- rotateTremorAround t p i w = set (particles . ix i . ptUpdate) (rotateTremorAround (t-1) p i) -- $ foldr ($) w shatters -- where rot d = rotateV $ d + fromIntegral t * pi / 7 -- ds = fmap (\x -> fromIntegral x * pi / 2.5) [0..4] -- shatters = map (\d -> shatterAt p (p +.+ rot d (300,0))) ds -- -- shatterAt :: Point -> Point -> World -> World -- shatterAt p1 p2 w = case wlHit of -- Just (p,v,col) -> makeFallingBlock col (f1 p) (f2 v) -- $ set randGen g w -- _ -> w -- where wlHit = collidePointWallsNormCol p1 p2 $ wallsNearPoint p2 w -- f1 q = q +.+ 5 *.* errorNormalizeV 10 (p2 -.- p1) -- (d,g) = randomR (-0.5,0.5) $ _randGen w -- f2 v' = rotateV d $ 3 *.* errorNormalizeV 11 v' -- -- fallingWall :: Int -> Color -> Point -> Float -> Particle -- fallingWall pid col p d -- = Particle -- { _ptPos = p -- , _ptStartPos = p -- , _ptVel = rotateV d (3,0) -- , _ptPict = Line [(0,0),(0,0)] -- , _ptID = pid -- , _ptUpdate = moveFallingWall 10 p d col pid -- } -- -- moveFallingWall :: Int -> Point -> Float -> Color -> Int -> World -> World -- moveFallingWall 0 p d col i w = over particles (IM.delete i) $ b1 $ b2 w -- where b1 = makeFallingBlock col (p +.+ ( 3, 3)) (rotateV d (0,5)) -- b2 = makeFallingBlock col (p +.+ (-3,-3)) (rotateV d (0,1)) -- moveFallingWall t p d col i w -- = set (particles . ix i . ptUpdate) (moveFallingWall (t-1) np d col i) -- $ set (particles . ix i . ptPict) pic -- w -- where np = p +.+ 1 *.* unitVectorAtAngle d -- pic = uncurry translate p $ rotate (-radToDeg d) -- $ color col $ polygon [(-6,-6) -- ,(-6, 6) -- ,( 6, 6) -- ,( 6,-6) -- ] -- -- makeFallingBlock :: Color -> Point -> Point -> World -> World -- makeFallingBlock col p v w -- = over particles (IM.insert i $ fallingBlock i col p v) w -- where i = newParticleKey w -- -- fallingBlock :: Int -> Color -> Point -> Point -> Particle -- fallingBlock pid col p v -- = Particle -- { _ptPos = p -- , _ptStartPos = p -- , _ptVel = v -- , _ptPict = Line [(0,0),(0,0)] -- , _ptID = pid -- , _ptUpdate = moveFallingBlock 10 p v col pid -- } -- -- moveFallingBlock :: Int -> Point -> Point -> Color -> Int -> World -> World -- moveFallingBlock 0 p v col i w = over particles (IM.delete i) w -- moveFallingBlock t p v col i w -- = case hitCr of -- Nothing -> set (particles . ix i . ptUpdate) (moveFallingBlock (t-1) np v col i) -- $ set (particles . ix i . ptPict) pic -- w -- Just (p1,v1,crID) -> over particles (IM.delete i) -- $ over (creatures . ix crID . crHP) (\hp -> hp - 1) w -- where np = p +.+ v -- pic = uncurry translate p $ rotate (-radToDeg (argV v)) -- $ color col $ polygon [(-3,-3) -- ,(-3, 3) -- ,( 3, 3) -- ,( 3,-3) -- ] -- hitCr = reflectCircCreatures 4 p np $ _creatures w -- 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 flareAt :: Color -> Point2 -> World -> World flareAt c p = flareAt' c 0.02 0.5 p flareAt' :: Color -> Float -> Float -> Point2 -> World -> World flareAt' col alphax alphay p = over particles' ((:) (flashColAt col alphax p)) . lowLightColAt col alphay p tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource tLightFade 0 rmax intensityF p = TLS { _tlsPos = p , _tlsRad = rmax , _tlsIntensity = intensityF 0 , _tlsUpdate = \w _ -> (w, Nothing) } tLightFade i rmax intensityF p = TLS { _tlsPos = p , _tlsRad = rmax , _tlsIntensity = intensityF i , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p) } tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource tLightRad 0 rmax rmin p = TLS { _tlsPos = p , _tlsRad = rmax , _tlsIntensity = 0.5 , _tlsUpdate = \w _ -> (w, Nothing) } tLightRad i rmax rmin p = TLS { _tlsPos = p , _tlsRad = rmax , _tlsIntensity = 0.5 , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) } tLightAt i p = tLightRad i 100 0 p 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)) . lowLightRadAt 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 } 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 } 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 lowLightRadAt :: Color -> Float -> Int -> Float -> Point2 -> World -> World lowLightRadAt col alphay rays rad p w = foldr (lowLightColHit col alphay p) w ps where ps = map ((+.+) p) $ nRaysRad rays rad lowLightColAt :: Color -> Float -> Point2 -> World -> World lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps where ps = map ((+.+) p) $ nRaysRad 20 30 lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World lowLightDirected col alpha a b angles w = foldr (\angle w' -> lowLightColHit col alpha a (a +.+ rotateV angle b) w') w angles lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World lowLightColHit col alphay a b w = case thingsHitLongLine a b w of ((p, E3x2 wall):_) -> over particles' ((:) (wallGlareCol col alphay p wall)) w ((p, E3x1 cr):_) -> over afterParticles' ((:) (crGlareCol col alphay p cr)) w _ -> w wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle' wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle' crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr 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 afterParticles' ((:) (crGlareWidth wdth col alphay p cr)) w _ -> w 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 --{ _ptPict' = [(blank, [levLayer WlLayer + 2])] , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w ,_ptUpdate' = ptTimer' 0 } ) } where l x = uncurry translate x $ rotate (pi*0.5 + 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 --Just p -> uncurry translate p $ circleSolid 5 _ -> blank muzFlareAt :: Point2 -> World -> World muzFlareAt p = over particles' ((:) (muzzleFlareAt p)) . lowLightAt p muzzleFlareAt :: Point2 -> Particle' muzzleFlareAt (x,y) = Particle' { _ptPict' = pictures $ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i ) [20,25,30,35,40,45,50] , _ptUpdate' = ptTimer' 1 } ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle') ptTimer' 0 w pt = (w, Nothing) ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)}) lowLightAt :: Point2 -> World -> World lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w lowLightHit :: Point2 -> Point2 -> World -> World lowLightHit a b w = case thingsHitLongLine a b w of ((p, E3x2 wall):_) -> over particles' ((:) (wallGlare p wall)) w ((p, E3x1 cr):_) -> over afterParticles' ((:) (crGlare p cr)) w _ -> w wallGlare :: Point2 -> Wall -> Particle' wallGlare p wl = wallGlareWidth 10 5 white 0.5 p wl crGlare :: Point2 -> Creature -> Particle' crGlare = crGlareCol white 0.5 -- crGlare p cr = -- Particle' -- { _ptPict' = [(l, [levLayer WlLayer + 2])] -- , _ptUpdate' = ptTimer' 1 -- } -- where l = uncurry translate cp -- $ rotate (90 - (radToDeg $ argV (p -.- cp))) -- $ color (withAlpha 0.5 white) -- $ thickArc 0 180 (_crRad cr) 5 -- -- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5 -- cp = _crPos cr 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 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 threeEff' crEff wlEff ffEff pt thing w = case thing of (p,E3x1 cr) -> crEff pt p cr w (p,E3x2 wl) -> wlEff pt p wl w (p,E3x3 ff) -> ffEff pt p ff w 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 ) ((hitp,thing):_) -> ( hiteff bt (hitp,thing) w , Just $ set btPassThrough' Nothing $ set btTrail' (hitp:p:ps) $ set ptPict' (bulLine col wth (hitp:p:ps)) $ set btTimer' 3 bt ) where mcr = _btPassThrough' bt col = _btColor' bt (p:ps) = _btTrail' bt vel = _btVel' bt hiteff = _btHitEffect' bt wth = _btWidth' bt t = _btTimer' bt bulLine c w = setLayer 1 . bulLinea c 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] ] -- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b] -- ,color white $ wedgeOfThickness width a b --bulLine col width (a:b:c:_) -- = onLayer HPtLayer $ pictures -- [color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c] -- ,color white $ wedgeOfThickness width a c 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 thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))] thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr)) $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs crs = zip crPs (map E3x1 hitCrs) -- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w) 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 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 = crs ++ walls thingsHitLongLine sp ep w = 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 $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs --crPs = map _crPos hitCrs crs = zip crPs (map E3x1 hitCrs) -- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w) hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w --hitWls = wallsOnLine sp ep $ _walls w f i m = case IM.lookup i m of Just val -> val _ -> IM.empty --walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1) -- 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 cr = _creatures w IM.! 0 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 -> World -> World makeSmokeAt p w = over particles (IM.insert n smP) w where n = newParticleKey w smP = Particle { _ptPos = p , _ptStartPos = p , _ptVel = (0,0) , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1 --, _ptPict = uncurry translate p $ color white $ circleSolid 30 , _ptID = n , _ptUpdate = moveSmoke p 20 n } moveSmoke :: Point2 -> Int -> Int -> World -> World moveSmoke p time i | time > 0 = set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i) | time > -50 = set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i) | otherwise = over particles (IM.delete i) where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ 21 - fromIntegral time pi1 = onLayer PtLayer $ uncurry translate p $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) $ circleSolid $ 21 makeSmokeAt' :: Float -> Int -> Point2 -> World -> World makeSmokeAt' scal time p w = over particles (IM.insert n smP) w where n = newParticleKey w smP = Particle { _ptPos = p , _ptStartPos = p , _ptVel = (0,0) , _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1 , _ptID = n , _ptUpdate = moveSmoke' scal p time n } moveSmoke' :: Float -> Point2 -> Int -> Int -> World -> World moveSmoke' scal p time i | time > 0 = set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i) | time > -50 = set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i) | otherwise = over particles (IM.delete i) where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal pi1 = onLayer PtLayer $ uncurry translate p $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) $ circleSolid $ 21 * scal 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 thingHit :: Point2 -> Maybe (Point2,a,b) -> Maybe (Point2,c) -> Maybe (Either (Point2,a,b) (Point2,c)) thingHit p Nothing Nothing = Nothing thingHit p (Just x) Nothing = Just (Left x) thingHit p Nothing (Just x) = Just (Right x) thingHit p (Just x@(p1,_,_)) (Just y@(p2,_)) | magV (p -.- p1) > magV (p -.- p2) = Just (Right y) | otherwise = Just (Left x) 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