Rename WorldActions to WorldEvent
This commit is contained in:
@@ -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]
|
||||
]
|
||||
@@ -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
|
||||
@@ -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)})
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user