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]
|
||||
]
|
||||
Reference in New Issue
Block a user