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

Merge branch 'master' into testing

Browse Source
This commit is contained in:
Ross
2021-03-29 10:59:10 +01:00
parent 8de5cfcb18 9608655947
commit c722b6f38f
16 changed files with 781 additions and 612 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature.hs
+22 -42
View File
@@ -245,55 +245,35 @@ startCr = defaultCreature
, _crDir = 0
, _crID = 0
, _crPict = basicCrPict $ greyN 0.8
, _crUpdate = stateUpdate yourControl
, _crRad = 10
, _crMass = 10
, _crHP = 10000
, _crMaxHP = 1500
, _crInv = IM.fromList (zip [0..20]
(
[pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
,longGun
,hvAutoGun
,teslaGun
,latchkey 0
,miniGun
,medkit 50
,bezierGun
,poisonSprayer
,blinkGun
]
-- [pistol,autoGun,launcher,lasGun,grenade
-- ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
-- ,longGun
-- ,hvAutoGun
-- ,teslaGun
-- ,latchkey 0
-- ,miniGun
-- ,medkit 50
-- ,bezierGun
-- ,poisonSprayer
-- ,blinkGun
-- ,frontArmour
-- ]
(
[pistol
,blinkGun
,flameGrenade
,teslaGrenade
,autoGun
,launcher
,flameLauncher
,poisonLauncher
,teslaLauncher
,lasGun
,grenade
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
,longGun
,hvAutoGun
,teslaGun
,latchkey 0
,miniGun
,medkit 50
,bezierGun
,poisonSprayer
]
++ repeat NoItem))
-- startInv
-- ([pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
-- ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
-- ,longGun
-- ,hvAutoGun
-- ,teslaGun
-- ,latchkey 0
-- ,miniGun
-- ,medkit 50
-- ,bezierGun
-- ,poisonSprayer
-- ,blinkGun
-- ]
-- ++ repeat NoItem))
-- -- startInv
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
}
src/Dodge/Data.hs
-10
View File
@@ -614,19 +614,10 @@ data PlacementSpot = PS
, _psRot :: Float
, _psType :: PSType
}
data Room = Room
{ _rmPolys :: [Poly]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: Poly
}
data SubNode a = SN a | InLink | OutLink
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
makeLenses ''RoomLink
makeLenses ''World
makeLenses ''Cloud
makeLenses ''Creature
@@ -653,7 +644,6 @@ makeLenses ''PressPlate
makeLenses ''Button
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Room
numColor :: Int -> Color
numColor 0 = (1,0,0,1)
src/Dodge/Event/Keyboard.hs
+1 -3
View File
@@ -11,6 +11,7 @@ import Dodge.LightSources
import Dodge.LevelGen
import Dodge.Creature.Inanimate
import qualified Data.IntMap.Strict as IM
import Dodge.Event.Test
import SDL
import Data.Maybe
@@ -55,9 +56,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
Just (Right but) -> _btEvent but but w
Nothing -> w
testEvent :: World -> World
testEvent w = w
pauseGame :: World -> World
pauseGame w = w {_menuState = PauseMenu}
src/Dodge/Event/Test.hs
+98
View File
@@ -0,0 +1,98 @@
module Dodge.Event.Test
( testEvent
)
where
import Dodge.Data
import Dodge.Base
import Dodge.Default
import Picture
import Geometry
import qualified Data.IntMap as IM
import Control.Lens
testEvent :: World -> World
testEvent w = over walls (IM.union testWalls) w
where
k = newKey $ _walls w
setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..]
testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
polyPairs = makeLoopPairs
$ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
-- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
polyWalls = map (wallWithCol red . flat2) polyPairs
errorWallPair =
(9,[(-340.0,60.0),(-320.0,60.0)])
-- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
errorWall = wallWithCol green $ snd errorWallPair
errorWallPairs =
[(1,[(-400.0,59.999996),(-340.0,60.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
-- ]
errorWalls = map (wallWithCol blue . snd) errorWallPairs
startWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-320.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-400.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)])
-- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
-- ]
startWalls = map (wallWithCol yellow . snd) startWallPairs
endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
endWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-340.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-340.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
,(9,[(-340.0,60.0),(-320.0,60.0)])
,(11,[(-340.0,100.0),(-400.0,100.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
-- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)])
-- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)])
-- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)])
-- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
-- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)])
-- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)])
-- ]
--flat2 :: (a,a) -> [a]
--flat2 (x,y) = [x,y]
wallWithCol :: Color -> [Point2] -> Wall
wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True
src/Dodge/Floor.hs
+2 -1
View File
@@ -8,6 +8,7 @@ import Picture
import Dodge.Data
import Dodge.Rooms
import Dodge.Room.Data
import Dodge.Base
import Dodge.Layout
import Dodge.Creature
@@ -43,7 +44,7 @@ lev1 = do
++ [roomCCrits]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++[roomMiniIntro]
++[roomMiniIntro]
++ [longRoom >>= randomiseLinks]
++ [return $ connectRoom corridor
,return $ connectRoom door]
src/Dodge/Item/Weapon.hs
-249
View File
@@ -890,26 +890,6 @@ aGasCloud cid w
vel = (_crPos cr -.- _crOldPos cr) +.+ 10 *.* unitVectorAtAngle dir
insertCloud = makeGasCloud pos vel -- . makeFlame pos2 vel (Just cid)
makeGasCloud :: Point2 -> Point2 -> World -> World
makeGasCloud pos vel w = over clouds (IM.insert i theCloud)
$ set randGen g w
where i = newKey $ _clouds w
theCloud = Cloud { _clID = i
, _clPos = pos
, _clVel = vel
, _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col)
$ circleSolid 20
, _clRad = 20
, _clTimer = 400
, _clEffect = cloudPoisonDamage
}
(col, g) = runState (takeOne [green,yellow]) $ _randGen w
cloudPoisonDamage :: Cloud -> World -> World
cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
where damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w
f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c
doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
aFlame :: Float -> Int -> World -> World
aFlame a cid w
@@ -929,119 +909,7 @@ aFlame a cid w
resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire)
(shoot $ aFlame angle)
-- The following should be improved.... I've made a first pass
makePoisonExplosionAt :: Point2 -> World -> World
makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vels
where
vels = evalState (sequence ( replicate 25 (randInCirc 2) )) (_randGen w)
-- just change the number after replicate to get more or less clouds
-- suggested change: use random positions, offset from p, rather than velocities
-- so, p +.+ randomOffset
-- currently the clouds push away from each other rather hard if they are close
makeTeslaExplosionAt :: Point2 -> World -> World
makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions -- a bit shorter
where
-- rad or 360? Radians (hopefully) everywhere
xs = randomRs (0, 2*pi) $ _randGen w
p = newProjectileKey w
pks = [p..]
listOfFunctions = map
(\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i))))
[1 .. 29]
-- slightly more work done on this one, want the flames to last for different
-- times
-- the new flames are directly added to the list of particles
makeFlameExplosionAt :: Point2 -> World -> World
makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++ ) w
where
newFlames = zipWith makeFlameWithVelAndTime velocities timers
makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing
velocities = evalState (sequence ( replicate 15 (randInCirc 1) )) (_randGen w)
timers = randomRs (80,100) $ _randGen w
-- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the
-- particle passes through for the first frame of its existence
-- take out the flame particle from makeFlame
aFlameParticle :: Int -> Point2 -> Point2 -> Maybe Int -> Particle'
aFlameParticle t pos vel maycid = Pt'
{ _ptDraw = drawFlame vel
, _ptUpdate' = moveFlame vel
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = 4
, _btTimer' = t
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : )
drawFlame :: Point2 -> Particle' -> Picture
drawFlame rotd pt = thePic
where ep = _btPos' pt
thePic = pictures
[ glow
, aPic prot2 0.2998 (scaleChange + 1,2) red
, aPic prot 0.2996 (scaleChange + 0.5,1.5) orange
, aPic prot3 0.2994 (scaleChange,1) white
]
aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic offset depth (scalex,scaley) col
= setLayer 1
. setDepth depth
. uncurry translate (offset ep)
. rotate (pi * 0.5 + argV rotd)
. scale scalex scaley
. color col
$ circleSolid 5
glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep
$ 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)
| otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of
((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt')
(thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p)
_ -> (soundAndGlare damcrs , mvPt)
where time = _btTimer' pt
soundAndGlare = soundFrom Flame fireSound 2 500
. over worldEvents ((.) $ flameGlareAt ep)
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep
, _btPassThrough' = Nothing
,_btVel' = 0.98 *.* vel}
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep
, _btPassThrough' = Nothing
,_btVel' = 0.7 *.* vel}
damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs
$ IM.elems $ _creatures w
closeCrs cr = dist ep (_crPos cr)
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi))
hiteff = _btHitEffect' pt pt
rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p
, _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p
}
pOut p = p +.+ safeNormalizeV (sp -.- p)
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
vel )
+.+
(0.2 *.* vel)
smokeGen = makeFlamerSmokeAt ep
flamerAngle = 0.3
@@ -1663,123 +1531,6 @@ remoteBombUnarmedPic :: Picture
remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5
makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile
makeTeslaArcAt i pos dir = Projectile
{ _ptPos = pos
, _ptStartPos = pos
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ line [(0,0),(0,0)]
, _ptID = i
, _ptUpdate = moveTeslaArc pos dir i
}
moveTeslaArc :: Point2 -> Float -> Int -> World -> World
moveTeslaArc p d i w =
set (projectiles . ix i . ptPict) pic
$ set (projectiles . ix i . ptUpdate)
(ptTimer 2 i)
$ set randGen g
$ createSpark 8 nc q2 (argV sv + d1) Nothing
$ foldr damCrs w hitCrs
where pic = setLayer 1 $ pictures
[ onLayer PtLayer $ color (f2 nc) $ line ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
]
ps' = lightningMids d pers ps
ps = take 15 $ p : map f (crsLightChain p d 0 w)
f (E3x1 cr) = _crPos cr
f (E3x2 p1) = p1
f (E3x3 p1) = p1
pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
(nc,g) = randomR (0::Int,11) $ _randGen w
f1 (E3x1 cr) = Just $ _crID cr
f1 _ = Nothing
hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5)
f2 0 = cyan
f2 1 = azure
f2 _ = white
sID = newProjectileKey w
q1 = last $ init ps'
q2 = last ps'
hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
(d1,_) = randomR (-0.7,0.7) $ _randGen w
sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall
lightningMid :: Float -> Point2 -> Point2 -> Point2
lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3
where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2
lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
lightningMids d1 (p:pers) (p1:p3:ps)
= let p2 = p +.+ lightningMid d1 p1 p3
d2 = argV $ p3 -.- p2
in p1 : p2 : lightningMids d2 pers (p3:ps)
lightningMids _ _ ps = ps
crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2]
crsLightChain' p d w
= case crOrWall p d w of
E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w
E3x2 p1 -> [E3x2 p1]
E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w)
-- where (dChange, g) = (0, _randGen w)
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
crsLightChain p d wlAttract w
= case crOrWallSensitive p d wlAttract w of
E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p))
(min 1 (wlAttract + 0.3)) w
E3x2 p1 -> [E3x2 p1]
E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w)
-- where (dChange, g) = (0, _randGen w)
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2
crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ listToMaybe $ sortBy (compare `on` g)
$ catMaybes [cr,wlp]
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe
$ sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+) dir
)
(fmap (*wlAttract) [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8])
--[-pi/4,-pi/8,0,pi/8,pi/4]
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w
-- BUG: can hit crs through walls
crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ listToMaybe $ sortBy (compare `on` g)
$ catMaybes [cr,wlp]
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe
$ sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+) dir
)
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
--[-pi/4,-pi/8,0,pi/8,pi/4]
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w
spreadGunSpread,autogunSpread :: Float
spreadGunSpread = 0.5
src/Dodge/Layout.hs
+14 -1
View File
@@ -10,6 +10,8 @@ import Dodge.Base
import Dodge.RandomHelp
import Dodge.Path
import Dodge.Layout.Tree
import Dodge.Room.Data
import Dodge.Default
import Geometry
@@ -59,8 +61,19 @@ generateFromTree t w = zoning $ placeSpots plmnts
makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten
-- consider nubbing walls after dividing them
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
wallsFromTree t =
createInnerWalls
. divideWalls
. assignKeys
. foldr cutWalls [] -- $ map (map (g . roundPoint2))
. map (map roundPoint2)
$ (concatMap _rmPolys $ flatten t)
where
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
g (x,y) = (x-3855,y - 2613)
divideWall :: Wall -> [Wall]
divideWall wl
src/Dodge/LevelGen.hs
+1 -2
View File
@@ -4,8 +4,6 @@ module Dodge.LevelGen
( module Dodge.LevelGen
, cutWalls
, createInnerWalls
, checkWalls
, nubWalls
, pairsToGraph
, makeButton
, makeSwitch
@@ -14,6 +12,7 @@ module Dodge.LevelGen
import Dodge.Data
import Dodge.Base
import Dodge.Room.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.LineBlock
src/Dodge/LevelGen/StaticWalls.hs
+114 -107
View File
@@ -16,84 +16,114 @@ import qualified Data.IntMap as IM
import qualified Data.Set as S
type WallP = (Point2,Point2)
-- the following checks one of the corners of cut walls at each step
cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
[] -> newWalls
errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps
++ "\nRight corner errors:\n"
++ unlines (map show errs)
++ "\nStart walls:\n"
++ unlines (map show wls)
++ "\nEnd walls:\n"
++ unlines (map show newWalls)
++ "\nLeft corner errors:\n"
++ unlines (map show errsL)
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP])
checkWallRight (x,y) wls = case filter (\(a,b) -> a == y ) wls of
[w] -> Nothing
wls -> Just ((x,y), wls)
checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP])
checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of
[w] -> Nothing
wls -> Just ((x,y),wls)
-- given a polygon of points and collection of walls, cuts out the polygon
-- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls qs walls = createPolyWalls rs
. IM.filter (not.wallIsZeroLength)
. removeWallsInPolygon ps
$ fuseWallsWith zs cwals
where (zs,cwals) = cutWallsWithPoints ps walls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
cutWalls' :: [Point2] -> [WallP] -> [WallP]
cutWalls' qs walls =
nub
. filter (not.wallIsZeroLength)
. fuseWallsWith zs
. createPolyWalls rs
-- . removeWallsInPolygon ps
-- . filter (not.wallIsZeroLength)
-- . fuseWallsWith zs
$ removeWallsInPolygon ps
cwals
where
(zs,cwals) = cutWallsWithPoints ps walls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
-- the overall procedure is:
-- split walls that intersect with the polygon into two
-- (possibly three if the wall extends across the polygon)
-- fuse wall endpoints that end up close to each or to polygon intersection points
-- remove the created walls that are inside the polygon
-- also remove any walls that ended up zero length
-- remove any created walls that are inside the polygon
-- draw the required new walls along the polygon boundary
createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
-- creates a wall if there is not already a wall on the clockwise normal to this wall
-- such that this existing wall faces towards the new wall
createPolyWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
createPolyWall (p1,p2) walls =
case maybeW of Just w -> if isLHS (_wlLine w !! 0) (_wlLine w !! 1) p3
then walls
else IM.insert k newWall walls
Nothing -> IM.insert k newWall walls
where p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeW = wallOnLine p3 p4 walls
k = newKey walls
newWall = defaultWall {_wlLine = [p1,p2], _wlID = k}
-- given a segment and a wall, adds a cut point to the wall if it intersects the
-- segment
cutWall :: Point2 -> Point2 -> Wall -> Wall
cutWall p1 p2 wall = case maybeCP of
Nothing -> wall
Just cp -> wall {_wlLine = [cp,w0,w1]}
where wl = _wlLine wall
w0 = wl !! 0
w1 = wl !! 1
maybeCP = intersectExtendedSegSeg p1 p2 w0 w1
-- intersects two segments, each extended by one unit in both directions
intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
where p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1)
a1' = a1 +.+ normalizeV (a1 -.- a2)
a2' = a2 +.+ normalizeV (a2 -.- a1)
-- given a segment and a collection of walls, cuts each wall where it intersects
-- with the segment, adds the two cut walls
addCutWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
addCutWalls p1 p2 ws = foldr addTwoWallsIfCut ws $ IM.map (cutWall p1 p2) ws
where addTwoWallsIfCut w ws
= case _wlLine w of
(cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
,_wlID = newKey ws})
$ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
(x:y:[]) -> ws
-- lists the points of intersection between a segment and collection of walls
cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
$ map _wlLine $ IM.elems ws
-- fuse wall endpoints that end up close to each or to polygon intersection points
-- remove any walls that ended up zero length after fusing
-- remove any duplicate walls
-- given a polygon expressed as a list of points and a collection of walls,
-- returns: fst: points of the polygon's intersection with walls
-- snd: the collection of walls after cutting by the polygon
cutWallsWithPoints :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
where f (p1,p2) (as,ws') = ( as ++ cutWallsPoints p1 p2 ws'
, addCutWalls p1 p2 ws'
)
where
f (p1,p2) (as,ws') =
( as ++ cutWallsPoints p1 p2 ws'
, concatMap (cutWall p1 p2) ws'
)
-- lists the points of intersection between a segment and collection of walls
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
-- given a segment and a wall, adds a cut point to the wall if it intersects the
-- segment
cutWall :: Point2 -> Point2 -> WallP -> [WallP]
cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
Nothing -> [(x,y)]
Just cp -> [(x,cp),(cp,y)]
createPolyWalls :: [Point2] -> [WallP] -> [WallP]
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
-- adds a wall if there is not already a wall on the clockwise normal to this wall
-- such that this existing wall faces towards the new wall
createPolyWall :: WallP -> [WallP] -> [WallP]
createPolyWall (p1,p2) walls =
case maybeW of Just (x,y) -> if isLHS x y p3
then walls
else (p1,p2) : walls
Nothing -> ((p1,p2) : walls)
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeW = listToMaybe
. fst
. unzip
. sortBy (compare `on` (dist p3 . snd))
. catMaybes
$ zipWith f walls maybes
f a (Just b) = Just (a,b)
f _ Nothing = Nothing
maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
-- intersects two segments, each extended by one unit in both directions
intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
where
p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1)
a1' = a1 +.+ normalizeV (a1 -.- a2)
a2' = a2 +.+ normalizeV (a2 -.- a1)
-- given a list of points and a point, returns a point in the list if any is close
-- enough to the point
@@ -112,32 +142,24 @@ fusePoint ps p = fromMaybe p $ findClosePoint ps p
-- given a list of points and wall, moves the wall to be on the points if it is
-- close to any of the points
-- if either wall point is not moved, this point gets added to the list
fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
fuseWall (ps, w) = ( rs
, w Control.Lens.& wlLine .~ [w0,w1]
)
where qs = catMaybes [pointIfNotClose ps (_wlLine w !! 0)] ++ ps
rs = catMaybes [pointIfNotClose qs (_wlLine w !! 1)] ++ qs
w0 = fusePoint ps (_wlLine w !! 0)
w1 = fusePoint qs (_wlLine w !! 1)
fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
where x' = fusePoint ps x
y' = fusePoint (x':ps) y
-- given list of points and collection of walls, fuses the wall ends if
-- they are close to the list of points or each other
fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
in (qs, IM.insert (_wlID w') w' ws)
in (qs, w' : ws)
wallIsZeroLength w = l !! 0 == l !! 1
where l = _wlLine w
wallIsZeroLength (x,y) = x == y
wallLengthGT x w = dist (l !! 0) (l !! 1) > x
where l = _wlLine w
removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
removeWallsInPolygon ps walls = IM.filter (not . cond) walls
where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
&& pointInsidePolygon (_wlLine wall !! 1) ps
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps walls = filter (not . cond) walls
where cond wall = pointInsidePolygon (fst wall) ps
&& pointInsidePolygon (snd wall) ps
pointInsidePolygon :: Point2 -> [Point2] -> Bool
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
@@ -145,30 +167,13 @@ pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV
where pairs = zip (x:xs) (xs ++ [x])
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
-.- p
------------------------------------------------------
finalFuse :: IM.IntMap Wall -> IM.IntMap Wall
finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith []
------------------------------------------------------
nubWalls :: IM.IntMap Wall -> IM.IntMap Wall
nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls
checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall
checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of
Just wl -> error $ show $ _wlLine wl
_ -> wls
checkWalls wls | (nub $ map _wlLine $ IM.elems wls)
== (map _wlLine $ IM.elems wls) = wls
| otherwise = error "hasdup"
------------------------------------------------------------------------------------
-- idea: create inner walls to draw and to cast shadows
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
createInnerWalls wls = IM.map (createInnerWall wls) wls
createInnerWall :: IM.IntMap Wall -> Wall -> Wall
--createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)]
createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
where wl0 = _wlLine wl !! 0
wl1 = _wlLine wl !! 1
@@ -183,14 +188,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
findWallLeft :: Wall -> IM.IntMap Wall -> Wall
findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
[w] -> w
wls -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
++ " wlLines: "++ show (map _wlLine wls)
findWallRight :: Wall -> IM.IntMap Wall -> Wall
findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
[w] -> w
wls -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
++ " wlLines: "++ show (map _wlLine wls)
wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
src/Dodge/Rendering/HUD.hs
+1
View File
@@ -102,6 +102,7 @@ mapWall w wl =
else Nothing
where
t = normalizeV (y -.- x)
-- n2 = 2 *.* vNormal t
n2 = 20 *.* vNormal t
(x:y:_) = (_wlLine wl)
c = _wlColor wl
src/Dodge/Room/Data.hs
+18
View File
@@ -0,0 +1,18 @@
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Room.Data
where
import Dodge.Data
import Control.Lens
data Room = Room
{ _rmPolys :: [Poly]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: Poly
}
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
makeLenses ''Room
makeLenses ''RoomLink
src/Dodge/Rooms.hs
+13 -8
View File
@@ -1,4 +1,8 @@
module Dodge.Rooms where
module Dodge.Rooms
-- ( module Dodge.Rooms
-- , module Dodge.Rooms.Data
-- )
where
-- imports {{{
import Dodge.Data
import Dodge.Item.Weapon
@@ -12,6 +16,7 @@ import Dodge.Path
import Dodge.Layout
import Dodge.LightSources
import Dodge.SoundLogic
import Dodge.Room.Data
import Dodge.Room.Placement
@@ -90,8 +95,8 @@ corridor = Room
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6)
,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6)
,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6)
,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6)
,((20,10) ,pi)
]
corridorN :: Room
@@ -256,7 +261,7 @@ glassSwitchBack = do
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
,blockLine ( 0, 3*hf) (wllen,3*hf)
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, PS (wth/2,hgt/2) 0 $ PutCrit lamp
, PS (wth/2,hgt/2) 0 $ putLamp
]
return $ set rmPS plmnts $ roomRect' wth hgt 2 6
@@ -494,14 +499,13 @@ weaponLongCorridor = do
i2 <- state $ randomR (2,5)
let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN)
return $ Node (Left $ addLS root) [branch1,branch2]
return $ Node (Left root) [branch1,branch2]
where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC
,PS (-10,40) (-pi/2) $ randC
]
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon
,PS (20,60) 0 $ putLamp
]
addLS = id -- set rmPS [PS (0,60) 0 $ putLamp]
critInDeadEnd :: Room
critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
@@ -531,10 +535,11 @@ weaponRoom = do
roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- sequence $ replicate 25 $ randInCirc 9
ps <- sequence $ replicate 20 $ randInCirc 9
let plmnts = map (\p -> PS p 0 $ randC)
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
lamps = [PS (50,100) 0 putLamp , PS (175,100) 0 putLamp]
return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room))
branchRectWith t = do
src/Dodge/WorldEvent.hs
+4 -189
View File
@@ -6,6 +6,8 @@ module Dodge.WorldEvent
, module Dodge.WorldEvent.HelperParticle
, module Dodge.WorldEvent.Cloud
, module Dodge.WorldEvent.HitEffect
, module Dodge.WorldEvent.Explosion
, module Dodge.WorldEvent.SpawnParticle
)
where
@@ -15,6 +17,8 @@ import Dodge.WorldEvent.ThingsHit
import Dodge.WorldEvent.HelperParticle
import Dodge.WorldEvent.Cloud
import Dodge.WorldEvent.HitEffect
import Dodge.WorldEvent.Explosion
import Dodge.WorldEvent.SpawnParticle
import Dodge.LightSources
import Dodge.Data
@@ -34,25 +38,6 @@ import Data.Function
import Data.List
import qualified Data.IntMap.Strict as IM
makeExplosionAt :: Point2 -> World -> World
makeExplosionAt p w = soundOnce grenadeBang
. addFlames
. explosionFlashAt p
$ makeShockwaveAt p 50 10 1 white
w
where 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'
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 Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
addFlames w = foldr ($) w newFs
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
$ collidePointWalls p q $ wallsNearPoint q w
shockWaveDamage :: Point2 -> Float -> Int -> World -> World
shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
@@ -67,75 +52,6 @@ shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over crea
(_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'
{ _ptDraw = const 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 ptDraw (const 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 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
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)
@@ -167,33 +83,6 @@ moveInverseShockWave t p r push pushexp w pt
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')
. sparkFlashAt pos')
) w
where spark = Bul' { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact 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
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
@@ -217,83 +106,9 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents
where sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
noEff _ _ _ = id
makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World
makeFlameletTimed pos vel maycid size time w
= set randGen g $ over particles' ((:) theFlamelet) w
where theFlamelet =
Pt' { _ptDraw = drawFlamelet rot
, _ptUpdate' = moveFlamelet
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
(rot ,g) = randomR (0,3) $ _randGen w
drawFlamelet :: Float -> Particle' -> Picture
drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
where
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 0.336 $ uncurry translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth 0.334 $ uncurry translate ep
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
$ scale s1 s1
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
pi2 = setDepth 0.332 $ 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)
pic = setDepth 0.33 $ 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)]
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]
moveFlamelet :: World -> Particle' -> (World, Maybe Particle')
moveFlamelet w pt
| _btTimer' pt <= 0 = ( w, Nothing)
| otherwise = (damcrs, mvPt)
where
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
mvPt = Just $ pt & btTimer' -~ 1
& btPos' .~ ep
& 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)
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
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)
src/Dodge/WorldEvent/Explosion.hs
+146
View File
@@ -0,0 +1,146 @@
module Dodge.WorldEvent.Explosion
where
import Dodge.Data
import Dodge.Base
import Dodge.WorldEvent.SpawnParticle
import Dodge.WorldEvent.Flash
import Dodge.RandomHelp
import Dodge.SoundLogic
import Geometry
import Picture
import Control.Monad.State
import Data.List
import Data.Maybe
import System.Random
import qualified Data.IntMap.Strict as IM
import Control.Lens
-- The following should be improved.... I've made a first pass
makePoisonExplosionAt :: Point2 -> World -> World
makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vels
where
vels = evalState (sequence ( replicate 25 (randInCirc 2) )) (_randGen w)
-- just change the number after replicate to get more or less clouds
-- suggested change: use random positions, offset from p, rather than velocities
-- so, p +.+ randomOffset
-- currently the clouds push away from each other rather hard if they are close
makeTeslaExplosionAt :: Point2 -> World -> World
makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions -- a bit shorter
where
-- rad or 360? Radians (hopefully) everywhere
xs = randomRs (0, 2*pi) $ _randGen w
p = newProjectileKey w
pks = [p..]
listOfFunctions = map
(\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i))))
[1 .. 29]
-- slightly more work done on this one, want the flames to last for different
-- times
-- the new flames are directly added to the list of particles
makeFlameExplosionAt :: Point2 -> World -> World
makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++ ) w
where
newFlames = zipWith makeFlameWithVelAndTime velocities timers
makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing
velocities = evalState (sequence ( replicate 15 (randInCirc 1) )) (_randGen w)
timers = randomRs (80,100) $ _randGen w
-- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the
-- particle passes through for the first frame of its existence
makeExplosionAt :: Point2 -> World -> World
makeExplosionAt p w = soundOnce grenadeBang
. addFlames
. explosionFlashAt p
$ makeShockwaveAt p 50 10 1 white
w
where
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'
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 Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
addFlames w = foldr ($) w newFs
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
$ collidePointWalls p q $ wallsNearPoint q 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'
{ _ptDraw = const 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 ptDraw (const 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 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
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
src/Dodge/WorldEvent/HitEffect.hs
+8
View File
@@ -56,3 +56,11 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
trl = _btTrail' pt
wth = _btWidth' pt
newP = head trl +.+ _btVel' pt
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
noEff _ _ _ = id
src/Dodge/WorldEvent/SpawnParticle.hs
+339
View File
@@ -0,0 +1,339 @@
module Dodge.WorldEvent.SpawnParticle
where
import Dodge.Data
import Dodge.Base
import Dodge.WorldEvent.HitEffect
import Dodge.WorldEvent.ThingsHit
import Dodge.WorldEvent.Cloud
import Dodge.WorldEvent.Flash
import Dodge.WorldEvent.HelperParticle
import Dodge.WorldEvent.Bullet
import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.Debug
import Picture
import Geometry
import Control.Lens
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Monad.State
import Data.Function (on)
import Data.List
import Data.Maybe
-- take out the flame particle from makeFlame
aFlameParticle :: Int -> Point2 -> Point2 -> Maybe Int -> Particle'
aFlameParticle t pos vel maycid = Pt'
{ _ptDraw = drawFlame vel
, _ptUpdate' = moveFlame vel
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = 4
, _btTimer' = t
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : )
drawFlame :: Point2 -> Particle' -> Picture
drawFlame rotd pt = thePic
where ep = _btPos' pt
thePic = pictures
[ glow
, aPic prot2 0.2998 (scaleChange + 1,2) red
, aPic prot 0.2996 (scaleChange + 0.5,1.5) orange
, aPic prot3 0.2994 (scaleChange,1) white
]
aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic offset depth (scalex,scaley) col
= setLayer 1
. setDepth depth
. uncurry translate (offset ep)
. rotate (pi * 0.5 + argV rotd)
. scale scalex scaley
. color col
$ circleSolid 5
glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep
$ 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)
| otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of
((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt')
(thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p)
_ -> (soundAndGlare damcrs , mvPt)
where time = _btTimer' pt
soundAndGlare = soundFrom Flame fireSound 2 500
. over worldEvents ((.) $ flameGlareAt ep)
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep
, _btPassThrough' = Nothing
,_btVel' = 0.98 *.* vel}
mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep
, _btPassThrough' = Nothing
,_btVel' = 0.7 *.* vel}
damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs
$ IM.elems $ _creatures w
closeCrs cr = dist ep (_crPos cr)
< _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
+ 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi))
hiteff = _btHitEffect' pt pt
rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p
, _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p
}
pOut p = p +.+ safeNormalizeV (sp -.- p)
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
vel )
+.+
(0.2 *.* vel)
smokeGen = makeFlamerSmokeAt ep
makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World
makeFlameletTimed pos vel maycid size time w
= set randGen g $ over particles' ((:) theFlamelet) w
where theFlamelet =
Pt' { _ptDraw = drawFlamelet rot
, _ptUpdate' = moveFlamelet
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
(rot ,g) = randomR (0,3) $ _randGen w
drawFlamelet :: Float -> Particle' -> Picture
drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
where
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
time = _btTimer' pt
glow = setDepth 0.336 $ uncurry translate ep
$ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
piu = setDepth 0.334 $ uncurry translate ep
$ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time))
$ scale s1 s1
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
pi2 = setDepth 0.332 $ 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)
pic = setDepth 0.33 $ 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)]
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]
moveFlamelet :: World -> Particle' -> (World, Maybe Particle')
moveFlamelet w pt
| _btTimer' pt <= 0 = ( w, Nothing)
| otherwise = (damcrs, mvPt)
where
sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
mvPt = Just $ pt & btTimer' -~ 1
& btPos' .~ ep
& 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)
makeGasCloud :: Point2 -> Point2 -> World -> World
makeGasCloud pos vel w = over clouds (IM.insert i theCloud)
$ set randGen g w
where i = newKey $ _clouds w
theCloud = Cloud { _clID = i
, _clPos = pos
, _clVel = vel
, _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col)
$ circleSolid 20
, _clRad = 20
, _clTimer = 400
, _clEffect = cloudPoisonDamage
}
(col, g) = runState (takeOne [green,yellow]) $ _randGen w
cloudPoisonDamage :: Cloud -> World -> World
cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs
where damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w
f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c
doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile
makeTeslaArcAt i pos dir = Projectile
{ _ptPos = pos
, _ptStartPos = pos
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ line [(0,0),(0,0)]
, _ptID = i
, _ptUpdate = moveTeslaArc pos dir i
}
moveTeslaArc :: Point2 -> Float -> Int -> World -> World
moveTeslaArc p d i w =
set (projectiles . ix i . ptPict) pic
$ set (projectiles . ix i . ptUpdate)
(ptTimer 2 i)
$ set randGen g
$ createSpark 8 nc q2 (argV sv + d1) Nothing
$ foldr damCrs w hitCrs
where pic = setLayer 1 $ pictures
[ onLayer PtLayer $ color (f2 nc) $ line ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
]
ps' = lightningMids d pers ps
ps = take 15 $ p : map f (crsLightChain p d 0 w)
f (E3x1 cr) = _crPos cr
f (E3x2 p1) = p1
f (E3x3 p1) = p1
pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
(nc,g) = randomR (0::Int,11) $ _randGen w
f1 (E3x1 cr) = Just $ _crID cr
f1 _ = Nothing
hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5)
f2 0 = cyan
f2 1 = azure
f2 _ = white
sID = newProjectileKey w
q1 = last $ init ps'
q2 = last ps'
hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
(d1,_) = randomR (-0.7,0.7) $ _randGen w
sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall
lightningMid :: Float -> Point2 -> Point2 -> Point2
lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3
where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2
lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
lightningMids d1 (p:pers) (p1:p3:ps)
= let p2 = p +.+ lightningMid d1 p1 p3
d2 = argV $ p3 -.- p2
in p1 : p2 : lightningMids d2 pers (p3:ps)
lightningMids _ _ ps = ps
crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2]
crsLightChain' p d w
= case crOrWall p d w of
E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w
E3x2 p1 -> [E3x2 p1]
E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w)
-- where (dChange, g) = (0, _randGen w)
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
crsLightChain p d wlAttract w
= case crOrWallSensitive p d wlAttract w of
E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p))
(min 1 (wlAttract + 0.3)) w
E3x2 p1 -> [E3x2 p1]
E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w)
-- where (dChange, g) = (0, _randGen w)
where (dChange, g) = randomR (-0.05,0.05) $ _randGen w
crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2
crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ listToMaybe $ sortBy (compare `on` g)
$ catMaybes [cr,wlp]
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe
$ sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+) dir
)
(fmap (*wlAttract) [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8])
--[-pi/4,-pi/8,0,pi/8,pi/4]
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w
-- BUG: can hit crs through walls
crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
$ listToMaybe $ sortBy (compare `on` g)
$ catMaybes [cr,wlp]
where cr = fmap E3x1 $ nearestCrInFront p dir 100 w
wlp = fmap E3x2 $ listToMaybe
$ sortBy (compare `on` dist p)
$ mapMaybe
( fmap fst
. (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w)
. (+.+) p
. (\d -> rotateV d (100,0))
. (+) dir
)
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
--[-pi/4,-pi/8,0,pi/8,pi/4]
g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first
--g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first
g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w
-- 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')
. sparkFlashAt pos')
) w
where spark = Bul' { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact 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
drawBul :: Particle' -> Picture
drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)