Merge branch 'master' into testing
This commit is contained in:
Ross
+11
-31
@@ -245,7 +245,6 @@ startCr = defaultCreature
|
|||||||
, _crDir = 0
|
, _crDir = 0
|
||||||
, _crID = 0
|
, _crID = 0
|
||||||
, _crPict = basicCrPict $ greyN 0.8
|
, _crPict = basicCrPict $ greyN 0.8
|
||||||
|
|
||||||
, _crUpdate = stateUpdate yourControl
|
, _crUpdate = stateUpdate yourControl
|
||||||
, _crRad = 10
|
, _crRad = 10
|
||||||
, _crMass = 10
|
, _crMass = 10
|
||||||
@@ -253,7 +252,17 @@ startCr = defaultCreature
|
|||||||
, _crMaxHP = 1500
|
, _crMaxHP = 1500
|
||||||
, _crInv = IM.fromList (zip [0..20]
|
, _crInv = IM.fromList (zip [0..20]
|
||||||
(
|
(
|
||||||
[pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade
|
[pistol
|
||||||
|
,blinkGun
|
||||||
|
,flameGrenade
|
||||||
|
,teslaGrenade
|
||||||
|
,autoGun
|
||||||
|
,launcher
|
||||||
|
,flameLauncher
|
||||||
|
,poisonLauncher
|
||||||
|
,teslaLauncher
|
||||||
|
,lasGun
|
||||||
|
,grenade
|
||||||
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
|
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
|
||||||
,longGun
|
,longGun
|
||||||
,hvAutoGun
|
,hvAutoGun
|
||||||
@@ -263,37 +272,8 @@ startCr = defaultCreature
|
|||||||
,medkit 50
|
,medkit 50
|
||||||
,bezierGun
|
,bezierGun
|
||||||
,poisonSprayer
|
,poisonSprayer
|
||||||
,blinkGun
|
|
||||||
]
|
]
|
||||||
-- [pistol,autoGun,launcher,lasGun,grenade
|
|
||||||
-- ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
|
|
||||||
-- ,longGun
|
|
||||||
-- ,hvAutoGun
|
|
||||||
-- ,teslaGun
|
|
||||||
-- ,latchkey 0
|
|
||||||
-- ,miniGun
|
|
||||||
-- ,medkit 50
|
|
||||||
-- ,bezierGun
|
|
||||||
-- ,poisonSprayer
|
|
||||||
-- ,blinkGun
|
|
||||||
-- ,frontArmour
|
|
||||||
-- ]
|
|
||||||
++ repeat NoItem))
|
++ 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]
|
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -614,19 +614,10 @@ data PlacementSpot = PS
|
|||||||
, _psRot :: Float
|
, _psRot :: Float
|
||||||
, _psType :: PSType
|
, _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 SubNode a = SN a | InLink | OutLink
|
||||||
|
|
||||||
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
|
|
||||||
|
|
||||||
makeLenses ''RoomLink
|
|
||||||
makeLenses ''World
|
makeLenses ''World
|
||||||
makeLenses ''Cloud
|
makeLenses ''Cloud
|
||||||
makeLenses ''Creature
|
makeLenses ''Creature
|
||||||
@@ -653,7 +644,6 @@ makeLenses ''PressPlate
|
|||||||
makeLenses ''Button
|
makeLenses ''Button
|
||||||
makeLenses ''PSType
|
makeLenses ''PSType
|
||||||
makeLenses ''PlacementSpot
|
makeLenses ''PlacementSpot
|
||||||
makeLenses ''Room
|
|
||||||
|
|
||||||
numColor :: Int -> Color
|
numColor :: Int -> Color
|
||||||
numColor 0 = (1,0,0,1)
|
numColor 0 = (1,0,0,1)
|
||||||
|
|||||||
@@ -11,6 +11,7 @@ import Dodge.LightSources
|
|||||||
import Dodge.LevelGen
|
import Dodge.LevelGen
|
||||||
import Dodge.Creature.Inanimate
|
import Dodge.Creature.Inanimate
|
||||||
import qualified Data.IntMap.Strict as IM
|
import qualified Data.IntMap.Strict as IM
|
||||||
|
import Dodge.Event.Test
|
||||||
|
|
||||||
import SDL
|
import SDL
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
@@ -55,9 +56,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
|
|||||||
Just (Right but) -> _btEvent but but w
|
Just (Right but) -> _btEvent but but w
|
||||||
Nothing -> w
|
Nothing -> w
|
||||||
|
|
||||||
testEvent :: World -> World
|
|
||||||
testEvent w = w
|
|
||||||
|
|
||||||
pauseGame :: World -> World
|
pauseGame :: World -> World
|
||||||
pauseGame w = w {_menuState = PauseMenu}
|
pauseGame w = w {_menuState = PauseMenu}
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
@@ -8,6 +8,7 @@ import Picture
|
|||||||
|
|
||||||
import Dodge.Data
|
import Dodge.Data
|
||||||
import Dodge.Rooms
|
import Dodge.Rooms
|
||||||
|
import Dodge.Room.Data
|
||||||
import Dodge.Base
|
import Dodge.Base
|
||||||
import Dodge.Layout
|
import Dodge.Layout
|
||||||
import Dodge.Creature
|
import Dodge.Creature
|
||||||
|
|||||||
@@ -890,26 +890,6 @@ aGasCloud cid w
|
|||||||
vel = (_crPos cr -.- _crOldPos cr) +.+ 10 *.* unitVectorAtAngle dir
|
vel = (_crPos cr -.- _crOldPos cr) +.+ 10 *.* unitVectorAtAngle dir
|
||||||
insertCloud = makeGasCloud pos vel -- . makeFlame pos2 vel (Just cid)
|
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 :: Float -> Int -> World -> World
|
||||||
aFlame a cid w
|
aFlame a cid w
|
||||||
@@ -929,119 +909,7 @@ aFlame a cid w
|
|||||||
resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire)
|
resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire)
|
||||||
(shoot $ aFlame angle)
|
(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
|
flamerAngle = 0.3
|
||||||
@@ -1663,123 +1531,6 @@ remoteBombUnarmedPic :: Picture
|
|||||||
remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5
|
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,autogunSpread :: Float
|
||||||
spreadGunSpread = 0.5
|
spreadGunSpread = 0.5
|
||||||
|
|||||||
+14
-1
@@ -10,6 +10,8 @@ import Dodge.Base
|
|||||||
import Dodge.RandomHelp
|
import Dodge.RandomHelp
|
||||||
import Dodge.Path
|
import Dodge.Path
|
||||||
import Dodge.Layout.Tree
|
import Dodge.Layout.Tree
|
||||||
|
import Dodge.Room.Data
|
||||||
|
import Dodge.Default
|
||||||
|
|
||||||
import Geometry
|
import Geometry
|
||||||
|
|
||||||
@@ -59,8 +61,19 @@ generateFromTree t w = zoning $ placeSpots plmnts
|
|||||||
makePath :: Tree Room -> [(Point2,Point2)]
|
makePath :: Tree Room -> [(Point2,Point2)]
|
||||||
makePath = concat . map _rmPath . flatten
|
makePath = concat . map _rmPath . flatten
|
||||||
|
|
||||||
|
-- consider nubbing walls after dividing them
|
||||||
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
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 :: Wall -> [Wall]
|
||||||
divideWall wl
|
divideWall wl
|
||||||
|
|||||||
@@ -4,8 +4,6 @@ module Dodge.LevelGen
|
|||||||
( module Dodge.LevelGen
|
( module Dodge.LevelGen
|
||||||
, cutWalls
|
, cutWalls
|
||||||
, createInnerWalls
|
, createInnerWalls
|
||||||
, checkWalls
|
|
||||||
, nubWalls
|
|
||||||
, pairsToGraph
|
, pairsToGraph
|
||||||
, makeButton
|
, makeButton
|
||||||
, makeSwitch
|
, makeSwitch
|
||||||
@@ -14,6 +12,7 @@ module Dodge.LevelGen
|
|||||||
|
|
||||||
import Dodge.Data
|
import Dodge.Data
|
||||||
import Dodge.Base
|
import Dodge.Base
|
||||||
|
import Dodge.Room.Data
|
||||||
|
|
||||||
import Dodge.LevelGen.Block
|
import Dodge.LevelGen.Block
|
||||||
import Dodge.LevelGen.LineBlock
|
import Dodge.LevelGen.LineBlock
|
||||||
|
|||||||
+111
-104
@@ -16,84 +16,114 @@ import qualified Data.IntMap as IM
|
|||||||
|
|
||||||
import qualified Data.Set as S
|
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
|
-- 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
|
-- 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' :: [Point2] -> [WallP] -> [WallP]
|
||||||
cutWalls qs walls = createPolyWalls rs
|
cutWalls' qs walls =
|
||||||
. IM.filter (not.wallIsZeroLength)
|
nub
|
||||||
. removeWallsInPolygon ps
|
. filter (not.wallIsZeroLength)
|
||||||
$ fuseWallsWith zs cwals
|
. fuseWallsWith zs
|
||||||
where (zs,cwals) = cutWallsWithPoints ps walls
|
. createPolyWalls rs
|
||||||
|
-- . removeWallsInPolygon ps
|
||||||
|
-- . filter (not.wallIsZeroLength)
|
||||||
|
-- . fuseWallsWith zs
|
||||||
|
$ removeWallsInPolygon ps
|
||||||
|
cwals
|
||||||
|
where
|
||||||
|
(zs,cwals) = cutWallsWithPoints ps walls
|
||||||
ps = orderPolygon qs
|
ps = orderPolygon qs
|
||||||
rs = orderPolygon $ nub $ zs ++ qs
|
rs = orderPolygon $ nub $ zs ++ qs
|
||||||
-- the overall procedure is:
|
-- the overall procedure is:
|
||||||
-- split walls that intersect with the polygon into two
|
-- split walls that intersect with the polygon into two
|
||||||
-- (possibly three if the wall extends across the polygon)
|
-- (possibly three if the wall extends across the polygon)
|
||||||
-- fuse wall endpoints that end up close to each or to polygon intersection points
|
-- remove any created walls that are inside the polygon
|
||||||
-- remove the created walls that are inside the polygon
|
|
||||||
-- also remove any walls that ended up zero length
|
|
||||||
-- draw the required new walls along the polygon boundary
|
-- draw the required new walls along the polygon boundary
|
||||||
|
-- fuse wall endpoints that end up close to each or to polygon intersection points
|
||||||
createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
-- remove any walls that ended up zero length after fusing
|
||||||
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q]))
|
-- remove any duplicate walls
|
||||||
|
|
||||||
-- 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
|
|
||||||
|
|
||||||
-- given a polygon expressed as a list of points and a collection of 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
|
-- returns: fst: points of the polygon's intersection with walls
|
||||||
-- snd: the collection of walls after cutting by the polygon
|
-- 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]))
|
cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
|
||||||
where f (p1,p2) (as,ws') = ( as ++ cutWallsPoints p1 p2 ws'
|
where
|
||||||
, addCutWalls p1 p2 ws'
|
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
|
-- given a list of points and a point, returns a point in the list if any is close
|
||||||
-- enough to the point
|
-- 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
|
-- given a list of points and wall, moves the wall to be on the points if it is
|
||||||
-- close to any of the points
|
-- close to any of the points
|
||||||
-- if either wall point is not moved, this point gets added to the list
|
-- if either wall point is not moved, this point gets added to the list
|
||||||
fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
|
fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
|
||||||
fuseWall (ps, w) = ( rs
|
fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
|
||||||
, w Control.Lens.& wlLine .~ [w0,w1]
|
where x' = fusePoint ps x
|
||||||
)
|
y' = fusePoint (x':ps) y
|
||||||
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)
|
|
||||||
|
|
||||||
-- given list of points and collection of walls, fuses the wall ends if
|
-- given list of points and collection of walls, fuses the wall ends if
|
||||||
-- they are close to the list of points or each other
|
-- they are close to the list of points or each other
|
||||||
fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
|
||||||
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
|
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
|
||||||
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
|
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
|
wallIsZeroLength (x,y) = x == y
|
||||||
where l = _wlLine w
|
|
||||||
|
|
||||||
wallLengthGT x w = dist (l !! 0) (l !! 1) > x
|
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
|
||||||
where l = _wlLine w
|
removeWallsInPolygon ps walls = filter (not . cond) walls
|
||||||
|
where cond wall = pointInsidePolygon (fst wall) ps
|
||||||
removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
&& pointInsidePolygon (snd wall) ps
|
||||||
removeWallsInPolygon ps walls = IM.filter (not . cond) walls
|
|
||||||
where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
|
|
||||||
&& pointInsidePolygon (_wlLine wall !! 1) ps
|
|
||||||
|
|
||||||
pointInsidePolygon :: Point2 -> [Point2] -> Bool
|
pointInsidePolygon :: Point2 -> [Point2] -> Bool
|
||||||
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|
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])
|
where pairs = zip (x:xs) (xs ++ [x])
|
||||||
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
|
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
|
||||||
-.- p
|
-.- 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
|
-- idea: create inner walls to draw and to cast shadows
|
||||||
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
|
||||||
createInnerWalls wls = IM.map (createInnerWall wls) wls
|
createInnerWalls wls = IM.map (createInnerWall wls) wls
|
||||||
|
|
||||||
createInnerWall :: IM.IntMap Wall -> Wall -> Wall
|
createInnerWall :: IM.IntMap Wall -> Wall -> Wall
|
||||||
--createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)]
|
|
||||||
createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
|
createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
|
||||||
where wl0 = _wlLine wl !! 0
|
where wl0 = _wlLine wl !! 0
|
||||||
wl1 = _wlLine wl !! 1
|
wl1 = _wlLine wl !! 1
|
||||||
@@ -183,14 +188,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
|
|||||||
findWallLeft :: Wall -> IM.IntMap Wall -> Wall
|
findWallLeft :: Wall -> IM.IntMap Wall -> Wall
|
||||||
findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
|
findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
|
||||||
[w] -> w
|
[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)
|
++ " wlLines: "++ show (map _wlLine wls)
|
||||||
|
|
||||||
findWallRight :: Wall -> IM.IntMap Wall -> Wall
|
findWallRight :: Wall -> IM.IntMap Wall -> Wall
|
||||||
findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
|
findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
|
||||||
[w] -> w
|
[w] -> w
|
||||||
wls -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls)
|
wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
|
||||||
++ " wlLines: "++ show (map _wlLine wls)
|
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 :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||||
findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
|
findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
|
||||||
|
|||||||
@@ -102,6 +102,7 @@ mapWall w wl =
|
|||||||
else Nothing
|
else Nothing
|
||||||
where
|
where
|
||||||
t = normalizeV (y -.- x)
|
t = normalizeV (y -.- x)
|
||||||
|
-- n2 = 2 *.* vNormal t
|
||||||
n2 = 20 *.* vNormal t
|
n2 = 20 *.* vNormal t
|
||||||
(x:y:_) = (_wlLine wl)
|
(x:y:_) = (_wlLine wl)
|
||||||
c = _wlColor wl
|
c = _wlColor wl
|
||||||
|
|||||||
@@ -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
|
||||||
+13
-8
@@ -1,4 +1,8 @@
|
|||||||
module Dodge.Rooms where
|
module Dodge.Rooms
|
||||||
|
-- ( module Dodge.Rooms
|
||||||
|
-- , module Dodge.Rooms.Data
|
||||||
|
-- )
|
||||||
|
where
|
||||||
-- imports {{{
|
-- imports {{{
|
||||||
import Dodge.Data
|
import Dodge.Data
|
||||||
import Dodge.Item.Weapon
|
import Dodge.Item.Weapon
|
||||||
@@ -12,6 +16,7 @@ import Dodge.Path
|
|||||||
import Dodge.Layout
|
import Dodge.Layout
|
||||||
import Dodge.LightSources
|
import Dodge.LightSources
|
||||||
import Dodge.SoundLogic
|
import Dodge.SoundLogic
|
||||||
|
import Dodge.Room.Data
|
||||||
|
|
||||||
import Dodge.Room.Placement
|
import Dodge.Room.Placement
|
||||||
|
|
||||||
@@ -90,8 +95,8 @@ corridor = Room
|
|||||||
, _rmBound = rectNSWE 50 30 0 40
|
, _rmBound = rectNSWE 50 30 0 40
|
||||||
}
|
}
|
||||||
where lnks = [((20,70) ,0)
|
where lnks = [((20,70) ,0)
|
||||||
,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6)
|
,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6)
|
||||||
,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6)
|
,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6)
|
||||||
,((20,10) ,pi)
|
,((20,10) ,pi)
|
||||||
]
|
]
|
||||||
corridorN :: Room
|
corridorN :: Room
|
||||||
@@ -256,7 +261,7 @@ glassSwitchBack = do
|
|||||||
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
|
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
|
||||||
,blockLine ( 0, 3*hf) (wllen,3*hf)
|
,blockLine ( 0, 3*hf) (wllen,3*hf)
|
||||||
,blockLine (wth-wllen, 4*hf) ( wth,4*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
|
return $ set rmPS plmnts $ roomRect' wth hgt 2 6
|
||||||
|
|
||||||
@@ -494,14 +499,13 @@ weaponLongCorridor = do
|
|||||||
i2 <- state $ randomR (2,5)
|
i2 <- state $ randomR (2,5)
|
||||||
let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
|
let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
|
||||||
let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN)
|
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
|
where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC
|
||||||
,PS (-10,40) (-pi/2) $ randC
|
,PS (-10,40) (-pi/2) $ randC
|
||||||
]
|
]
|
||||||
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon
|
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon
|
||||||
,PS (20,60) 0 $ putLamp
|
,PS (20,60) 0 $ putLamp
|
||||||
]
|
]
|
||||||
addLS = id -- set rmPS [PS (0,60) 0 $ putLamp]
|
|
||||||
|
|
||||||
critInDeadEnd :: Room
|
critInDeadEnd :: Room
|
||||||
critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
|
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 :: RandomGen g => State g (Tree (Either Room Room))
|
||||||
roomCCrits = do
|
roomCCrits = do
|
||||||
ps <- sequence $ replicate 25 $ randInCirc 9
|
ps <- sequence $ replicate 20 $ randInCirc 9
|
||||||
let plmnts = map (\p -> PS p 0 $ randC)
|
let plmnts = map (\p -> PS p 0 $ randC)
|
||||||
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
|
$ 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 :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room))
|
||||||
branchRectWith t = do
|
branchRectWith t = do
|
||||||
|
|||||||
+4
-189
@@ -6,6 +6,8 @@ module Dodge.WorldEvent
|
|||||||
, module Dodge.WorldEvent.HelperParticle
|
, module Dodge.WorldEvent.HelperParticle
|
||||||
, module Dodge.WorldEvent.Cloud
|
, module Dodge.WorldEvent.Cloud
|
||||||
, module Dodge.WorldEvent.HitEffect
|
, module Dodge.WorldEvent.HitEffect
|
||||||
|
, module Dodge.WorldEvent.Explosion
|
||||||
|
, module Dodge.WorldEvent.SpawnParticle
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@@ -15,6 +17,8 @@ import Dodge.WorldEvent.ThingsHit
|
|||||||
import Dodge.WorldEvent.HelperParticle
|
import Dodge.WorldEvent.HelperParticle
|
||||||
import Dodge.WorldEvent.Cloud
|
import Dodge.WorldEvent.Cloud
|
||||||
import Dodge.WorldEvent.HitEffect
|
import Dodge.WorldEvent.HitEffect
|
||||||
|
import Dodge.WorldEvent.Explosion
|
||||||
|
import Dodge.WorldEvent.SpawnParticle
|
||||||
import Dodge.LightSources
|
import Dodge.LightSources
|
||||||
|
|
||||||
import Dodge.Data
|
import Dodge.Data
|
||||||
@@ -34,25 +38,6 @@ import Data.Function
|
|||||||
import Data.List
|
import Data.List
|
||||||
import qualified Data.IntMap.Strict as IM
|
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 :: Point2 -> Float -> Int -> World -> World
|
||||||
shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
|
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)
|
(_blIDs wall)
|
||||||
_ -> w
|
_ -> 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 :: Point2 -> Float -> Int -> Float -> Float -> World -> World
|
||||||
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
||||||
@@ -167,33 +83,6 @@ moveInverseShockWave t p r push pushexp w pt
|
|||||||
cr
|
cr
|
||||||
| otherwise = 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 :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
||||||
createBarrelSpark time colid pos dir maycid w = over worldEvents
|
createBarrelSpark time colid pos dir maycid w = over worldEvents
|
||||||
@@ -217,82 +106,8 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents
|
|||||||
where sp = head (_btTrail' bt)
|
where sp = head (_btTrail' bt)
|
||||||
ep = sp +.+ _btVel' 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 :: Int -> Point2 -> Point2 -> World -> World
|
||||||
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
|
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
|
||||||
|
|||||||
@@ -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
|
||||||
@@ -56,3 +56,11 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
|
|||||||
trl = _btTrail' pt
|
trl = _btTrail' pt
|
||||||
wth = _btWidth' pt
|
wth = _btWidth' pt
|
||||||
newP = head trl +.+ _btVel' 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
|
||||||
|
|||||||
@@ -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)
|
||||||
Reference in New Issue
Block a user