Refactor window block
This commit is contained in:
+1
-1
@@ -7,7 +7,7 @@ import Dodge.SoundLogic
|
||||
import Dodge.CreatureAction
|
||||
import Dodge.KeyEvents
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.WorldActions
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.CreatureState
|
||||
|
||||
import Geometry
|
||||
|
||||
@@ -11,7 +11,7 @@ import Dodge.CreatureAction.UseItem
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.WorldActions
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.Inventory
|
||||
|
||||
import Geometry
|
||||
|
||||
@@ -4,7 +4,7 @@ import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.WorldActions
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.WallCreatureCollisions
|
||||
import Dodge.CreatureAction
|
||||
|
||||
|
||||
@@ -7,18 +7,6 @@ import Dodge.Base
|
||||
import Dodge.Floor
|
||||
import Dodge.Layout
|
||||
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Function
|
||||
import Data.Graph.Inductive.Graph
|
||||
import Data.Graph.Inductive.PatriciaTree
|
||||
import Codec.BMP
|
||||
import qualified Data.ByteString as B
|
||||
import Control.Lens
|
||||
import Control.Applicative
|
||||
import Control.Monad.State
|
||||
import Control.Monad
|
||||
import System.Random
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
@@ -53,7 +41,6 @@ initialWorld = basicWorld
|
||||
, _pressPlates = IM.empty
|
||||
, _buttons = IM.empty
|
||||
, _soundQueue = []
|
||||
-- , _loadedSounds = IM.empty
|
||||
, _sounds = M.empty
|
||||
, _decorations = IM.empty
|
||||
, _storedLevel = Nothing
|
||||
|
||||
@@ -9,7 +9,7 @@ import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.CreatureAction
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.WorldActions
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.Debug
|
||||
import Dodge.WallCreatureCollisions
|
||||
import Dodge.Prototypes
|
||||
|
||||
@@ -2,7 +2,7 @@ module Dodge.Item.Weapon.Bullet
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.WorldActions
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.RandomHelp
|
||||
|
||||
|
||||
@@ -3,7 +3,7 @@ module Dodge.Item.Weapon.TriggerType
|
||||
import Dodge.Data
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.CreatureAction (reloadWeapon)
|
||||
import Dodge.WorldActions (muzFlareAt,lowLightAt,tLightAt)
|
||||
import Dodge.WorldEvent (muzFlareAt,lowLightAt,tempLightForAt)
|
||||
import Dodge.RandomHelp
|
||||
|
||||
import Dodge.Item.Weapon.Bullet
|
||||
@@ -94,7 +94,7 @@ shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> am
|
||||
reloadCondition = _wpLoadedAmmo item == 0
|
||||
|
||||
withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
|
||||
withMuzFlare f cid w = over tempLightSources (tLightAt 3 pos :)
|
||||
withMuzFlare f cid w = tempLightForAt 3 pos
|
||||
. muzFlareAt pos2 $ f cid w
|
||||
where cr = _creatures w IM.! cid
|
||||
dir = _crDir cr
|
||||
|
||||
+2
-66
@@ -16,6 +16,7 @@ import Dodge.Data
|
||||
import Dodge.Base
|
||||
|
||||
import Dodge.LevelGen.Block
|
||||
import Dodge.LevelGen.WindowBlock
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
import Dodge.LevelGen.AutoDoor
|
||||
@@ -85,7 +86,7 @@ placeSpot ps w = case ps of
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutWindowBlock a b}
|
||||
-> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
-> putWindowBlock' (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
|
||||
-> rmCrossPaths $ over walls (addWindow (q:qs) c) w
|
||||
@@ -119,71 +120,6 @@ instance Shiftable PlacementSpot where
|
||||
translateS p' (PS p r x) = PS (p +.+ p') r x
|
||||
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
|
||||
|
||||
putWindowBlock :: Point2 -> Point2 -> World -> World
|
||||
putWindowBlock a b w = removePathsCrossing a b $ foldr (makeBlockAt bSide) w $ zip ps ns
|
||||
where d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
numPoints' = floor (d / 20)
|
||||
numPoints = numPoints'*2
|
||||
ns = take (numPoints+1) [0..]
|
||||
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
|
||||
$ map fromIntegral ns
|
||||
bSide = d / (fromIntegral numPoints)
|
||||
makeBlockAt :: Float -> (Point2,Int) -> World -> World
|
||||
makeBlockAt bSide (p,i) w =
|
||||
let k = newKey $ _walls w
|
||||
ds = [(-bSide,-9),(-bSide,9),(bSide,9),(bSide,-9)]
|
||||
polyAtP p = map ((+.+) p . rotateV rot) ds
|
||||
hp = 1
|
||||
degradeHP = [5,5]
|
||||
winCol = withAlpha 0.5 cyan
|
||||
ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
|
||||
(k0:k1:k2:k3:_) = ksAtN i
|
||||
(bl:tl:tr:br:_) = polyAtP p
|
||||
shadows | i == 0 = ksAtN 1
|
||||
| i == numPoints - 1 = ksAtN $ numPoints - 2
|
||||
| otherwise = ksAtN (i-1) ++ ksAtN (i+1)
|
||||
seen | even i = True
|
||||
| otherwise = False
|
||||
isLeftmost | i == 0 = True
|
||||
| otherwise = False
|
||||
isRightmost | i == numPoints = True
|
||||
| otherwise = False
|
||||
l = baseBlock
|
||||
{ _wlLine = [bl,tl]
|
||||
, _wlID = k0
|
||||
, _blVisible = isLeftmost
|
||||
}
|
||||
t = baseBlock
|
||||
{ _wlLine = [tl,tr]
|
||||
, _wlID = k1
|
||||
, _blVisible = seen
|
||||
}
|
||||
r = baseBlock
|
||||
{ _wlLine = [tr,br]
|
||||
, _wlID = k2
|
||||
, _blVisible = isRightmost
|
||||
}
|
||||
b = baseBlock
|
||||
{ _wlLine = [br,bl]
|
||||
, _wlID = k3
|
||||
, _blVisible = seen
|
||||
}
|
||||
baseBlock = Block
|
||||
{ _wlLine = []
|
||||
, _wlID = 0
|
||||
, _wlColor = winCol
|
||||
, _wlDraw = Nothing
|
||||
, _wlSeen = False
|
||||
, _blIDs = ksAtN i
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = True
|
||||
, _blVisible = seen
|
||||
, _blShadows = shadows
|
||||
, _blDegrades = degradeHP
|
||||
}
|
||||
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
|
||||
in over walls f w
|
||||
|
||||
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
||||
|
||||
|
||||
@@ -1,10 +1,15 @@
|
||||
module Dodge.LevelGen.WindowBlock
|
||||
(
|
||||
(putWindowBlock'
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.LevelGen.Pathing
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
@@ -23,3 +28,98 @@ basePane = Block
|
||||
, _blDegrades = [5,5]
|
||||
}
|
||||
--singleBlock :: [Int] -> IM.IntMap Wall
|
||||
|
||||
-- taken from online, splits a list into its even and odd elements
|
||||
evenOddSplit = foldr f ([],[])
|
||||
where f a (ls,rs) = (rs, a : ls)
|
||||
|
||||
putWindowBlock :: Point2 -> Point2 -> World -> World
|
||||
putWindowBlock a b w = removePathsCrossing a b $ foldr (makeBlockAt bSide) w $ zip ps ns
|
||||
where d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
numPoints = 2 * floor (d / 20)
|
||||
ns = take (numPoints+1) [0..]
|
||||
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
|
||||
$ map fromIntegral ns
|
||||
bSide = d / (fromIntegral numPoints)
|
||||
makeBlockAt :: Float -> (Point2,Int) -> World -> World
|
||||
makeBlockAt bSide (p,i) w =
|
||||
let k = newKey $ _walls w
|
||||
ds = [(-bSide,-9),(-bSide,9),(bSide,9),(bSide,-9)]
|
||||
polyAtP p = map ((+.+) p . rotateV rot) ds
|
||||
ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
|
||||
(k0:k1:k2:k3:_) = ksAtN i
|
||||
(bl:tl:tr:br:_) = polyAtP p
|
||||
shadows | i == 0 = ksAtN 1
|
||||
| i == numPoints - 1 = ksAtN $ numPoints - 2
|
||||
| otherwise = ksAtN (i-1) ++ ksAtN (i+1)
|
||||
seen | even i = True
|
||||
| otherwise = False
|
||||
isLeftmost | i == 0 = True
|
||||
| otherwise = False
|
||||
isRightmost | i == numPoints = True
|
||||
| otherwise = False
|
||||
l = baseBlock
|
||||
{ _wlLine = [bl,tl]
|
||||
, _wlID = k0
|
||||
, _blVisible = isLeftmost
|
||||
}
|
||||
t = baseBlock
|
||||
{ _wlLine = [tl,tr]
|
||||
, _wlID = k1
|
||||
, _blVisible = seen
|
||||
}
|
||||
r = baseBlock
|
||||
{ _wlLine = [tr,br]
|
||||
, _wlID = k2
|
||||
, _blVisible = isRightmost
|
||||
}
|
||||
b = baseBlock
|
||||
{ _wlLine = [br,bl]
|
||||
, _wlID = k3
|
||||
, _blVisible = seen
|
||||
}
|
||||
baseBlock = basePane
|
||||
{ _blIDs = ksAtN i
|
||||
, _blShadows = shadows
|
||||
}
|
||||
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
|
||||
in over walls f w
|
||||
|
||||
putWindowBlock' :: Point2 -> Point2 -> World -> World
|
||||
putWindowBlock' a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
|
||||
where d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
psOnLine = divideLineOddNumPoints 9 a b
|
||||
halfBlockWidth = d / (fromIntegral $ length psOnLine - 1)
|
||||
blockCenPs = snd $ evenOddSplit psOnLine
|
||||
numBlocks = length blockCenPs
|
||||
is = [0.. numBlocks - 1]
|
||||
cornerPoints = [(-halfBlockWidth,-9) -- goes anticlockwise around the block
|
||||
,(-halfBlockWidth, 9)
|
||||
,( halfBlockWidth, 9)
|
||||
,( halfBlockWidth,-9)
|
||||
]
|
||||
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
|
||||
linesAt p = map (\(a,b) -> [a,b]) $ makeLoopPairs $ cornersAt p
|
||||
k = newKey $ _walls w
|
||||
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
|
||||
visibilityAt i | i == 0 = [ True,True,False,True]
|
||||
| i == numBlocks - 1 = [False,True, True,True]
|
||||
| otherwise = [False,True,False,True]
|
||||
shadowsAt i | i == 0 = ksAtI 1
|
||||
| i == numBlocks - 1 = ksAtI $ numBlocks - 1
|
||||
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
|
||||
makeBlockAt :: Point2 -> Int -> [Wall]
|
||||
makeBlockAt p i = zipWith3 (makePane i) (ksAtI i) (visibilityAt i) (linesAt p)
|
||||
makePane i k' visStatus ps
|
||||
= basePane {_wlID = k'
|
||||
,_wlLine = ps
|
||||
,_blIDs = ksAtI i
|
||||
,_blShadows = shadowsAt i
|
||||
,_blVisible = visStatus
|
||||
}
|
||||
listBlocks = concat $ zipWith makeBlockAt blockCenPs is
|
||||
insertBlock :: Wall -> World -> World
|
||||
insertBlock wl = over walls $ IM.insert (_wlID wl) wl
|
||||
|
||||
|
||||
@@ -23,3 +23,34 @@ lightAt p i =
|
||||
basicLS = PutLS ls dec
|
||||
where ls = lightAt (0,0) 0
|
||||
dec = onLayer PtLayer $ color white $ circleSolid 8
|
||||
|
||||
|
||||
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
|
||||
tLightFade 0 rmax intensityF p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = intensityF 0
|
||||
, _tlsUpdate = \w _ -> (w, Nothing)
|
||||
}
|
||||
tLightFade i rmax intensityF p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = intensityF i
|
||||
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
|
||||
}
|
||||
|
||||
tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource
|
||||
tLightRad 0 rmax rmin p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = 0.5
|
||||
, _tlsUpdate = \w _ -> (w, Nothing)
|
||||
}
|
||||
tLightRad i rmax rmin p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = 0.5
|
||||
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
|
||||
}
|
||||
|
||||
tLightAt i p = tLightRad i 100 0 p
|
||||
|
||||
@@ -1,451 +0,0 @@
|
||||
module Dodge.WorldActions
|
||||
( module Dodge.WorldActions
|
||||
, module Dodge.WorldActions.Bullet
|
||||
, module Dodge.WorldActions.Flash
|
||||
, module Dodge.WorldActions.ThingsHit
|
||||
, module Dodge.WorldActions.HelperParticle
|
||||
)
|
||||
where
|
||||
|
||||
import Dodge.WorldActions.Bullet
|
||||
import Dodge.WorldActions.Flash
|
||||
import Dodge.WorldActions.ThingsHit
|
||||
import Dodge.WorldActions.HelperParticle
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.RandomHelp
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
|
||||
import System.Random
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
makeExplosionAt :: Point2 -> World -> World
|
||||
makeExplosionAt p w = soundOnce grenadeBang
|
||||
$ over tempLightSources ((:) $ tLightFade 20 150 intensityF p)
|
||||
$ fs
|
||||
$ over particles (IM.insert n exp)
|
||||
w
|
||||
where n = newParticleKey w
|
||||
exp = Particle
|
||||
{ _ptPos = p
|
||||
, _ptStartPos = p
|
||||
, _ptVel = (0,0)
|
||||
, _ptPict = blank
|
||||
, _ptID = n
|
||||
, _ptUpdate = explosionWaveDamage 6 p n
|
||||
}
|
||||
fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
|
||||
fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w
|
||||
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5)
|
||||
--fPs = map (pushAgainstWalls . (+.+) p . (*.*) 5)
|
||||
fPs'
|
||||
inversePushOut v = (15 - magV v) * 0.01 *.* v
|
||||
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
|
||||
sizes = randomRs (2,6) $ _randGen w
|
||||
times = randomRs (20,25) $ _randGen w
|
||||
mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time
|
||||
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
|
||||
fs w = foldr ($) w newFs
|
||||
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
|
||||
$ collidePointWalls p q $ wallsNearPoint q w
|
||||
fadeFac x | x > 10 = 0
|
||||
| otherwise = 1 - fromIntegral x / 10
|
||||
intensityF x | x < 10 = 1 / (10 - fromIntegral x)
|
||||
| otherwise = 1
|
||||
|
||||
explosionWaveDamage :: Int -> Point2 -> Int -> World -> World
|
||||
explosionWaveDamage 0 p ptid = over particles (IM.delete ptid)
|
||||
explosionWaveDamage time p ptid
|
||||
= set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid)
|
||||
. shockWaveDamage p rad 20
|
||||
. set (particles . ix ptid . ptPict) shockwavePic
|
||||
. explosionFlashAt p
|
||||
where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white)
|
||||
$ thickCircle rad (thickness*2)
|
||||
thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8
|
||||
rad = 40 - thickness
|
||||
|
||||
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
|
||||
|
||||
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'
|
||||
{ _ptPict' = 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 ptPict' 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 ptPict' (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
|
||||
|
||||
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
|
||||
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
||||
where theShockwave
|
||||
= Particle'
|
||||
{ _ptPict' = 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 ptPict' (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
|
||||
|
||||
-- if the spark is created by another Particle', it cannot be directly added to
|
||||
-- the list, hence the redirect through worldEvents
|
||||
createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
||||
createSpark time colid pos dir maycid w = over worldEvents
|
||||
((.) $ ( over particles' ((:) spark)
|
||||
. flareAt' white 0.02 0.05 pos')
|
||||
-- . lowLightAt' pos)
|
||||
) w
|
||||
where spark = Bul' { _ptPict' = blank
|
||||
, _ptUpdate' = mvGenBullet'
|
||||
, _btVel' = rotateV dir (5,0)
|
||||
, _btColor' = numColor colid
|
||||
, _btTrail' = [pos]
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = 1
|
||||
, _btTimer' = time
|
||||
, _btHitEffect' = threeEff' sparkEff noEff noEff
|
||||
}
|
||||
x = fst $ randomR (0,20) $ _randGen w
|
||||
pos' = pos +.+ rotateV dir (x,0)
|
||||
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
||||
((:) $ SparkDam 1 sp p ep)
|
||||
where sp = head (_btTrail' bt)
|
||||
ep = sp +.+ _btVel' bt
|
||||
|
||||
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
||||
createBarrelSpark time colid pos dir maycid w = over worldEvents
|
||||
((.) $ ( over particles' ((:) spark)
|
||||
. flareAt' white 0.005 0.03 pos')
|
||||
-- . lowLightAt' pos)
|
||||
) w
|
||||
where spark = Bul' { _ptPict' = blank
|
||||
, _ptUpdate' = mvGenBullet'
|
||||
, _btVel' = rotateV dir (5,0)
|
||||
, _btColor' = numColor colid
|
||||
, _btTrail' = [pos]
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = 1
|
||||
, _btTimer' = time
|
||||
, _btHitEffect' = threeEff' sparkEff noEff noEff
|
||||
}
|
||||
x = fst $ randomR (0,20) $ _randGen w
|
||||
pos' = pos +.+ rotateV dir (x,0)
|
||||
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
||||
((:) $ SparkDam 1 sp p ep)
|
||||
where sp = head (_btTrail' bt)
|
||||
ep = sp +.+ _btVel' bt
|
||||
|
||||
|
||||
|
||||
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
|
||||
tLightFade 0 rmax intensityF p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = intensityF 0
|
||||
, _tlsUpdate = \w _ -> (w, Nothing)
|
||||
}
|
||||
tLightFade i rmax intensityF p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = intensityF i
|
||||
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
|
||||
}
|
||||
|
||||
tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource
|
||||
tLightRad 0 rmax rmin p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = 0.5
|
||||
, _tlsUpdate = \w _ -> (w, Nothing)
|
||||
}
|
||||
tLightRad i rmax rmin p =
|
||||
TLS { _tlsPos = p
|
||||
, _tlsRad = rmax
|
||||
, _tlsIntensity = 0.5
|
||||
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
|
||||
}
|
||||
|
||||
tLightAt i p = tLightRad i 100 0 p
|
||||
|
||||
|
||||
noEff _ _ _ = id
|
||||
|
||||
threeEff' ::
|
||||
( Particle' -> Point2 -> Creature -> World -> World ) ->
|
||||
( Particle' -> Point2 -> Wall -> World -> World ) ->
|
||||
( Particle' -> Point2 -> ForceField -> World -> World ) ->
|
||||
Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
|
||||
threeEff' crEff wlEff ffEff pt hitThings w = case hitThings of
|
||||
[] -> error "threeEff called without hitting anything"
|
||||
((p,E3x1 cr):_) -> (crEff pt p cr w, updatePt p)
|
||||
((p,E3x2 wl):_) -> (wlEff pt p wl w, updatePt p)
|
||||
((p,E3x3 ff):_) -> (ffEff pt p ff w, updatePt p)
|
||||
where updatePt hitp = Just $ pt & btTrail' .~ (hitp : trl)
|
||||
& ptPict' .~ bulLine col wth (hitp: trl)
|
||||
& btTimer' .~ 3
|
||||
trl = _btTrail' pt
|
||||
col = _btColor' pt
|
||||
wth = _btWidth' pt
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
|
||||
makeFlameletTimed pos vel levelInt maycid size time w
|
||||
= set randGen g $ over particles' ((:) theFlamelet)
|
||||
$ flareAt' white 0.01 0.1 pos w
|
||||
where theFlamelet =
|
||||
Pt' { _ptPict' = blank
|
||||
, _ptUpdate' = moveFlamelet levelInt rot
|
||||
, _btVel' = vel
|
||||
, _btColor' = red
|
||||
, _btPos' = pos
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = size
|
||||
, _btTimer' = time
|
||||
, _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff
|
||||
}
|
||||
(rot ,g) = randomR (0,3) $ _randGen 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
|
||||
, _ptUpdate' = moveFlamelet levelInt rot
|
||||
, _btVel' = vel
|
||||
, _btColor' = red
|
||||
, _btPos' = pos
|
||||
, _btPassThrough' = maycid
|
||||
, _btWidth' = size
|
||||
, _btTimer' = 20
|
||||
, _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff
|
||||
}
|
||||
(rot ,g) = randomR (0.5,1.5) $ _randGen w
|
||||
moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveFlamelet levelInt rot w pt =
|
||||
case _btTimer' pt of
|
||||
time | time <= 0 -> (w, Nothing)
|
||||
| otherwise -> (damcrs, mvPt)
|
||||
where sp = _btPos' pt
|
||||
vel = _btVel' pt
|
||||
ep = sp +.+ vel
|
||||
size = _btWidth' pt
|
||||
siz2 = size + 0.2
|
||||
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture
|
||||
, _btPassThrough' = Nothing
|
||||
,_btVel' = 0.8 *.* vel}
|
||||
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
|
||||
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
|
||||
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
||||
((:) $ Flaming 3 sp ep ep)
|
||||
pic = onLayerL [levelInt,3] $ uncurry translate ep
|
||||
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
||||
white (dark red)
|
||||
)
|
||||
$ rotate (0 - ( 0.1 * fromIntegral time + rot))
|
||||
$ scale sc sc
|
||||
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
|
||||
piu = onLayerL [levelInt,1] $ uncurry translate ep
|
||||
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
|
||||
$ scale s1 s1
|
||||
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
|
||||
glow = onLayerL [levelInt,0] $ uncurry translate ep
|
||||
$ color (withAlpha 0.01 red)
|
||||
$ circleSolid 30
|
||||
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
|
||||
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
|
||||
s2 = 0.5 * (sc + s1)
|
||||
thepicture = pictures [pic , piu , pi2 , glow]
|
||||
pi2 = onLayerL [levelInt,2] $ uncurry translate ep
|
||||
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
||||
orange (dark red)
|
||||
)
|
||||
$ rotate (0 - (rot + 0.2 * fromIntegral time))
|
||||
$ scale s2 s2
|
||||
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
|
||||
|
||||
|
||||
doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World
|
||||
doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
|
||||
((:) $ Flaming amount sp p ep)
|
||||
where sp = _btPos' pt
|
||||
ep = sp +.+ _btVel' pt
|
||||
|
||||
makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
|
||||
makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
|
||||
where smokeP = Particle'
|
||||
--{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
|
||||
{ _ptPict' = onLayerL [levLayer PtLayer ] $ uncurry translate p $ color black $ circleSolid 1
|
||||
, _ptUpdate' = moveSmoke'' scal time p vel
|
||||
}
|
||||
|
||||
moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveSmoke'' scal time p vel w pt
|
||||
| time > 0 = (w, Just $ pt { _ptPict' = pic
|
||||
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
|
||||
})
|
||||
| time > -50 = (w, Just $ pt { _ptPict' = pi1
|
||||
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
|
||||
})
|
||||
| otherwise = (w, Nothing)
|
||||
where pNew = p +.+ vel
|
||||
pic = onLayerL [levLayer PtLayer]
|
||||
--pic = onLayerL [levLayer PtLayer - 1]
|
||||
$ uncurry translate pNew
|
||||
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
|
||||
pi1 = pictures $ reverse
|
||||
[(onLayerL [levLayer PtLayer]
|
||||
$ uncurry translate pNew
|
||||
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
|
||||
$ circleSolid $ 21 * scal)
|
||||
,
|
||||
--(onLayerL [levLayer BgLayer+1]
|
||||
(onLayerL [levLayer PtLayer]
|
||||
$ uncurry translate pNew
|
||||
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
|
||||
$ circleSolid $ 21 * scal)
|
||||
]
|
||||
|
||||
makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
|
||||
makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w
|
||||
where n = newParticleKey w
|
||||
smP = Particle
|
||||
{ _ptPos = p
|
||||
, _ptStartPos = p
|
||||
, _ptVel = vel
|
||||
, _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1
|
||||
, _ptID = n
|
||||
, _ptUpdate = moveColorSmoke col scal time n
|
||||
}
|
||||
|
||||
moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World
|
||||
moveColorSmoke col scal time i w
|
||||
| time > 0
|
||||
= set (particles . ix i . ptPict) pic
|
||||
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
||||
. set (particles . ix i . ptPos) newPos
|
||||
. setVel
|
||||
$ w
|
||||
| time > -50
|
||||
= set (particles . ix i . ptPict) pi1
|
||||
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
|
||||
. set (particles . ix i . ptPos) newPos
|
||||
. setVel
|
||||
$ w
|
||||
| otherwise
|
||||
= over particles (IM.delete i) w
|
||||
where oldPos = _ptPos $ _particles w IM.! i
|
||||
newPos = oldPos +.+ (_ptVel $ _particles w IM.! i)
|
||||
setVel = over (particles . ix i . ptVel) $ (*.*) 0.99
|
||||
pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal
|
||||
pi1 = onLayer PtLayer $ uncurry translate newPos
|
||||
$ color (withAlpha (1 + fromIntegral time /50) col)
|
||||
$ circleSolid $ 21 * scal
|
||||
|
||||
damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
|
||||
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
|
||||
where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr)
|
||||
= over crHP (\hp -> hp - dam) cr
|
||||
| otherwise = cr
|
||||
@@ -1,140 +0,0 @@
|
||||
module Dodge.WorldActions.Bullet
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
|
||||
import Dodge.WorldActions.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]
|
||||
]
|
||||
@@ -1,137 +0,0 @@
|
||||
module Dodge.WorldActions.Flash
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
|
||||
import Dodge.WorldActions.ThingsHit
|
||||
import Dodge.WorldActions.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
|
||||
@@ -1,8 +0,0 @@
|
||||
module Dodge.WorldActions.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)})
|
||||
@@ -1,60 +0,0 @@
|
||||
module Dodge.WorldActions.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
|
||||
@@ -299,6 +299,16 @@ divideLine x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.
|
||||
numPoints = max 1 $ ceiling $ d / x
|
||||
ns = [0 .. numPoints]
|
||||
|
||||
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
|
||||
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
|
||||
divideLineOddNumPoints x a b = take 5000 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) )
|
||||
$ map fromIntegral ns
|
||||
where d = dist a b
|
||||
numPoints' = max 1 $ ceiling $ d / x
|
||||
numPoints | even numPoints' = numPoints'
|
||||
| otherwise = numPoints' + 1
|
||||
ns = [0 .. numPoints]
|
||||
|
||||
|
||||
-- pulled the following from the haskell wiki
|
||||
-- it seems to produce an infinite loop sometimes
|
||||
|
||||
Reference in New Issue
Block a user