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

Replace particle pictures with draw functions

Browse Source
This commit is contained in:
jgk
2021-03-24 13:42:31 +01:00
parent 27fc9d19d2
commit 3cce959d00
8 changed files with 70 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+4 -4
View File
@@ -429,10 +429,10 @@ data ItemIdentity
data Particle' =
Particle'
{ _ptPict' :: Picture
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
}
| Bul' { _ptPict' :: Picture
| Bul' { _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btVel' :: Point2
, _btColor' :: Color
@@ -442,7 +442,7 @@ data Particle' =
, _btTimer' :: Int
, _btHitEffect' :: HitEffect
}
| Pt' { _ptPict' :: Picture
| Pt' { _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btVel' :: Point2
, _btColor' :: Color
@@ -453,7 +453,7 @@ data Particle' =
, _btHitEffect' :: HitEffect
}
| Shockwave'
{ _ptPict' :: Picture
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btColor' :: Color
, _btPos' :: Point2
src/Dodge/Item/Weapon.hs
+47 -13
View File
@@ -878,7 +878,7 @@ aFlame a cid w
makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame pos vel maycid = over particles' ((:) theFlame)
where theFlame =
Pt' { _ptPict' = blank
Pt' { _ptDraw = drawFlame
, _ptUpdate' = moveFlame vel
, _btVel' = vel
, _btColor' = red
@@ -889,6 +889,40 @@ makeFlame pos vel maycid = over particles' ((:) theFlame)
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
drawFlame :: Particle' -> Picture
drawFlame pt = thePic ep
where ep = _btPos' pt
rotd = _btVel' pt
thePic p' = pictures $ reverse [ pic p' , piu p' , pi2 p' , glow p' ]
pic p' = setLayer 1 . setDepth 0.2994 $ uncurry translate (prot3 p')
$ rotate (pi * 0.5 + argV rotd)
$ scale scaleChange 1
$ pictures $ reverse [color white $ circleSolid 4
,color (withAlpha 0.5 white) $ circleSolid 5
]
piu p' = setLayer 1 . setDepth 0.2998 $ uncurry translate (prot2 p')
$ rotate (pi*0.5 + argV rotd)
$ scale (scaleChange + 1) 2
$ pictures $ reverse [color red $ circleSolid 4.5
,color (withAlpha 0.5 red) $ circleSolid 5
]
pi2 p' = setLayer 1
. setDepth 0.2996
. uncurry translate (prot p')
$ rotate (pi * 0.5 + argV rotd)
$ scale (scaleChange + 0.5) 1.5
$ pictures $ reverse [color orange $ circleSolid 4.5
,color (withAlpha 0.5 orange) $ circleSolid 5
]
glow p' = setLayer 1 $ setDepth 0.3 $ uncurry translate p'
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
time = _btTimer' pt
scaleChange | time < 80 = 3
| otherwise = 3 - (fromIntegral time - 80) * 0.2
prot p' = p' +.+ rotateV (fromIntegral time * 1) (0,1)
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle')
moveFlame rotd w pt
| time <= 0 = (smokeGen w, Nothing)
@@ -902,10 +936,10 @@ moveFlame rotd w pt
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepic ep
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep--, _ptDraw = const $ thepic ep
, _btPassThrough' = Nothing
,_btVel' = 0.98 *.* vel}
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepic ep
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep--, _ptDraw = const $ thepic ep
, _btPassThrough' = Nothing
,_btVel' = 0.7 *.* vel}
damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs
@@ -940,7 +974,7 @@ moveFlame rotd w pt
,color (withAlpha 0.5 red) $ circleSolid 5
]
rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p
, _btVel' = reflV wl, _ptPict' = thepic $ pOut p
, _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p
}
glow p' = setLayer 1 $ setDepth 0.3 $ uncurry translate p'
$ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50
@@ -1133,7 +1167,7 @@ rateIncAB startRate fastRate shooteff1 shooteff2 cid w
makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle'
makeLaserAt phaseV pos dir mcid = Particle'
{ _ptPict' = blank
{ _ptDraw = const blank
, _ptUpdate' = moveLaser phaseV pos dir mcid
}
@@ -1142,7 +1176,7 @@ moveLaser phaseV pos dir mcid w pt
= ( set randGen g
-- $ over worldEvents ((.) flares)
$ hitEffect w
, Just pt {_ptPict' = onLayer PtLayer $ pic
, Just pt {_ptDraw = const $ onLayer PtLayer $ pic
,_ptUpdate' = ptTimer' 0
}
)
@@ -1900,7 +1934,7 @@ aRadarPulse cid w = over particles' ((:) $ radarPulseAt (_crPos (_creatures w IM
blipAt :: Point2 -> Color -> Int -> Particle'
blipAt p col i = Particle'
{_ptPict' = blank
{_ptDraw = const blank
,_ptUpdate' = mvBlip p col i i
}
@@ -1908,7 +1942,7 @@ mvBlip :: Point2 -> Color -> Int -> Int -> World -> Particle' -> (World, Maybe P
mvBlip p col maxt 0 w pt = (w, Nothing)
mvBlip p col maxt t w pt
= (w, Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1)
& ptPict' .~ (onLayerL [levLayer ShadowLayer, 2]
& ptDraw .~ (const $ onLayerL [levLayer ShadowLayer, 2]
$ uncurry translate p
$ color (withAlpha (fromIntegral t / fromIntegral maxt) col)
$ circleSolid 2)
@@ -1916,13 +1950,13 @@ mvBlip p col maxt t w pt
sonarPulseAt :: Point2 -> Particle'
sonarPulseAt p = Particle'
{ _ptPict' = blank
{ _ptDraw = const blank
, _ptUpdate' = mvSonar 100 p
}
mvSonar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle')
mvSonar 0 _ w _ = (w, Nothing)
mvSonar x p w pt = (w, Just $ pt {_ptPict' = pic
mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic
,_ptUpdate' = mvSonar (x-1) p
}
)
@@ -1949,13 +1983,13 @@ mvSonar x p w pt = (w, Just $ pt {_ptPict' = pic
radarPulseAt :: Point2 -> Particle'
radarPulseAt p = Particle'
{ _ptPict' = blank
{ _ptDraw = const blank
, _ptUpdate' = mvRadar 50 p
}
mvRadar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle')
mvRadar 0 _ w _ = (w, Nothing)
mvRadar x p w pt = (putBlips w, Just $ pt {_ptPict' = pic
mvRadar x p w pt = (putBlips w, Just $ pt {_ptDraw = const pic
,_ptUpdate' = mvRadar (x-1) p
}
)
@@ -2057,7 +2091,7 @@ itemLaserScopeEffect
makeLaserScope :: Point2 -> Point2 -> Float -> Float -> Particle'
makeLaserScope p ep d relFrac = Particle'
{_ptPict' = onLayer PtLayer $ pictures
{_ptDraw = const $ onLayer PtLayer $ pictures
[color (withAlpha 0.5 $ mixColors relFrac (1-relFrac) red green)
$ lineOfThickness 0.5 [p,ep]
,color (withAlpha 0.2 $ mixColors relFrac (1-relFrac) red green)
src/Dodge/Item/Weapon/Bullet.hs
+2 -2
View File
@@ -223,7 +223,7 @@ bulletParticleSideEffect pt = destroyOnImpact mkPt mkPt noEff
aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect -> Float -> Particle'
aGenBulAt' maycid col pos vel hiteff width = Bul'
{ _ptPict' = blank
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = vel
, _btColor' = col
@@ -236,7 +236,7 @@ aGenBulAt' maycid col pos vel hiteff width = Bul'
aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect -> Float -> Particle'
aCurveBulAt maycid col pos control targ hiteff width = Bul'
{ _ptPict' = blank
{ _ptDraw = drawBul
, _ptUpdate' = mvBulletTrajectory f
, _btVel' = (0,0)
, _btColor' = col
src/Dodge/Rendering.hs
+1 -1
View File
@@ -42,7 +42,7 @@ worldPictures w
, map crDraw . IM.elems $ _creatures w
, map clDraw . IM.elems $ _clouds w
, map btDraw (IM.elems (_buttons w))
, map _ptPict' $ _particles' w
, map (\pt -> _ptDraw pt pt) $ _particles' w
, map drawWallFloor (wallFloorsToDraw w)
-- , map (drawWallFace w) (wallShadowsToDraw w)
, testPic w
src/Dodge/WorldEvent.hs
+13 -10
View File
@@ -75,7 +75,7 @@ makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave)
shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
shockwaveAt p rad dam push col maxtime
= Shockwave'
{ _ptPict' = blank
{ _ptDraw = const blank
, _ptUpdate' = mvShockwave'
, _btColor' = col
, _btPos' = p
@@ -90,7 +90,7 @@ 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)
= (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt)
where r = _btRad' pt
p = _btPos' pt
push = _btPush' pt
@@ -119,7 +119,7 @@ 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
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
@@ -141,7 +141,7 @@ inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
where theShockwave
= Particle'
{ _ptPict' = blank
{ _ptDraw = const blank
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
}
moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
@@ -149,7 +149,7 @@ 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
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
@@ -175,7 +175,7 @@ createSpark time colid pos dir maycid w = over worldEvents
-- . flareAt' white 0.02 0.05 pos')
. sparkFlashAt pos')
) w
where spark = Bul' { _ptPict' = blank
where spark = Bul' { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
@@ -192,12 +192,15 @@ createSpark time colid pos dir maycid w = over worldEvents
where sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
drawBul :: Particle' -> Picture
drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createBarrelSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles' ((:) spark)
. sparkFlashAt pos')
) w
where spark = Bul' { _ptPict' = blank
where spark = Bul' { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
@@ -221,7 +224,7 @@ makeFlameletTimed pos vel levelInt maycid size time w
= set randGen g $ over particles' ((:) theFlamelet) w
-- $ flareAt' white 0.01 0.1 pos w
where theFlamelet =
Pt' { _ptPict' = blank
Pt' { _ptDraw = const blank
, _ptUpdate' = moveFlamelet levelInt rot
, _btVel' = vel
, _btColor' = red
@@ -236,7 +239,7 @@ makeFlameletTimed pos vel levelInt maycid size time 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
Pt' { _ptDraw = const blank
, _ptUpdate' = moveFlamelet levelInt rot
, _btVel' = vel
, _btColor' = red
@@ -257,7 +260,7 @@ moveFlamelet levelInt rot w pt =
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptDraw = const thepicture
, _btPassThrough' = Nothing
,_btVel' = 0.8 *.* vel}
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
src/Dodge/WorldEvent/Bullet.hs
-40
View File
@@ -21,21 +21,18 @@ 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))
@@ -46,7 +43,6 @@ mvBulletTrajectory velF w bt
-- , 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
@@ -85,7 +81,6 @@ 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
@@ -97,38 +92,3 @@ mvGenBullet' w 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]
]
src/Dodge/WorldEvent/Flash.hs
+3 -3
View File
@@ -55,7 +55,7 @@ glareLine t len wdth col alphay a b w = w & particles' %~ (maybeToList linePt ++
glareBetween :: Int -> Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> Maybe Particle'
glareBetween 0 _ _ _ _ _ _ _ = Nothing
glareBetween t len wdth col alphay a b w
= Just $ Particle' {_ptPict' = lowLightPic len wdth col alphay a b w
= Just $ Particle' {_ptDraw = const $ lowLightPic len wdth col alphay a b w
,_ptUpdate' = \ w' _ -> (w',glareBetween (t-1) len wdth col alphay a b w')
}
@@ -76,7 +76,7 @@ lowLightPic len wdth col alphay a b w
flashFlareAt :: Color -> Float -> Point2 -> Particle'
flashFlareAt col alphax (x,y) =
Particle'
{ _ptPict' = setLayer 2 . setDepth (-0.9) . translate x y
{ _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y
$ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
, _ptUpdate' = ptTimer' 1
}
@@ -102,7 +102,7 @@ muzzleFlashAt p = over particles' ((:) (muzzleFlashPt p))
muzzleFlashPt :: Point2 -> Particle'
muzzleFlashPt (x,y) =
Particle'
{ _ptPict' = setDepth 0
{ _ptDraw = const $ setDepth 0
. setLayer 2
. translate x y
$ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20
src/Dodge/WorldEvent/Projectile.hs
-7
View File
@@ -22,10 +22,8 @@ destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of
((p,E3x2 wl):_) -> (wlEff pt p wl w, destroyAt p)
((p,E3x3 ff):_) -> (ffEff pt p ff w, destroyAt p)
where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl)
& ptPict' .~ drawBul wth (hitp: trl)
& btTimer' .~ 3
mvPt = Just $ pt & btTrail' .~ (newP : trl)
& ptPict' .~ drawBul wth (newP : trl)
& btTimer' %~ (\t -> t - 1)
& btPassThrough' .~ Nothing
trl = _btTrail' pt
@@ -41,15 +39,10 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
-> first (wlEff pt p wl) $ penWalls crEff wlEff ffEff pt hs w
((p,E3x2 wl):_) | otherwise -> (wlEff pt p wl w, destroyAt p)
where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl)
& ptPict' .~ drawBul wth (hitp: trl)
& btTimer' .~ 3
mvPt = Just $ pt & btTrail' .~ (newP : trl)
& ptPict' .~ drawBul wth (newP : trl)
& btTimer' %~ (\t -> t - 1)
& btPassThrough' .~ Nothing
trl = _btTrail' pt
wth = _btWidth' pt
newP = head trl +.+ _btVel' pt
drawBul :: Float -> [Point2] -> Picture
drawBul width (a:b:_) = setLayer 1 . color white $ thickLine [a,b] width
drawBul _ _ = blank