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

Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop

Browse Source
This commit is contained in:
Ross
2021-04-06 17:55:59 +01:00
parent 76dfe01442 ebcac39069
commit 79673574b9
21 changed files with 593 additions and 358 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+123 -65
View File
@@ -583,8 +583,9 @@ collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for first collision of a point with walls
-- if found, gives point and colour of wall
{- | Looks for first collision of a point with walls.
If found, gives point and colour of wall.
-}
collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
( (\(m, c) -> fmap (flip (,) c) m)
@@ -592,8 +593,9 @@ collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for first collision of a point with walls
-- if found, gives point, and normal and colour of wall
{- | Looks for first collision of a point with walls.
If found, gives point, and normal and colour of wall.
-}
collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
collidePointWallsNormCol p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
@@ -603,7 +605,7 @@ collidePointWallsNormCol p1 p2 ws
m w = let (a1,a2,a3) = ls w
in fmap (\a4 -> (a4,a2,a3)) a1
--returns the first creature, if any, that a point intersects with
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
@@ -611,8 +613,8 @@ collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toLi
)
(_creatures w)
where csnd (_,a) (_,b) = compare a b
--as for collidePointCreatures, only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
@@ -622,35 +624,46 @@ collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.t
where csnd (_,a) (_,b) = compare a b
--returns the first creature, if any, that a point intersects with, gives point
--in creature on line
-- | Returns the first creature, if any, that a point intersects with, gives point
--in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
)
(_creatures w)
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
)
(_creatures w)
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
collideCircCrsPoint p1 p2 rad w
= fmap f
. listToMaybe
. sortBy (csndsnd)
. IM.toList
$ IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
)
(_creatures w)
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
-- makes a creatures not hittable
-- | Makes a creature not hittable.
collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
)
(IM.delete cid $ _creatures w)
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
collidePointCrsWithoutPoint cid p1 p2 w
= fmap f
. listToMaybe
. sortBy (csndsnd)
. IM.toList
$ IM.mapMaybe (\x ->
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
)
(IM.delete cid $ _creatures w)
where
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
f (cID,(p,_)) = (p,cID)
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad)
@@ -664,55 +677,85 @@ crsNearPoint :: Float -> Point2 -> World -> Bool
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
crsOnLine :: Point2 -> Point2 -> World -> [Creature]
crsOnLine p1 p2 w = IM.elems
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w
crsOnLine p1 p2 w
= IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w = IM.elems
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w
crsOnThickLine thickness p1 p2 w
= IM.elems
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w
{- | Find 'Maybe' the closest creature to a point, within a circle.
-}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
in listToMaybe sortedCrs
nearestCrInRad p r w
= let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
in listToMaybe sortedCrs
nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.
-}
nearestCrInTri
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInTri p dir x w
= let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
in listToMaybe sortedCrs
where tri = [p
,p +.+ rotateV (dir-pi/4) (x,0)
,p +.+ rotateV (dir+pi/4) (x,0)
]
nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
where
tri = [p
,p +.+ rotateV (dir-pi/4) (x,0)
,p +.+ rotateV (dir+pi/4) (x,0)
]
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance.
The shapes within which creatures are searched are a triangle then rectangle.
-}
nearestCrInFront
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInFront p dir x w
= let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
in listToMaybe sortedCrs
where rec = [p
,pR
,pR1
,pL1
,pL
]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
pR1 = pR +.+ rotateV dir (x/2,0)
pL1 = pL +.+ rotateV dir (x/2,0)
where
rec = [p
,pR
,pR1
,pL1
,pL
]
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
pR1 = pR +.+ rotateV dir (x/2,0)
pL1 = pL +.+ rotateV dir (x/2,0)
{- | Test whether a creature is in a polygon.
-}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
{- | Uses a layer to set the depth.
-}
onLayer :: Layer -> Picture -> Picture
onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100
{- | Set a depth according to a list of numbers.
Lists are lexicographically ordered if input values are always less than 100.
Higher numbers will get placed on top of lower numbers.
-}
onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..]))
onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
{- | For depth testing, set layer values.
-}
levLayer :: Layer -> Int
levLayer BgLayer = 20
levLayer PressPlateLayer = 45
@@ -729,6 +772,8 @@ levLayer LabelLayer = 80
levLayer InvLayer = 85
levLayer MenuLayer = 90
{- | Transform coordinates from world position to normalised screen coordinates.
-}
worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where
@@ -739,6 +784,9 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
, y * 2 / _windowY w
)
{- | Transform coordinates from the map position to normalised screen
coordinates.
-}
cartePosToScreen :: World -> Point2 -> Point2
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
where
@@ -749,32 +797,42 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
, y * 2 / _windowY w
)
{- | The mouse position in world coordinates.
-}
mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
{- | The mouse position in map coordinates
-}
mouseCartePos :: World -> Point2
mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot w) (_mousePos w)
{- | Create a logistic function given three parameters.
-}
logistic :: Float -> Float -> Float -> (Float -> Float)
logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
wallLOS :: [Point2] -> Point2 -> Point2 -> Bool
{-# INLINE wallLOS #-}
wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y
where n = 10 *.* (normV . vNormal $ y -.- x)
x' = x +.+ n
y' = y +.+ n
wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
{-# INLINE wallsLOS #-}
wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
{- | given a target and a start point, shift toward the end point by a given
amount.
If close enough, end up on the end point
-}
mvPointTowardAtSpeed
:: Float -- ^ Speed.
-> Point2 -- ^ End point.
-> Point2 -- ^ Start point.
-> Point2
mvPointTowardAtSpeed speed !ep !p
| dist p ep < speed = ep
| otherwise = p +.+ speed *.* normalizeV (ep -.- p)
mvPointToward :: Point2 -> Point2 -> Point2
{- | given a target and a start point, shift toward the end point by 1.
If close enough, end up on the end point
-}
mvPointToward
:: Point2 -- ^ End point.
-> Point2 -- ^ Start point.
-> Point2
mvPointToward !ep !p | dist p ep < 1 = ep
| otherwise = p +.+ normalizeV (ep -.- p)
src/Dodge/Creature.hs
+2 -6
View File
@@ -14,6 +14,7 @@ import Dodge.Item.Consumable
import Dodge.WorldEvent.Cloud
import Dodge.Creature.YourControl
import Dodge.Creature.Inanimate
import Dodge.Item
import Picture
import Geometry
@@ -255,13 +256,9 @@ startCr = defaultCreature
[pistol
,blinkGun
,spawnGun lamp
,flameGrenade
,teslaGrenade
,poisonSprayer
,autoGun
,launcher
,flameLauncher
,poisonLauncher
,teslaLauncher
,lasGun
,grenade
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
@@ -272,7 +269,6 @@ startCr = defaultCreature
,miniGun
,medkit 50
,bezierGun
,poisonSprayer
]
++ repeat NoItem))
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
src/Dodge/CreatureAction.hs
+8 -4
View File
@@ -7,7 +7,7 @@ module Dodge.CreatureAction
where
-- imports {{{
import Dodge.CreatureAction.UseItem
import Dodge.WorldEvent.Shockwave
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
@@ -223,7 +223,7 @@ createItemAt p it w = over floorItems (IM.insert i (set flItPos p
blinkAction :: Int -> World -> World
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
$ blinkShockwave p3
$ blinkShockwave n p3
$ inverseShockwaveAt cp 40 2 2 2
w
where p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
@@ -232,8 +232,12 @@ blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
r = 1.5 * _crRad (_creatures w IM.! n)
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
blinkShockwave :: Point2 -> World -> World
blinkShockwave p = makeShockwaveAt p 40 1 2 cyan
blinkShockwave
:: Int -- ^ Blinking creature ID.
-> Point2
-> World
-> World
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
moveAmountToward :: Point2 -> Float -> Point2 -> Point2
moveAmountToward p1 am p2
src/Dodge/Item.hs
+53
View File
@@ -0,0 +1,53 @@
module Dodge.Item
where
import Dodge.Data
import Dodge.Base
import Dodge.Default
import Picture
keyToken :: Int -> Item
keyToken n = defaultEquipment
{ _itIdentity = Generic
, _itName = "KEYTOKEN "++show n
, _itMaxStack = 5
, _itAmount = 1
, _itFloorPict = setDepth 0.5 $ keyPic
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
, _itID = Nothing
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itZoom = defaultItZoom
, _itInvColor = yellow
, _itInvDisplay = _itName
}
keyPic = color green $
pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 [(4,0),(4,-4)]
]
latchkey :: Int -> Item
latchkey n = defaultEquipment
{ _itIdentity = Generic
, _itName = "KEY "++show n
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = setDepth 0.5 $ latchkeyPic
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
, _itID = Nothing
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itZoom = defaultItZoom
, _itInvColor = yellow
, _itInvDisplay = _itName
}
latchkeyPic = color yellow $
pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 [(4,0),(4,-4)]
]
src/Dodge/Item/Weapon.hs
-25
View File
@@ -920,9 +920,6 @@ flamerAngle = 0.3
aSelf :: Int -> World -> World
aSelf = blinkAction
reflect :: Float -> Float -> Float
reflect a b = a + 2*(a-b)
@@ -1581,28 +1578,6 @@ jetPack = defaultEquipment
, _itID = Nothing
}
latchkey :: Int -> Item
latchkey n = defaultEquipment
{ _itIdentity = Generic
, _itName = "KEY "++show n
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ latchkeyPic
, _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
, _itID = Nothing
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itZoom = defaultItZoom
, _itInvColor = yellow
, _itInvDisplay = _itName
}
latchkeyPic = color yellow $
pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 [(4,0),(4,-4)]
]
-- }}}
src/Dodge/Item/Weapon/Bullet.hs
+3 -2
View File
@@ -5,6 +5,7 @@ import Dodge.Base
import Dodge.WorldEvent
import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.WorldEvent.Shockwave
import Dodge.Creature.Property
@@ -129,7 +130,7 @@ bulConCr' bt p cr w
where cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
bulHitWall' bt p x w = damageBlocks x
@@ -195,7 +196,7 @@ bulConWall' bt p wl w = damageBlocks wl
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
hvBulHitWall' bt p x w = damageBlocks x
src/Dodge/SoundLogic.hs
+23 -16
View File
@@ -1,5 +1,7 @@
module Dodge.SoundLogic where
import Dodge.Data
import Sound.Preload (SoundStatus (..))
import Control.Lens
import qualified Data.Map as M
@@ -19,22 +21,24 @@ soundOnceOrigin :: Int -> SoundOrigin -> World -> World
soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound)
where
sound = Sound
{ _soundType = sType
, _soundTime = Nothing
, _soundFadeTime = 0
, _soundChannel = Nothing
, _soundPos = Nothing
{ _soundChunkID = sType
, _soundTime = Nothing
, _soundFadeTime = 0
, _soundStatus = ToStart
, _soundChannel = Nothing
, _soundPos = Nothing
}
soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w
where
sound = Sound
{ _soundType = sType
, _soundTime = Just time
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
{ _soundChunkID = sType
, _soundTime = Just time
, _soundStatus = ToStart
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime}
@@ -43,12 +47,15 @@ soundMultiFrom [] _ _ _ w = w
soundMultiFrom (so:sos) sType time fadeTime w
| so `M.member` _sounds w = soundMultiFrom sos sType time fadeTime w
| otherwise = over sounds (M.insert so sound) w
where sound = Sound { _soundType = sType
, _soundTime = Nothing
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
where
sound = Sound
{ _soundChunkID = sType
, _soundTime = Nothing
, _soundStatus = ToStart
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
stopSoundFrom :: SoundOrigin -> World -> World
src/Dodge/WorldEvent.hs
+1 -46
View File
@@ -19,6 +19,7 @@ import Dodge.WorldEvent.Cloud
import Dodge.WorldEvent.HitEffect
import Dodge.WorldEvent.Explosion
import Dodge.WorldEvent.SpawnParticle
import Dodge.WorldEvent.Shockwave
import Dodge.LightSources
import Dodge.Data
@@ -38,52 +39,6 @@ import Data.Function
import Data.List
import qualified Data.IntMap.Strict as IM
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
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
where theShockwave
= Particle'
{ _ptDraw = const 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 ptDraw (const $ 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
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createBarrelSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles' ((:) spark)
src/Dodge/WorldEvent/Explosion.hs
+2 -72
View File
@@ -7,7 +7,7 @@ import Dodge.WorldEvent.SpawnParticle
import Dodge.WorldEvent.Flash
import Dodge.RandomHelp
import Dodge.SoundLogic
import Dodge.WorldEvent.Shockwave
import Geometry
import Picture
@@ -57,7 +57,7 @@ makeExplosionAt :: Point2 -> World -> World
makeExplosionAt p w = soundOnce grenadeBang
. addFlames
. explosionFlashAt p
$ makeShockwaveAt p 50 10 1 white
$ makeShockwaveAt [] p 50 10 1 white
w
where
fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
@@ -74,73 +74,3 @@ makeExplosionAt p w = soundOnce grenadeBang
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
$ collidePointWalls p q $ wallsNearPoint q 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'
{ _ptDraw = const 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 ptDraw (const 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 ptDraw (const $ 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
src/Dodge/WorldEvent/Shockwave.hs
+114
View File
@@ -0,0 +1,114 @@
module Dodge.WorldEvent.Shockwave
( makeShockwaveAt
, inverseShockwaveAt
)
where
import Dodge.Data
import Dodge.Base
import Geometry
import Picture
import qualified Data.IntMap.Strict as IM
import Control.Lens
makeShockwaveAt
:: [Int] -- ^ IDs of invulnerable creatures.
-> Point2 -- ^ Center of shockwave.
-> Float -- ^ Maximal radius.
-> Int -- ^ Damage caused per frame.
-> Float -- ^ Amount of pushback per frame.
-> Color -- ^ Color of shockwave.
-> World -- ^ Start world.
-> World
makeShockwaveAt is p rad dam push col = over particles' ((:) theShockwave)
where theShockwave = shockwaveAt is p rad dam push col 10
shockwaveAt
:: [Int] -- ^ IDs of invulnerable creatures.
-> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
shockwaveAt is p rad dam push col maxtime
= Shockwave'
{ _ptDraw = drawShockwave
, _ptUpdate' = mvShockwave' is
, _btColor' = col
, _btPos' = p
, _btRad' = rad
, _btDam' = dam
, _btPush' = push
, _btMaxTime' = maxtime
, _btTimer' = maxtime
}
drawShockwave :: Particle' -> Picture
drawShockwave pt = pic
where
pic = onLayer PtLayer $ uncurry translate p
$ color (_btColor' pt) $ thickCircle rad thickness
p = _btPos' pt
r = _btRad' pt
thickness = tFraction**2 * r
rad = r - (3/4) * r * tFraction
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
t = _btTimer' pt
mvShockwave'
:: [Int] -- ^ IDs of invulnerable creatures.
-> World -> Particle' -> (World, Maybe Particle')
mvShockwave' is w pt
| _btTimer' pt <= 0 = (w, Nothing)
| otherwise
= (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt)
where
r = _btRad' pt
p = _btPos' pt
push = _btPush' pt
dam = _btDam' pt
t = _btTimer' pt
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
rad = r - (3/4) * r * tFraction
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 | _crID cr `elem` is = cr
| dist (_crPos cr) p < rad + _crRad cr
= over (crState . crDamage)
((:) $ PushDam dam (25 * push *.* 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'
{ _ptDraw = const 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 ptDraw (const $ 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