142 lines
6.3 KiB
Haskell
142 lines
6.3 KiB
Haskell
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 = hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w
|
|
-- 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]
|
|
]
|