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

Hlinting

Browse Source
This commit is contained in:
jgk
2021-04-27 11:45:43 +02:00
parent f8351fb150
commit 64b5b9e2a5
34 changed files with 974 additions and 761 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+18 -14
View File
@@ -57,7 +57,7 @@ data World = World
, _clouds :: IM.IntMap Cloud
, _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
, _projectiles :: IM.IntMap Projectile
, _particles' :: ![Particle']
, _particles :: ![Particle]
, _walls :: !(IM.IntMap Wall)
, _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall)))
, _forceFields :: IM.IntMap ForceField
@@ -374,14 +374,18 @@ data ItemIdentity
| PoisonSprayer
deriving (Eq,Show,Ord,Enum)
data Particle'
= Particle'
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
{-
Objects without ids.
Update themselves, perhaps with side effects.
-}
data Particle
= Particle
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
}
| Bul'
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
, _btVel' :: Point2
, _btColor' :: Color
, _btTrail' :: [Point2]
@@ -391,8 +395,8 @@ data Particle'
, _btHitEffect' :: HitEffect
}
| Pt'
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
, _btVel' :: Point2
, _btColor' :: Color
, _btPos' :: Point2
@@ -402,8 +406,8 @@ data Particle'
, _btHitEffect' :: HitEffect
}
| Shockwave'
{ _ptDraw :: Particle' -> Picture
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
{ _ptDraw :: Particle -> Picture
, _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
, _btColor' :: Color
, _btPos' :: Point2
, _btRad' :: Float
@@ -413,8 +417,8 @@ data Particle'
, _btTimer' :: Int
}
type HitEffect = Particle' -> [(Point2, (Either3 Creature Wall ForceField))] -> World
-> (World,Maybe Particle')
type HitEffect = Particle -> [(Point2, (Either3 Creature Wall ForceField))] -> World
-> (World,Maybe Particle)
data Projectile
= Projectile
@@ -500,7 +504,7 @@ makeLenses ''ItAttachment
makeLenses ''ItZoom
makeLenses ''FloorItem
makeLenses ''Projectile
makeLenses ''Particle'
makeLenses ''Particle
makeLenses ''Wall
makeLenses ''ForceField
makeLenses ''FFState
src/Dodge/Default.hs
+1 -1
View File
@@ -210,7 +210,7 @@ defaultWorld = World
, _cloudsZone = IM.empty
, _itemPositions = IM.empty
, _projectiles = IM.empty
, _particles' = []
, _particles = []
, _walls = IM.empty
, _wallsZone = IM.empty
, _forceFields = IM.empty
src/Dodge/Item/Weapon.hs
+139 -128
View File
@@ -1,3 +1,7 @@
{-
Definitions of weapons.
In progress: move out effects into other modules.
-}
{-# LANGUAGE BangPatterns #-}
module Dodge.Item.Weapon
( module Dodge.Item.Weapon
@@ -12,14 +16,11 @@ import Dodge.WorldEvent
import Dodge.Debug
import Dodge.WallCreatureCollisions
import Dodge.Default
import Dodge.Item.Draw
import Dodge.Item.Weapon.Bullet
import Dodge.Item.Weapon.InventoryDisplay
import Dodge.Item.Weapon.TriggerType
import Dodge.Item.Weapon.Recock
import Geometry
import Picture
@@ -33,15 +34,11 @@ import Control.Applicative
import Control.Monad.State
import Control.Monad
import qualified SDL as SDL
--import qualified Graphics.UI.SDL.Mixer as Mix
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Foreign.ForeignPtr
import Control.Concurrent
-- }}}
pistol,lasGun,tractorGun,launcher,autoGun
,teslaGun
@@ -371,7 +368,7 @@ maybeSetTarget f cid w = case join $ w ^? creatures . ix cid . crInv . ix itRef
itRef = _crInvSel cr
shootBezier :: Point2 -> Int -> World -> World
shootBezier targetp cid w = over particles' (theBullet :) w
shootBezier targetp cid w = over particles (theBullet :) w
where
theBullet = aCurveBulAt
(Just cid)
@@ -678,24 +675,26 @@ aTeslaArc' cid w =
teslaGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
$ over projectiles (IM.insert i (makeTeslaArcAt i pos dir))
$ set randGen g w
where cr = (_creatures w IM.! cid)
i = newProjectileKey w
pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
+.+ sideOffset *.* vNormal (unitVectorAtAngle dir)
(sideOffset,g) = randomR (-5,5) $ _randGen w
dir = _crDir cr
where
cr = (_creatures w IM.! cid)
i = newProjectileKey w
pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
+.+ sideOffset *.* vNormal (unitVectorAtAngle dir)
(sideOffset,g) = randomR (-5,5) $ _randGen w
dir = _crDir cr
aLaser :: Int -> World -> World
aLaser cid w = over particles' ( (:) (makeLaserAt phaseV pos dir (Just cid)))
aLaser cid w = over particles ((makeLaserAt phaseV pos dir (Just cid)) : )
$ soundFrom LasSound 24 1 0
$ laserGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
w
where cr = (_creatures w IM.! cid)
i = newProjectileKey w
pos = _crPos cr +.+ ((_crRad cr +3) *.* unitVectorAtAngle dir)
dir = _crDir cr
phaseV = fromMaybe 1 $ cr ^? crInv . ix j . itAttachment . _Just . itPhaseV
j = _crInvSel cr
where
cr = (_creatures w IM.! cid)
i = newProjectileKey w
pos = _crPos cr +.+ ((_crRad cr +3) *.* unitVectorAtAngle dir)
dir = _crDir cr
phaseV = fromMaybe 1 $ cr ^? crInv . ix j . itAttachment . _Just . itPhaseV
j = _crInvSel cr
aTractorBeam :: Int -> Int -> World -> World
aTractorBeam col cid w
@@ -1043,13 +1042,20 @@ rateIncAB startRate fastRate shooteff1 shooteff2 cid w
reloadCondition = _wpLoadedAmmo item == 0
makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle'
makeLaserAt phaseV pos dir mcid = Particle'
makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle
makeLaserAt phaseV pos dir mcid = Particle
{ _ptDraw = const blank
, _ptUpdate' = moveLaser phaseV pos dir mcid
}
moveLaser :: Float -> Point2 -> Float -> Maybe Int -> World -> Particle' -> (World, Maybe Particle')
moveLaser
:: Float -- ^ Phase velocity, controls deflection in windows
-> Point2
-> Float
-> Maybe Int
-> World
-> Particle
-> (World, Maybe Particle)
moveLaser phaseV pos dir mcid w pt
= ( set randGen g
-- $ over worldEvents ((.) flares)
@@ -1058,61 +1064,62 @@ moveLaser phaseV pos dir mcid w pt
,_ptUpdate' = ptTimer' 0
}
)
where xp = pos +.+ 800 *.* unitVectorAtAngle dir
(a,g) = randomR (-0.7,0.7) $ _randGen w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(xp -.- pos)
)
(colID,_) = randomR (0,11) $ _randGen w
-- flares w = foldr (\p w' -> flareAt' yellow 0.01 0.02 p w') w flarePs
-- flarePs = zipWith (\x y -> x +.+ 5 *.* normalizeV (y -.- x)) ps $ tail ps
-- flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (pos -.- p))
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
f seenWs x y = case listToMaybe $ filter (h' seenWs)
$ thingsHitExceptCrLongLine Nothing x y w of
Just (p,E3x2 wl)
| _wlIsSeeThrough wl -> f' p $ f (wl:seenWs)
p
(h x y wl p)
| otherwise -> (Just (p,E3x2 wl), [p])
Just (p,obj) -> (Just (p,obj), [p])
Nothing -> (Nothing, [y])
f' p (x,ps') = (x,p:ps')
h x y wl p | isEntering = p +.+ rotateV angleRef normalDist
| otherwise = p +.+ rotateV angleRef' normalDist'
where wlNormal = vNormal $ (_wlLine wl !! 1) -.- (_wlLine wl !! 0)
normalDist = magV (p -.- y) *.* normalizeV wlNormal
angleInc = piRange $ argV wlNormal - argV (x -.- y)
angleRef | reflectExternal = angleInc
| otherwise = asin $ sin angleInc / phaseV
piRange a | a > pi = a - 2 * pi
| a > 0 - pi = a
| otherwise = a + 2 * pi
isEntering = isLeftOf (x -.- y) ((_wlLine wl !! 1) -.- (_wlLine wl !! 0))
wlNormal' = vNormal $ (_wlLine wl !! 0) -.- (_wlLine wl !! 1)
normalDist' = magV (p -.- y) *.* normalizeV wlNormal'
angleInc' = piRange $ argV wlNormal' - argV (x -.- y)
angleRef' | reflectInternal = angleInc'
| otherwise = asin $ phaseV * sin angleInc'
reflectInternal = 1 < abs (phaseV * sin angleInc')
reflectExternal = 1 < abs (sin angleInc / phaseV)
h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws
h' _ _ = True
(thHit, ps) = f [] pos xp
hitEffect
= case thHit of
Just (p,E3x1 cr)
-> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 19 pos p xp)
-- . over worldEvents ((.) $ flareAt yellow (flarePos p))
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
(reflectDir wl) Nothing
_ -> id
pic = pictures [ fadeLine pos (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
]
where
xp = pos +.+ 800 *.* unitVectorAtAngle dir
(a,g) = randomR (-0.7,0.7) $ _randGen w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(xp -.- pos)
)
(colID,_) = randomR (0,11) $ _randGen w
-- flares w = foldr (\p w' -> flareAt' yellow 0.01 0.02 p w') w flarePs
-- flarePs = zipWith (\x y -> x +.+ 5 *.* normalizeV (y -.- x)) ps $ tail ps
-- flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (pos -.- p))
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
f seenWs x y = case listToMaybe $ filter (h' seenWs)
$ thingsHitExceptCrLongLine Nothing x y w of
Just (p,E3x2 wl)
| _wlIsSeeThrough wl -> f' p $ f (wl:seenWs)
p
(h x y wl p)
| otherwise -> (Just (p,E3x2 wl), [p])
Just (p,obj) -> (Just (p,obj), [p])
Nothing -> (Nothing, [y])
f' p (x,ps') = (x,p:ps')
h x y wl p | isEntering = p +.+ rotateV angleRef normalDist
| otherwise = p +.+ rotateV angleRef' normalDist'
where wlNormal = vNormal $ (_wlLine wl !! 1) -.- (_wlLine wl !! 0)
normalDist = magV (p -.- y) *.* normalizeV wlNormal
angleInc = piRange $ argV wlNormal - argV (x -.- y)
angleRef | reflectExternal = angleInc
| otherwise = asin $ sin angleInc / phaseV
piRange a | a > pi = a - 2 * pi
| a > 0 - pi = a
| otherwise = a + 2 * pi
isEntering = isLeftOf (x -.- y) ((_wlLine wl !! 1) -.- (_wlLine wl !! 0))
wlNormal' = vNormal $ (_wlLine wl !! 0) -.- (_wlLine wl !! 1)
normalDist' = magV (p -.- y) *.* normalizeV wlNormal'
angleInc' = piRange $ argV wlNormal' - argV (x -.- y)
angleRef' | reflectInternal = angleInc'
| otherwise = asin $ phaseV * sin angleInc'
reflectInternal = 1 < abs (phaseV * sin angleInc')
reflectExternal = 1 < abs (sin angleInc / phaseV)
h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws
h' _ _ = True
(thHit, ps) = f [] pos xp
hitEffect
= case thHit of
Just (p,E3x1 cr)
-> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 19 pos p xp)
-- . over worldEvents ((.) $ flareAt yellow (flarePos p))
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
(reflectDir wl) Nothing
_ -> id
pic = pictures [ fadeLine pos (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
]
fadeLine :: Point2 -> Point2 -> Float -> Float -> Color -> Picture
fadeLine sp ep alph width col = setLayer 1 $
@@ -1693,18 +1700,21 @@ sonar = defaultGun
}
aSonarPulse :: Int -> World -> World
aSonarPulse cid w = over particles' ((:) $ sonarPulseAt (_crPos (_creatures w IM.! cid))) w
aSonarPulse cid w = over particles ((:) $ sonarPulseAt (_crPos (_creatures w IM.! cid))) w
aRadarPulse :: Int -> World -> World
aRadarPulse cid w = over particles' ((:) $ radarPulseAt (_crPos (_creatures w IM.! cid))) w
aRadarPulse cid w = over particles ((:) $ radarPulseAt (_crPos (_creatures w IM.! cid))) w
blipAt :: Point2 -> Color -> Int -> Particle'
blipAt p col i = Particle'
{-
Radar blip at a point.
-}
blipAt :: Point2 -> Color -> Int -> Particle
blipAt p col i = Particle
{_ptDraw = const blank
,_ptUpdate' = mvBlip p col i i
}
mvBlip :: Point2 -> Color -> Int -> Int -> World -> Particle' -> (World, Maybe Particle')
mvBlip :: Point2 -> Color -> Int -> Int -> World -> Particle -> (World, Maybe Particle)
mvBlip p col maxt 0 w pt = (w, Nothing)
mvBlip p col maxt t w pt
= (w, Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1)
@@ -1715,67 +1725,68 @@ mvBlip p col maxt t w pt
$ circleSolid 2)
)
sonarPulseAt :: Point2 -> Particle'
sonarPulseAt p = Particle'
sonarPulseAt :: Point2 -> Particle
sonarPulseAt p = Particle
{ _ptDraw = const blank
, _ptUpdate' = mvSonar 100 p
}
mvSonar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle')
mvSonar :: Int -> Point2 -> World -> Particle -> (World, Maybe Particle)
mvSonar 0 _ w _ = (w, Nothing)
mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic
,_ptUpdate' = mvSonar (x-1) p
}
)
where pic = setDepth (-0.5) . setLayer 1 $ pictures
-- $ sweepPics ++
crBlips -- ++ wallBlips
crBlips = mapMaybe crBlip $ IM.elems $ _creatures w
crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100)
= Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100))
$ uncurry translate cpos $ circleSolid crad
| otherwise = Nothing
where crad = _crRad cr
cpos = _crPos cr
r = fromIntegral (500 - x*5)
sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5
-- ,colHelper 0.3 $ uncurry translate p $ thickCircle (r-5) 5
-- ,colHelper 0.1 $ uncurry translate p $ thickCircle (r-10) 5
]
globalAlpha | x > 10 = 1
| otherwise = fromIntegral x / 10
colHelper y = color (withAlpha (y * globalAlpha) green)
-- wallBlips
where
pic = setDepth (-0.5) . setLayer 1 $ pictures
-- $ sweepPics ++
crBlips -- ++ wallBlips
crBlips = mapMaybe crBlip $ IM.elems $ _creatures w
crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100)
= Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100))
$ uncurry translate cpos $ circleSolid crad
| otherwise = Nothing
where crad = _crRad cr
cpos = _crPos cr
r = fromIntegral (500 - x*5)
sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5
-- ,colHelper 0.3 $ uncurry translate p $ thickCircle (r-5) 5
-- ,colHelper 0.1 $ uncurry translate p $ thickCircle (r-10) 5
]
globalAlpha | x > 10 = 1
| otherwise = fromIntegral x / 10
colHelper y = color (withAlpha (y * globalAlpha) green)
-- wallBlips
radarPulseAt :: Point2 -> Particle'
radarPulseAt p = Particle'
radarPulseAt :: Point2 -> Particle
radarPulseAt p = Particle
{ _ptDraw = const blank
, _ptUpdate' = mvRadar 50 p
}
mvRadar :: Int -> Point2 -> World -> Particle' -> (World, Maybe Particle')
mvRadar :: Int -> Point2 -> World -> Particle -> (World, Maybe Particle)
mvRadar 0 _ w _ = (w, Nothing)
mvRadar x p w pt = (putBlips w, Just $ pt {_ptDraw = const pic
,_ptUpdate' = mvRadar (x-1) p
}
)
where pic = onLayerL [levLayer ShadowLayer, 1] $ pictures
$ sweepPics
putBlips = over worldEvents ((.) $ over particles' ((++) blips))
blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50)
$ circPoints
circPoints = mapMaybe (\wl -> collidePointCircCorrect (_wlLine wl !! 0) (_wlLine wl !! 1) r p)
$ (map (over wlLine reverse) $ IM.elems $ wallsAlongCirc p r w)
++ (IM.elems $ wallsAlongCirc p r w)
r = fromIntegral (800 - x*16)
sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
--,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
--,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5
]
globalAlpha | x > 10 = 1
| otherwise = fromIntegral x / 10
colHelper y = color (withAlpha (y * globalAlpha) red)
where
pic = onLayerL [levLayer ShadowLayer, 1] $ pictures $ sweepPics
putBlips = over worldEvents ((.) $ over particles ((++) blips))
blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50)
$ circPoints
circPoints = mapMaybe (\wl -> collidePointCircCorrect (_wlLine wl !! 0) (_wlLine wl !! 1) r p)
$ (map (over wlLine reverse) $ IM.elems $ wallsAlongCirc p r w)
++ (IM.elems $ wallsAlongCirc p r w)
r = fromIntegral (800 - x*16)
sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
--,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
--,colHelper 0.03 $ uncurry translate p $ thickCircle (r-10) 5
]
globalAlpha | x > 10 = 1
| otherwise = fromIntegral x / 10
colHelper y = color (withAlpha (y * globalAlpha) red)
autoSonar = defaultEquipment
{ _itIdentity = Generic
@@ -1831,7 +1842,7 @@ itemLaserScopeEffect
}
where f cr invid w
| invid == _crInvSel cr
= w & particles' %~ (:) (makeLaserScope sp ep d reloadFrac)
= w & particles %~ (:) (makeLaserScope sp ep d reloadFrac)
& creatures . ix (_crID cr) . crInv . ix invid . itHammer %~ moveHammerUp
& laserScopeTargetGlow col glowPoint
-- this flare MAY be buggy... something to do with the creature glare
@@ -1856,8 +1867,8 @@ itemLaserScopeEffect
moveHammerUp !HammerDown = HammerReleased
moveHammerUp !_ = HammerUp
makeLaserScope :: Point2 -> Point2 -> Float -> Float -> Particle'
makeLaserScope p ep d relFrac = Particle'
makeLaserScope :: Point2 -> Point2 -> Float -> Float -> Particle
makeLaserScope p ep d relFrac = Particle
{_ptDraw = const $ onLayer PtLayer $ pictures
[color (withAlpha 0.5 $ mixColors relFrac (1-relFrac) red green)
$ lineOfThickness 0.5 [p,ep]
src/Dodge/Item/Weapon/Bullet.hs
+116 -95
View File
@@ -20,12 +20,11 @@ import qualified Data.IntMap.Strict as IM
import Picture
-- bullet effects
bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World
-- | bullet effects
bulHitCr' :: Particle -> Point2 -> Creature -> World -> World
bulHitCr' bt p cr w
| crIsArmouredFrom p cr
= createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing
. addDamageArmoured $ w
= createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing . addDamageArmoured $ w
| otherwise
= addDamage . hitSound . flashEff $ w
where
@@ -42,7 +41,10 @@ bulHitCr' bt p cr w
(colID,_) = randomR (0,11) $ _randGen w
p1 = p +.+ 2 *.* safeNormalizeV (p -.- _crPos cr)
bulBounceArmCr' :: Particle' -> Point2 -> Creature -> World -> World
{-
Bounce off armoured creatures, otherwise do damage.
-}
bulBounceArmCr' :: Particle -> Point2 -> Creature -> World -> World
bulBounceArmCr' bt p cr w
| crIsArmouredFrom p cr
= addBouncer . addDamageArmoured $ w
@@ -61,12 +63,15 @@ bulBounceArmCr' bt p cr w
newDir = safeNormalizeV (p -.- _crPos cr)
pOut = p +.+ 2 *.* newDir
reflectVel = magV bulVel *.* newDir
addBouncer = worldEvents %~ ((over particles' (bouncer :) ) . )
addBouncer = worldEvents %~ ((over particles (bouncer :) ) . )
bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel
(_btHitEffect' bt) (_btWidth' bt)
) {_btTimer' = _btTimer' bt - 1}
bulPenCr' :: Particle' -> Point2 -> Creature -> World -> World
{-
Bullet pass through creatures.
-}
bulPenCr' :: Particle -> Point2 -> Creature -> World -> World
bulPenCr' bt p cr w
= over (creatures . ix cid . crState . crDamage)
(\dams -> [Piercing 50 sp p ep
@@ -82,14 +87,16 @@ bulPenCr' bt p cr w
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
addPiercer = (.) $ over particles' ((:) piercer)
addPiercer = (.) $ over particles (piercer :)
piercer = (aGenBulAt' (Just cid) (_btColor' bt) p (_btVel' bt)
(_btHitEffect' bt) (_btWidth' bt)
) {_btTimer' = _btTimer' bt - 1}
hvBulHitCr' :: Particle' -> Point2 -> Creature -> World -> World
hvBulHitCr' bt p cr w
= over (creatures . ix cid . crState . crDamage)
{- Heavy bullet effects when hitting creature:
piercing, blunt, twisting and pushback damage all applied.
-}
hvBulHitCr' :: Particle -> Point2 -> Creature -> World -> World
hvBulHitCr' bt p cr w = over (creatures . ix cid . crState . crDamage)
(\dams -> [Piercing 200 sp p ep
,Blunt 100 sp p ep
,TorqueDam 1 d1
@@ -98,12 +105,13 @@ hvBulHitCr' bt p cr w
)
$ soundMultiFrom [CrHitSound 0] 15 10 0
w
where (d1,g) = randomR (-0.7,0.7) $ _randGen w
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
where
(d1,g) = randomR (-0.7,0.7) $ _randGen w
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
bulIncCr' :: Particle' -> Point2 -> Creature -> World -> World
bulIncCr' :: Particle -> Point2 -> Creature -> World -> World
bulIncCr' bt p cr w
= over (creatures . ix cid . crState . crDamage)
(\dams -> [Piercing 60 sp p ep
@@ -112,13 +120,17 @@ bulIncCr' bt p cr w
$ soundMultiFrom [CrHitSound 0] 15 10 0
$ incFlamelets
w
where cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
v = evalState (randInCirc 1) $ _randGen w
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p v Nothing 3 20)
where
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
v = evalState (randInCirc 1) $ _randGen w
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p v Nothing 3 20)
bulConCr' :: Particle' -> Point2 -> Creature -> World -> World
{-
Creates a shockwave when hitting a creature.
-}
bulConCr' :: Particle -> Point2 -> Creature -> World -> World
bulConCr' bt p cr w
= over (creatures . ix cid . crState . crDamage)
(\dams -> [Piercing 60 sp p ep
@@ -127,31 +139,39 @@ bulConCr' bt p cr w
$ soundMultiFrom [CrHitSound 0] 15 10 0
$ mkwave
w
where cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
where
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
{-
Hitting wall effects: create a spark, damage blocks.
-}
bulHitWall' :: Particle -> Point2 -> Wall -> World -> World
bulHitWall' bt p x w = damageBlocks x
$ createSpark 8 colID pOut (reflectDir x) Nothing
$ set randGen g
w
where sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
(colID,g) = randomR (0,11) $ _randGen w
(a, _) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(p -.- sp)
)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
where
sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
(colID,g) = randomR (0,11) $ _randGen w
(a, _) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(p -.- sp)
)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
bulBounceWall' :: Particle' -> Point2 -> Wall -> World -> World
{-
Bounce off walls, do damage to blocks.
-}
bulBounceWall' :: Particle -> Point2 -> Wall -> World -> World
bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w
where
sp = head $ _btTrail' bt
@@ -165,71 +185,72 @@ bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w
) {_btTimer' = _btTimer' bt - 1}
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
reflectVel = (reflectIn wallV (_btVel' bt))
addBouncer = (.) (over particles' ((:) bouncer))
-- the hack is to get around the fact that the particles' list gets reset after
addBouncer = (.) ( over particles (bouncer : ) )
-- the hack is to get around the fact that the particles list gets reset after
-- all projectiles in it are checked, so we cannot add to it as we accumulate over
-- this list
bulIncWall' :: Particle' -> Point2 -> Wall -> World -> World
bulIncWall' bt p wl w = damageBlocks wl
$ incFlamelets
-- yay for hack -- should have used this before? or never?
w
where sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
{- Create flamelet on wall.
-}
bulIncWall' :: Particle -> Point2 -> Wall -> World -> World
bulIncWall' bt p wl w = damageBlocks wl $ incFlamelets w
where
sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
bulConWall' :: Particle' -> Point2 -> Wall -> World -> World
bulConWall' bt p wl w = damageBlocks wl
$ mkwave
w
where sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
{- Create a shockwave on wall-}
bulConWall' :: Particle -> Point2 -> Wall -> World -> World
bulConWall' bt p wl w = damageBlocks wl $ mkwave w
where
sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
hvBulHitWall' bt p x w = damageBlocks x
$ set randGen g
$ foldr ($) w (sparks pOut sv)
where sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
(a, g) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(p -.- sp)
)
sv = unitVectorAtAngle $ reflectDir x
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 20)) w (_blIDs wall)
_ -> w
cs = take 10 $ randomRs (0,11) $ _randGen w
ds = randomRs (-0.7,0.7) $ _randGen w
ts = randomRs (4,8) $ _randGen w
sparks pos vel = zipWith3 (\t c d -> createSpark t c pos (argV vel + d) Nothing) ts cs ds
bulHitFF' :: Particle' -> Point2 -> ForceField -> World -> World
hvBulHitWall' :: Particle -> Point2 -> Wall -> World -> World
hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks pOut sv)
where
sp = head $ _btTrail' bt
pOut = p +.+ safeNormalizeV (sp -.- p)
(a, g) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0)
(p -.- sp)
)
sv = unitVectorAtAngle $ reflectDir x
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 20)) w (_blIDs wall)
_ -> w
cs = take 10 $ randomRs (0,11) $ _randGen w
ds = randomRs (-0.7,0.7) $ _randGen w
ts = randomRs (4,8) $ _randGen w
sparks pos vel = zipWith3 (\t c d -> createSpark t c pos (argV vel + d) Nothing) ts cs ds
bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World
bulHitFF' _ _ _ = id
bulletEffect' :: HitEffect
bulletEffect' = destroyOnImpact bulHitCr' bulHitWall' bulHitFF'
bulletParticleSideEffect :: Particle' -> HitEffect
bulletParticleSideEffect :: Particle -> HitEffect
bulletParticleSideEffect pt = destroyOnImpact mkPt mkPt noEff
where mkPt _ p _ = over particles' ((:) pt {_btTrail' = [p]})
where
mkPt _ p _ = over particles ((pt {_btTrail' = [p]}) :)
aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect -> Float -> Particle'
aGenBulAt' :: Maybe Int -> Color -> Point2 -> Point2 -> HitEffect -> Float -> Particle
aGenBulAt' maycid col pos vel hiteff width = Bul'
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
@@ -242,7 +263,7 @@ aGenBulAt' maycid col pos vel hiteff width = Bul'
, _btHitEffect' = hiteff
}
aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect -> Float -> Particle'
aCurveBulAt :: Maybe Int -> Color -> Point2 -> Point2 -> Point2 -> HitEffect -> Float -> Particle
aCurveBulAt maycid col pos control targ hiteff width = Bul'
{ _ptDraw = drawBul
, _ptUpdate' = \w -> mvGenBullet' w . setVel
src/Dodge/Item/Weapon/TriggerType.hs
+3 -3
View File
@@ -192,7 +192,7 @@ withVelWthHiteff
-> World
-> World
withVelWthHiteff vel width hiteff cid w
= over particles' ((:) newbul) $ set randGen g w
= over particles (newbul : ) $ set randGen g w
where
cr = _creatures w IM.! cid
newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width
@@ -281,7 +281,7 @@ spreadNumVelWthHiteff
-> World
-> World
spreadNumVelWthHiteff spread num vel wth eff cid w
= over particles' (newbuls ++) w
= over particles (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid)
@@ -306,7 +306,7 @@ numVelWthHitEff
-> World
-> World
numVelWthHitEff num vel wth eff cid w
= over particles' (newbuls ++) w
= over particles (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid)
src/Dodge/LevelGen/Switch.hs
+3 -3
View File
@@ -28,9 +28,9 @@ makeButton c eff = Button
--, _btText = "Button"
, _btState = BtOff
}
where
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
where
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
makeSwitch c effOn effOff = Button
src/Dodge/LevelGen/TriggerDoor.hs
+56 -52
View File
@@ -23,47 +23,50 @@ import Data.Graph.Inductive.NodeMap
-- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where bid = newKey $ _buttons w
cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
eff w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtNoLabel == _btState (_buttons w IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
eff w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where bid = newKey $ _buttons w
cond w = BtOn == (_btState $ _buttons w IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
openDoor w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtOn == _btState (_buttons w IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
openDoor w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
closeDoor w' = over pathGraph' (\\ removedPairs)
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
where i = newKey wls
is = [i..]
where
i = newKey wls
is = [i..]
mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
@@ -100,7 +103,8 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
$ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
where
wp = _wlLine (_walls w IM.! (head xs)) !! 1
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n closedPos openPos = Door
@@ -113,22 +117,22 @@ triggerDoorPane c cond n closedPos openPos = Door
, _wlIsSeeThrough = False
, _doorPathable = False
}
where
a = closedPos !! 0
b = closedPos !! 1
dm w | cond w = flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') zoneps
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
openDoor = moveToward openPos
closeDoor = moveToward closedPos
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
where
a = closedPos !! 0
b = closedPos !! 1
dm w | cond w = flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') zoneps
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
openDoor = moveToward openPos
closeDoor = moveToward closedPos
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
src/Dodge/Render/HUD.hs
+48 -46
View File
@@ -67,7 +67,7 @@ drawLocations w = displayListTopLeft locs w
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w
zoom = _carteZoom w
locTexts = fst . unzip $ locs
locTexts = map fst locs
bFunc (x,y) (z,w) = pictures
[ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w)
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
@@ -104,63 +104,65 @@ mapWall w wl =
t = normalizeV (y -.- x)
-- n2 = 2 *.* vNormal t
n2 = 20 *.* vNormal t
(x:y:_) = (_wlLine wl)
(x:y:_) = _wlLine wl
c = _wlColor wl
{- Pictures of popup text for items close to your position.-}
closeObjectTexts :: World -> Picture
closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w)
closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _closeActiveObjects w)
++ maybeToList maybeLine
where colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
colAndText (Right x) = (white, _btText x)
renderList i (c,t) = scale (2/_windowX w) (2/_windowY w)
. tran
. translate (xtran i) (0 - 20 * fromIntegral i)
. scale 0.1 0.1
. color c
$ text t
tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
youSel = _crInvSel $ you w
freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
invPos = fromMaybe youSel freeSlot
mayObj = listToMaybe $ _closeActiveObjects w
mayIt = mayObj >>= maybeLeft
maybeLeft (Left x) = Just x
maybeLeft _ = Nothing
pushout = 140
xtran 0 = case mayIt of Nothing -> 25
_ -> -25
xtran _ = 0
objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
maybeLine = do
itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj
let textWidth = 9 * fromIntegral (length theText)
let col = fromMaybe white $ fmap (_itInvColor . _flIt) mayIt
let p = (textWidth + xtran 0 + pushout - halfWidth w
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
let p' = ( pushout - halfWidth w + 130
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
return $ lineCol
[(itScreenPos, withAlpha 0 col)
,(sc p' , col)
,(sc p , col)
]
where
colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
colAndText (Right x) = (white, _btText x)
renderList i (c,t) = scale (2/_windowX w) (2/_windowY w)
. tran
. translate (xtran i) (0 - 20 * fromIntegral i)
. scale 0.1 0.1
. color c
$ text t
tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
youSel = _crInvSel $ you w
freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
invPos = fromMaybe youSel freeSlot
mayObj = listToMaybe $ _closeActiveObjects w
mayIt = mayObj >>= maybeLeft
maybeLeft (Left x) = Just x
maybeLeft _ = Nothing
pushout = 140
xtran 0 = case mayIt of Nothing -> 25
_ -> -25
xtran _ = 0
objPos obj = case obj of Left flit -> _flItPos flit
Right bt -> _btPos bt
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
maybeLine = do
itScreenPos <- mayScreenPos
theText <- fmap (snd . colAndText) mayObj
let textWidth = 9 * fromIntegral (length theText)
let col = maybe white (_itInvColor . _flIt) mayIt
let p = (textWidth + xtran 0 + pushout - halfWidth w
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
let p' = ( pushout - halfWidth w + 130
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
)
return $ lineCol
[(itScreenPos, withAlpha 0 col)
,(sc p' , col)
,(sc p , col)
]
{- Add coloured drop shadow. -}
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures $
dShadCol c p = pictures
[ color black $ uncurry translate (1.2,-1.2) p
, color c p
]
drawListCursor :: Color -> Int -> World -> Picture
drawListCursor c iPos w = scale (2 / _windowX w) (2 / _windowY w)
. translate (105-halfWidth w) (halfHeight w - (20* (fromIntegral iPos)) - 20)
. translate (105-halfWidth w) (halfHeight w - (20* fromIntegral iPos) - 20)
$ lineCol [(( 100,12.5) ,withAlpha 0 c)
,((-100,12.5) ,c)
,((-100,-7.5) ,c)
src/Dodge/Render/Picture.hs
+67 -59
View File
@@ -22,7 +22,7 @@ worldPictures w = pictures $ concat
, map clDraw . IM.elems $ _clouds w
, map ppDraw . IM.elems $ _pressPlates w
, map btDraw (IM.elems (_buttons w))
, map (\pt -> _ptDraw pt pt) $ _particles' w
, map (\pt -> _ptDraw pt pt) $ _particles w
, map drawWallFloor (wallFloorsToDraw w)
, testPic w
]
@@ -54,14 +54,16 @@ btDraw :: Button -> Picture
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
clDraw :: Cloud -> Picture
clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
clDraw c = uncurry translate (_clPos c) (_clPict c c)
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where onScreen wall = lineOnScreen w (_wlLine wall)
isVisible wl | wl ^? blVisible == Just False = False
| otherwise = onScreen wl
where
onScreen wall = lineOnScreen w (_wlLine wall)
isVisible wl
| wl ^? blVisible == Just False = False
| otherwise = onScreen wl
wallsOnScreen :: World -> IM.IntMap Wall
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
@@ -76,26 +78,28 @@ drawWallFloor wl = if _wlIsSeeThrough wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
errorNormalizeVDR :: Point2 -> Point2
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
errorNormalizeVDR (0,0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
errorNormalizeVDR p = normalizeV p
printPoint :: Point2 -> Picture
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
printRotPoint :: Float -> Point2 -> Picture
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3
, rotate (0 - r) $ scale 0.1 0.1 $ text (show p)]
printRotPoint r p = color white
. uncurry translate p
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2]
outsideScreenPolygon w = [tr,tl,bl,br]
where scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
x = halfWidth w + halfHeight w
where
scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraCenter w
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
x = halfWidth w + halfHeight w
wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
@@ -107,43 +111,46 @@ wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
lineOnScreenCone :: World -> [Point2] -> Bool
lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
where sp' = screenPolygon w
vp = _cameraViewFrom w
sp | pointInPolygon vp sp' = sp'
| otherwise = orderPolygon $ (_cameraViewFrom w : sp')
sps = zip sp (tail sp ++ [head sp])
where
sp' = screenPolygon w
vp = _cameraViewFrom w
sp | pointInPolygon vp sp' = sp'
| otherwise = orderPolygon (_cameraViewFrom w : sp')
sps = zip sp (tail sp ++ [head sp])
lineOnScreen :: World -> [Point2] -> Bool
lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
where sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
where
sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
drawWallFace :: World -> Wall -> Picture
drawWallFace w wall
| isRHS sightFrom x y || _wlIsSeeThrough wall = blank
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
where
(x:y:_) = _wlLine wall
points = extendConeToScreenEdge w sightFrom (x,y)
sightFrom = _cameraViewFrom w
where
(x:y:_) = _wlLine wall
points = extendConeToScreenEdge w sightFrom (x,y)
sightFrom = _cameraViewFrom w
-- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen w a b = listToMaybe
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
. makeLoopPairs
$ screenPolygon w
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
. makeLoopPairs
$ screenPolygon w
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
. makeLoopPairs $ screenPolygon w
where
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
. makeLoopPairs $ screenPolygon w
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
@@ -154,47 +161,48 @@ drawItem flIt = uncurry translate (_flItPos flIt)
ffToDraw :: World -> [ForceField]
ffToDraw w = filter (lineOnScreen w . _ffLine) $
IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraCenter w))) $
IM.elems $ over ffLine (map ( -.- _cameraCenter w)) <$>
_forceFields w
drawFF :: ForceField -> Picture
drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col
$ lineOfThickness 6 l ]
drawFFShadow :: World -> ForceField -> [Picture]
drawFFShadow w ff
| youOnFF = []
| otherwise = map (rotate ( _cameraRot w) . pane)
[0,0.05..0.25]
where p = rotateV (-_cameraRot w) $ ypShift
x = rotateV (-_cameraRot w) x'
y = rotateV (-_cameraRot w) y'
yp = _crPos $ you w
(x1:y1:_) = _ffLine ff
(x':y':_) | isRHS x1 y1 yp = (y1:x1:[])
| otherwise = (x1:y1:[])
fCol = color (_ffColor ff)
col = _ffColor ff
ypShift = yp -.- _cameraCenter w
youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
pane j = color (withAlpha 0.1 col)
$ polygon
$ [ x
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
, y]
| otherwise = map (rotate ( _cameraRot w) . pane) [0,0.05..0.25]
where
p = rotateV (-_cameraRot w) ypShift
x = rotateV (-_cameraRot w) x'
y = rotateV (-_cameraRot w) y'
yp = _crPos $ you w
(x1:y1:_) = _ffLine ff
(x':y':_) | isRHS x1 y1 yp = [y1,x1]
| otherwise = [x1,y1]
fCol = color (_ffColor ff)
col = _ffColor ff
ypShift = yp -.- _cameraCenter w
youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
pane j = color (withAlpha 0.1 col)
$ polygon
[ x
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
, y]
wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
where
linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
wallsWindows :: World -> [((Point2,Point2),Point4)]
wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
where
linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
wallsForShadows :: World -> [(Point2,Point2)]
wallsForShadows w = map (linePairs . _wlLine)
src/Dodge/Room/Boss.hs
+4 -4
View File
@@ -25,10 +25,10 @@ roomOctogon x = Room
, _rmPath = [((0,x),(0,-(x+40)))
,((0,-(x+40)),(0,x))]
, _rmPS =
[PS (fx,fx) 0 $ putLamp
,PS (-fx,fx) 0 $ putLamp
,PS (fx,-fx) 0 $ putLamp
,PS (-fx,-fx) 0 $ putLamp
[PS (fx,fx) 0 putLamp
,PS (-fx,fx) 0 putLamp
,PS (fx,-fx) 0 putLamp
,PS (-fx,-fx) 0 putLamp
,crystalLine (-x,x/2) (negate (x/2), x)
,crystalLine (x,x/2) (x/2, x)
,crystalLine (x/2,-x) (x,negate (x/2))
src/Dodge/Room/Branch.hs
+5 -4
View File
@@ -21,7 +21,8 @@ branchRectWith t = do
y <- state $ randomR (100,200)
b <- t
root <- randomiseOutLinks $ roomRectAutoLinks x y
return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeFromTrunk [Left door] b]
where rToL :: Either a a -> Either a a
rToL (Right r) = Left r
rToL (Left r) = Left r
return $ Node (Left root) [Node (Right door) [], rToL <$> treeFromTrunk [Left door] b]
where
rToL :: Either a a -> Either a a
rToL (Right r) = Left r
rToL (Left r) = Left r
src/Dodge/Room/CheckConsistency.hs
+2 -2
View File
@@ -13,5 +13,5 @@ linksOnPath r = all pointOnPath linkPoints
pathConnected :: Room -> Bool
pathConnected = isSingleton . pairsToSCC . _rmPath
where
isSingleton (_:[]) = True
isSingleton _ = False
isSingleton [] = True
isSingleton _ = False
src/Dodge/Room/Corridor.hs
+8 -7
View File
@@ -3,6 +3,9 @@ module Dodge.Room.Corridor
import Dodge.Room.Data
import Geometry
{- First exit due north, two other exits at angles next to this.
Entrance from south.
-}
corridor :: Room
corridor = Room
{ _rmPolys = [rectNSWE 80 0 0 40
@@ -10,15 +13,13 @@ corridor = Room
-- ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where
lnks =
[((20,70) ,0)
-- ,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6)
-- ,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6)
,((20,70), pi/6)
,((20,70), 0-pi/6)
,((20,10) ,pi)
@@ -39,11 +40,11 @@ corridorN = Room
tEast :: Room
tEast = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
@@ -53,11 +54,11 @@ tEast = Room
]
tWest :: Room
tWest = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPath = concatMap (doublePair . (,) (0,60) . fst) lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
src/Dodge/Room/Link.hs
+3 -2
View File
@@ -48,8 +48,9 @@ This is intended to work when the external point is an outgoing link from anothe
shiftRoomToLink :: (Point2,Float) -> Room -> Room
shiftRoomToLink l r
= shiftRoomBy l
. shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0)
$ shiftRoomBy ((0,0),pi-a) r
. shiftRoomBy ((0,0) -.- rotateV (pi-a) p , 0)
$ shiftRoomBy ((0,0) ,pi-a)
r
where
(p,a) = last $ _rmLinks r
src/Dodge/Room/Placement.hs
+1 -1
View File
@@ -60,7 +60,7 @@ crystalLine a b = PS
up = vNormal left
windowLineType :: Point2 -> Point2 -> PSType
windowLineType a b = PutLineBlock baseWindowPane 8 8 a b
windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = Block
src/Dodge/Room/Procedural.hs
+8 -11
View File
@@ -19,7 +19,7 @@ import Dodge.Creature
import Dodge.Default
import Geometry
import Data.List (nub,nubBy,sortBy)
import Data.List (nub,nubBy,sortBy,minimumBy)
import Data.Function (on)
import Control.Lens
import Control.Monad
@@ -39,7 +39,7 @@ roomRect x y xn yn = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [PS (x/2,y/2) 0 $ putLamp]
, _rmPS = [PS (x/2,y/2) 0 putLamp]
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
}
where
@@ -76,7 +76,8 @@ makeRect x y = [((0,0),(x,0))
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
where
linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
{- Combines two rooms into one room.
Combines into one big bound, concatenates the rest.
@@ -174,7 +175,7 @@ fourthCornerWall w = do
, PS (0,10) 0 putLamp
, PS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate $ w,w) (0,w)
, blockLine (negate w,w) (0,w)
]
, [ PS (10-w,w) 0 putLamp
, PS (w-10,w) 0 putLamp
@@ -211,20 +212,16 @@ shufflePlacements r = do
newPSs <- shuffle $ _rmPS r
return $ r & rmPS .~ newPSs
putDefaultFlIt :: Item -> PSType
putDefaultFlIt itm = PutFlIt itm
testRoom :: RandomGen g => State g Room
testRoom = do
corners <- replicateM 4 . join $ takeOne [fourthWall 100, fourthCornerWall 100]
nItms <- state $ randomR (1,2)
itms <- takeN nItms $ fmap putDefaultFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
itms <- takeN nItms $ fmap PutFlIt $ [autoRadar,autoSonar,remoteLauncher,jetPack,blinkGun] ++ replicate 5 (medkit 500)
nCrits <- state $ randomR (1,3)
crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
++ replicate 20 chaseCrit
randomiseAllLinks =<<
( fmap (fillNothingPlacements $ crits ++ itms)
. shufflePlacements
randomiseAllLinks . (fillNothingPlacements $ crits ++ itms) =<<
( shufflePlacements
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
)
src/Dodge/Room/RoadBlock.hs
+4 -4
View File
@@ -37,12 +37,12 @@ litCorridor90 = do
,((40,h-40),(20,h-40))
]
, _rmPS =
[ PS (20,h-5) 0 $ putLamp
[ PS (20,h-5) 0 putLamp
, windowLine (0,h-20) (40,h-20)
, PS (-50,h-85) 0 $ putLamp
, PS (-50,h-85) 0 putLamp
, windowLine (0-40,h-60) (0-40,h-100)
, PS ( 20,h-40) 0 $ PutID 0
, PS (-20,h-80) 0 $ PutID 2
, PS ( 20,h-40) 0 $ PutID 0
, PS (-20,h-80) 0 $ PutID 2
]
, _rmBound = poly
}
src/Dodge/Room/Teleport.hs
+5 -2
View File
@@ -19,7 +19,10 @@ import Control.Monad.State
import System.Random
import qualified Data.Set as S
telRoomLev :: RandomGen g => Int -> State g Room
telRoomLev
:: RandomGen g
=> Int -- ^ Level number to teleport to
-> State g Room
telRoomLev i = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
@@ -40,5 +43,5 @@ telRoomLev i = do
levelReset pp w
| dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ startNewGame w
| otherwise = w
ppPoly pp = map (+.+ (_ppPos pp)) ppFootprint
ppPoly pp = map (+.+ _ppPos pp) ppFootprint
startNewGame w = w & worldTriggers %~ S.insert (ResetLevel i)
src/Dodge/Room/Treasure.hs
+3 -1
View File
@@ -52,8 +52,10 @@ triLootRoom w h = pure $ Room
]
base = rectNSWE 20 (-80) (-20) 20
{- Create a random room with one entrance containing given creatures and items.
-}
lootRoom :: RandomGen g => [Creature] -> [Item] -> State g Room
lootRoom crs itms = do
let w = 300
h = 700
fmap (replacePutID 0 (map PutCrit crs) . replacePutID 2 (map PutFlIt itms)) $ triLootRoom w h
replacePutID 0 (map PutCrit crs) . replacePutID 2 (map PutFlIt itms) <$> triLootRoom w h
src/Dodge/Update.hs
+11 -8
View File
@@ -41,7 +41,7 @@ update' :: World -> World
update' w = case _menuLayers w of
(ConfigSaveScreen : ls) -> w & menuLayers .~ ls
(_ : _) -> w
[] -> let w1 = updateParticles'
[] -> let w1 = updateParticles
. updateProjectiles
. updateLightSources
. zoneClouds
@@ -83,19 +83,22 @@ triggerUpdate w
& creatures . ix 0 .~ (_creatures w IM.! 0 & crPos .~ (0,0))
| otherwise = w
updateSoundQueue = set soundQueue []
. set sounds M.empty
updateSoundQueue = set soundQueue [] . set sounds M.empty
updateLightSources :: World -> World
updateLightSources w = set tempLightSources (catMaybes tlss) w'
where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
where
(w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
updateParticles' :: World -> World
updateParticles' w =
set particles' (catMaybes ps) w'
{-
Apply internal particle updates, delete 'Nothing's.
-}
updateParticles :: World -> World
updateParticles w = set particles (catMaybes ps) w'
where
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles w
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
src/Dodge/Update/Camera.hs
+28 -26
View File
@@ -7,7 +7,6 @@ module Dodge.Update.Camera
( updateCamera
)
where
import Dodge.Data
import Dodge.Base
import Dodge.Config.KeyConfig
@@ -18,17 +17,22 @@ import Control.Monad
import Data.Maybe
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified SDL as SDL
import qualified SDL
{-
Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
update where your avatar's view is from.
-}
updateCamera :: World -> World
updateCamera = rotCam . moveCamera . updateScopeZoom
{- Updte the center of the screen camera center and where your avatar's view is from in world. -}
moveCamera :: World -> World
moveCamera w = w & cameraCenter .~ idealPos
& cameraViewFrom .~ sightFrom
where
aimRangeFactor | _cameraZoom w == 0 = 0
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
| otherwise = fromMaybe 0 (yourItem w ^? itAimingRange) / _cameraZoom w
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
| otherwise = 0
ypos = _crPos $ you w
@@ -72,28 +76,27 @@ updateScopeZoom w
zoomSpeed = 39/40
zoomInLongGun :: World -> World
zoomInLongGun w | currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos)
(\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep)
$ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z / zoomSpeed)
w
| otherwise = w
where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
mousep = rotateV (_cameraRot w) $ _mousePos w
zoomInLongGun w
| currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos)
(\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep)
$ over (wpPointer . itAttachment . _Just . scopeZoom) (/ zoomSpeed)
w
| otherwise = w
where
wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0)
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
mousep = rotateV (_cameraRot w) $ _mousePos w
zoomOutLongGun :: World -> World
zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopePos)
-- (\p -> p -.- 2/(2 * currentZoom) *.* _mousePos w)
-- (\p -> p -.- 2*zoomSpeed/currentZoom *.* p)
(\p -> p)
$ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z * zoomSpeed)
w
| otherwise = w
where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
currentCursorDisplacement = fromJust $ _itAttachment wp
zoomOutLongGun w
| currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopeZoom) (* zoomSpeed) w
| otherwise = w
where
wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0)
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
currentCursorDisplacement = fromJust $ _itAttachment wp
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
@@ -130,11 +133,10 @@ autoZoomCam w = over cameraZoom changeZoom w
wallZoom = farWallDist camPos w
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom *
(
min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
$ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
( max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
)
)
| otherwise
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
src/Dodge/WorldEvent.hs
+1 -1
View File
@@ -41,7 +41,7 @@ import qualified Data.IntMap.Strict as IM
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createBarrelSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles' ((:) spark)
((.) $ ( over particles ((:) spark)
. sparkFlashAt pos')
) w
where spark = Bul' { _ptDraw = drawBul
src/Dodge/WorldEvent/Bullet.hs
+7 -1
View File
@@ -1,3 +1,6 @@
{-
Bullet update.
-}
module Dodge.WorldEvent.Bullet
where
import Dodge.Data
@@ -16,7 +19,10 @@ import Data.Function (on)
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
{-
Update for a generic bullet.
-}
mvGenBullet' :: World -> Particle -> (World, Maybe Particle)
mvGenBullet' w bt
| t <= 0 = (w, Nothing)
| t < 4 = (w, Just $ set btPassThrough' Nothing
src/Dodge/WorldEvent/Explosion.hs
+27 -19
View File
@@ -1,3 +1,6 @@
{-
Explosions: creation of shockwave and particles at a given point.
-}
module Dodge.WorldEvent.Explosion
where
@@ -18,20 +21,24 @@ 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
:: Point2 -- ^ Position
-> World
-> World
makePoisonExplosionAt p w = soundOncePos grenadeBang p $ 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
vels = replicateM 25 (randInCirc 2) & evalState $ _randGen w
-- just change the number after replicateM 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
:: Point2 -- ^ Position
-> World
-> World
makeTeslaExplosionAt pos w = soundOncePos grenadeBang pos $ foldr ($) w listOfFunctions -- a bit shorter
where
-- rad or 360? Radians (hopefully) everywhere
xs = randomRs (0, 2*pi) $ _randGen w
j = newProjectileKey w
pks = [j..]
@@ -39,31 +46,32 @@ makeTeslaExplosionAt pos w = soundOncePos grenadeBang pos $ foldr ($) w listOfFu
(\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 = soundOncePos grenadeBang p $ over particles' (newFlames ++ ) w
makeFlameExplosionAt
:: Point2 -- ^ Position
-> World
-> World
makeFlameExplosionAt p w = soundOncePos grenadeBang p $ 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)
velocities = replicateM 15 (randInCirc 1) & evalState $ _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
:: Point2 -- ^ Position
-> World
-> World
makeExplosionAt p w = soundOncePos grenadeBang p
. 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'
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs' = replicateM 75 (randInCirc 15) & evalState $ _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
@@ -71,6 +79,6 @@ makeExplosionAt p w = soundOncePos grenadeBang p
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)
pushAgainstWalls q = maybe q (uncurry (+.+))
$ collidePointWalls p q $ wallsNearPoint q w
src/Dodge/WorldEvent/Flash.hs
+53 -48
View File
@@ -1,3 +1,13 @@
{- | Flashes.
projected naming conventions: three base types of light:
glare : "low lighting", draws lines around creatures and walls
flare : coloured light drawn on top of picture in fixed shapes
light : removal of shadows
duration (subject to modification):
flash : short, abrupt changes in alpha
glow : continuous, potentially long, fading, slow changes in alpha
flicker : potentially long, moving, abrupt changes in alpha
-}
module Dodge.WorldEvent.Flash
where
import Dodge.Data
@@ -13,71 +23,67 @@ import Geometry
import Data.Maybe (maybeToList)
import Control.Lens
-- projected naming: three base types of light:
-- glare : "low lighting", draws lines around creatures and walls
-- flare : coloured light drawn on top of picture in fixed shapes
-- light : removal of shadows
-- duration (subject to modification):
-- flash : short, abrupt changes in alpha
-- glow : continuous, potentially long, fading, slow changes in alpha
-- flicker : potentially long, moving, abrupt changes in alpha
glareAt :: Int -> Float -> Float -> Color -> Int -> Float -> Point2 -> World -> World
glareAt t len wdth col nrays rad p w = foldr (glareLine' t len wdth col p) w ps
where ps = map ((+.+) p) $ nRaysRad nrays rad
where
ps = map (p +.+) $ nRaysRad nrays rad
{- White flash. -}
sparkFlashAt :: Point2 -> World -> World
sparkFlashAt p =
glareAt 2 10 5 (withAlpha 0.05 white) 20 30 p
sparkFlashAt =
glareAt 2 10 5 (withAlpha 0.05 white) 20 30
{- Red flash. -}
bloodFlashAt :: Point2 -> World -> World
bloodFlashAt p =
over particles' ((:) (flashFlareAt red 0.4 p))
. glareAt 2 10 5 (withAlpha 0.05 red) 20 30 p
over particles (flashFlareAt red 0.4 p : )
. glareAt 2 10 5 (withAlpha 0.05 red) 20 30 p
{- Cyan flash. -}
teslaGunFlashAt :: Point2 -> World -> World
teslaGunFlashAt p =
over particles' ((:) (flashFlareAt cyan 0.3 p))
. glareAt 2 10 5 (withAlpha 0.1 cyan) 20 30 p
teslaGunFlashAt p =
over particles (flashFlareAt cyan 0.3 p : )
. glareAt 2 10 5 (withAlpha 0.1 cyan) 20 30 p
{- Yellow flash. -}
laserGunFlashAt :: Point2 -> World -> World
laserGunFlashAt p =
over particles' ((:) (flashFlareAt yellow 0.2 p))
. glareAt 2 10 5 (withAlpha 0.05 yellow) 20 30 p
over particles (flashFlareAt yellow 0.2 p : )
. glareAt 2 10 5 (withAlpha 0.05 yellow) 20 30 p
glareLine' :: Int -> Float -> Float -> Color -> Point2 -> Point2 -> World -> World
glareLine' t len wdth col a b w = w & particles' %~ (maybeToList linePt ++)
where linePt :: Maybe Particle'
linePt = glareBetween t len wdth col a b w
glareLine' t len wdth col a b w = w & particles %~ (maybeToList linePt ++)
where
linePt :: Maybe Particle
linePt = glareBetween t len wdth col a b w
glareBetween :: Int -> Float -> Float -> Color -> Point2 -> Point2 -> World -> Maybe Particle'
glareBetween :: Int -> Float -> Float -> Color -> Point2 -> Point2 -> World -> Maybe Particle
glareBetween 0 _ _ _ _ _ _ = Nothing
glareBetween t len wdth col a b w
= Just $ Particle' {_ptDraw = const $ lowLightPic len wdth col (a,b) w
,_ptUpdate' = \ w' _ -> (w',glareBetween (t-1) len wdth col a b w')
}
glareBetween t len wdth col a b w = Just $ Particle
{_ptDraw = const $ lowLightPic len wdth col (a,b) w
,_ptUpdate' = \ w' _ -> (w',glareBetween (t-1) len wdth col a b w')
}
lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture
lowLightPic len wdth col (a,b) w
= case thingsHit a b w of
lowLightPic len wdth col (a,b) w = case thingsHit a b w of
((p, E3x2 wall):_)
-> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb]
where x = len *.* (normalizeV $ wa -.- wb)
where x = len *.* normalizeV (wa -.- wb)
(wa:wb:_) = _wlLine wall
((p, E3x1 cr):_)
-> setCol . uncurry translate cp . rotate (-0.25 * pi + argV (p -.- cp))
$ thickArc 0 (pi/2) (_crRad cr) wdth
where cp = _crPos cr
_ -> blank
where setCol = color col . setDepth (-0.5) . setLayer 2
where setCol = color col . setDepth (-0.5) . setLayer 2
flashFlareAt :: Color -> Float -> Point2 -> Particle'
flashFlareAt col alphax (x,y) =
Particle'
{ _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y
$ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
, _ptUpdate' = ptTimer' 1
}
flashFlareAt :: Color -> Float -> Point2 -> Particle
flashFlareAt col alphax (x,y) = Particle
{ _ptDraw = const $ setLayer 2 . setDepth (-0.9) . translate x y
$ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
, _ptUpdate' = ptTimer' 1
}
explosionFlashAt :: Point2 -> World -> World
explosionFlashAt p = over tempLightSources ((:) $ tLightFade 20 150 intensityFunc p)
@@ -94,19 +100,18 @@ lowLightDirected col a b angles w
muzzleFlashAt :: Point2 -> World -> World
muzzleFlashAt p = over particles' ((:) (muzzleFlashPt p))
muzzleFlashAt p = over particles (muzzleFlashPt p : )
. glareAt 2 10 5 (withAlpha 0.5 white) 20 30 p
muzzleFlashPt :: Point2 -> Particle'
muzzleFlashPt (x,y) =
Particle'
{ _ptDraw = const $ setDepth 0
. setLayer 2
. translate x y
$ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20
, _ptUpdate' = ptTimer' 1
}
muzzleFlashPt :: Point2 -> Particle
muzzleFlashPt (x,y) = Particle
{ _ptDraw = const $ setDepth 0
. setLayer 2
. translate x y
$ circleSolidCol (withAlpha 0 white) (withAlpha 0.2 white) 20
, _ptUpdate' = ptTimer' 1
}
laserScopeTargetGlow :: Color -> Point2 -> World -> World
laserScopeTargetGlow col p = glareAt 2 3 1 (withAlpha 0.1 col) 15 5 p
laserScopeTargetGlow col = glareAt 2 3 1 (withAlpha 0.1 col) 15 5
src/Dodge/WorldEvent/HelperParticle.hs
+7 -1
View File
@@ -1,8 +1,14 @@
{-
Helper functions for particles.
-}
module Dodge.WorldEvent.HelperParticle
where
import Dodge.Data
ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle')
{-
A simple timer update for particles.
-}
ptTimer' :: Int -> World -> Particle -> (World, Maybe Particle)
ptTimer' 0 w pt = (w, Nothing)
ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)})
src/Dodge/WorldEvent/HitEffect.hs
+7 -7
View File
@@ -9,12 +9,12 @@ import Data.Maybe
import Control.Lens
type HitCreatureEffect = Particle' -> Point2 -> Creature -> World -> World
type HitWallEffect = Particle' -> Point2 -> Wall -> World -> World
type HitForceFieldEffect = Particle' -> Point2 -> ForceField -> World -> World
type HitCreatureEffect = Particle -> Point2 -> Creature -> World -> World
type HitWallEffect = Particle -> Point2 -> Wall -> World -> World
type HitForceFieldEffect = Particle -> Point2 -> ForceField -> World -> World
passThroughAll :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle)
passThroughAll crEff wlEff ffEff pt hitThings w = (w, mvPt)
where
mvPt = Just $ pt & btTrail' .~ (newP : trl)
@@ -24,7 +24,7 @@ passThroughAll crEff wlEff ffEff pt hitThings w = (w, mvPt)
newP = head trl +.+ _btVel' pt
destroyOnImpact :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle)
destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of
[] -> ( w, mvPt)
((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p)
@@ -40,7 +40,7 @@ destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of
newP = head trl +.+ _btVel' pt
penWalls :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle)
penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
[] -> ( w, mvPt)
((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p)
@@ -57,7 +57,7 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
wth = _btWidth' pt
newP = head trl +.+ _btVel' pt
doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World
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
src/Dodge/WorldEvent/Shockwave.hs
+57 -34
View File
@@ -20,16 +20,17 @@ makeShockwaveAt
-> Color -- ^ Color of shockwave.
-> World -- ^ Start world.
-> World
makeShockwaveAt is p rad dam push col = over particles' ((:) theShockwave)
where theShockwave = shockwaveAt is p rad dam push col 10
makeShockwaveAt is p rad dam push col = over particles (theShockwave :)
where
theShockwave = shockwaveAt is p rad dam push col 10
shockwaveAt
:: [Int] -- ^ IDs of invulnerable creatures.
-> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
-> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle
shockwaveAt is p rad dam push col maxtime
= Shockwave'
{ _ptDraw = drawShockwave
, _ptUpdate' = mvShockwave' is
, _ptUpdate' = mvShockwave is
, _btColor' = col
, _btPos' = p
, _btRad' = rad
@@ -39,7 +40,10 @@ shockwaveAt is p rad dam push col maxtime
, _btTimer' = maxtime
}
drawShockwave :: Particle' -> Picture
{-
Shockwave picture.
-}
drawShockwave :: Particle -> Picture
drawShockwave pt = pic
where
pic = onLayer PtLayer $ uncurry translate p
@@ -51,10 +55,10 @@ drawShockwave pt = pic
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
t = _btTimer' pt
mvShockwave'
mvShockwave
:: [Int] -- ^ IDs of invulnerable creatures.
-> World -> Particle' -> (World, Maybe Particle')
mvShockwave' is w pt
-> World -> Particle -> (World, Maybe Particle)
mvShockwave is w pt
| _btTimer' pt <= 0 = (w, Nothing)
| otherwise
= (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt)
@@ -83,32 +87,51 @@ mvShockwave' is w pt
-------------------------------------------------
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
where theShockwave
= Particle'
{ _ptDraw = const blank
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
}
moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
{-
Create a shockwave going from an outside circle into a center point.
-}
inverseShockwaveAt
:: Point2 -- Center position
-> Float -- Radius
-> Int -- Damage
-> Float -- Push amount
-> Float -- Push amount parameter
-> World
-> World
inverseShockwaveAt p rad dam push pushexp = over particles (theShockwave :)
where
theShockwave = Particle
{ _ptDraw = const blank
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
}
moveInverseShockWave
:: Int -- ^ Timer
-> Point2 -- ^ Center position
-> Float -- ^ Radius
-> Float -- ^ Push amount
-> Float -- ^ Push amount parameter
-> World
-> Particle
-> (World, Maybe Particle)
moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing)
moveInverseShockWave t p r push pushexp w pt
= (dams w, Just $ newupdate $ newpic pt )
where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
$ color cyan $ thickCircle rad thickness)
rad = r - (4/40) * r * fromIntegral (10 - t)
thickness = (fromIntegral (10 - t))**2 * rad / 40
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
w
(_blIDs wall)
_ -> w
damCr cr | dist (_crPos cr) p < rad + _crRad cr
= over (crState . crDamage)
((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
cr
| otherwise = cr
where
newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
$ color cyan $ thickCircle rad thickness)
rad = r - (4/40) * r * fromIntegral (10 - t)
thickness = fromIntegral (10 - t) **2 * rad / 40
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
w
(_blIDs wall)
_ -> w
damCr cr | dist (_crPos cr) p < rad + _crRad cr
= over (crState . crDamage)
((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
cr
| otherwise = cr
src/Dodge/WorldEvent/SpawnParticle.hs
+246 -161
View File
@@ -1,3 +1,6 @@
{-
Creation of particles in the world.
-}
module Dodge.WorldEvent.SpawnParticle
where
import Dodge.Data
@@ -11,7 +14,6 @@ import Dodge.WorldEvent.Bullet
import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.Debug
import Picture
import Geometry
@@ -23,8 +25,12 @@ 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
:: Int -- ^ Timer
-> Point2 -- ^ Position
-> Point2 -- ^ Velocity
-> Maybe Int -- ^ Creature id
-> Particle
aFlameParticle t pos vel maycid = Pt'
{ _ptDraw = drawFlame vel
, _ptUpdate' = moveFlame vel
@@ -37,10 +43,18 @@ aFlameParticle t pos vel maycid = Pt'
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
makeFlame :: Int -> Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame t pos vel maycid = over particles' (aFlameParticle t pos vel maycid : )
makeFlame
:: Int -- ^ Timer
-> Point2 -- ^ Position
-> Point2 -- ^ Velocity
-> Maybe Int -- ^ Creature id
-> World
-> World
makeFlame t pos vel maycid = over particles (aFlameParticle t pos vel maycid : )
drawFlame :: Point2 -> Particle' -> Picture
drawFlame
:: Point2 -- ^ Rotate direction
-> Particle -> Picture
drawFlame rotd pt = thePic
where
ep = _btPos' pt
@@ -69,13 +83,20 @@ drawFlame rotd pt = thePic
prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (0,1)
prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2)
moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle')
{-
TODO: add generalised area damage particles/hiteffects.
-}
moveFlame
:: Point2 -- ^ Rotation direction
-> 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)
((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
@@ -89,16 +110,19 @@ moveFlame rotd w pt
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
damcrs = foldr (\cr -> fst . hiteff [(ep,E3x1 cr)]) w
$ 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))
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
}
rfl wl p = Just $ pt
{ _btTimer' = time -1
, _btPos' = pOut p
, _btVel' = reflV wl
}
pOut p = p +.+ safeNormalizeV (sp -.- p)
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
vel )
@@ -106,23 +130,35 @@ moveFlame rotd w pt
(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
makeFlameletTimed
:: Point2 -- ^ Position
-> Point2 -- ^ Velocity
-> Maybe Int -- ^ Creature id
-> Float -- ^ Size
-> Int -- ^ Timer
-> World
-> World
makeFlameletTimed pos vel maycid size time w = w
& randGen .~ g
& particles %~ (theFlamelet :)
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
:: Float -- ^ Rotation
-> Particle
-> Picture
drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
where
sp = _btPos' pt
@@ -133,30 +169,40 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
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)]
piu = setDepth 0.334
. uncurry translate ep
. color (dark red)
. rotate (negate (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 (negate (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 (negate ( 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')
{-
Update of a flamelet.
Applies movement and attaches damage to nearby creatures.
-}
moveFlamelet :: World -> Particle -> (World, Maybe Particle)
moveFlamelet w pt
| _btTimer' pt <= 0 = ( w, Nothing)
| otherwise = (damcrs, mvPt)
@@ -169,33 +215,46 @@ moveFlamelet w pt
& btPos' .~ ep
& btPassThrough' .~ Nothing
& btVel' .~ 0.8 *.* vel
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
-- damcrs = w
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming 3 sp ep ep)
damcrs = w & creatures %~ IM.map damifclose
isClose cr = dist ep (_crPos cr) < _crRad cr + size
damifclose cr
| isClose cr = cr & crState . crDamage %~ ( Flaming 3 sp ep ep : )
| otherwise = cr
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
makeGasCloud
:: Point2 -- ^ Position
-> Point2 -- ^ Velocity
-> World
-> World
makeGasCloud pos vel w = w
& clouds %~ IM.insert i theCloud
& randGen .~ g
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
{-
Attach poison cloud damage to creatures near cloud.
-}
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)
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)
{-
TODO: make tesla arc a particle.
-}
makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile
makeTeslaArcAt i pos dir = Projectile
{ _pjPos = pos
@@ -206,7 +265,12 @@ makeTeslaArcAt i pos dir = Projectile
, _pjUpdate = moveTeslaArc pos dir i
}
moveTeslaArc :: Point2 -> Float -> Int -> World -> World
moveTeslaArc
:: Point2 -- ^ Emmission position
-> Float -- ^ Emmission direction
-> Int -- ^ Projectile id
-> World
-> World
moveTeslaArc p d i w =
set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . pjUpdate)
@@ -214,37 +278,44 @@ moveTeslaArc p d i w =
$ 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
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 = maybe (q2 -.- q1) snd hitWall
{-
Finds a point somewhere roughly inbetween two points.
-}
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
{-
Finds extra middle points between successive points in a list of points.
-}
lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
lightningMids d1 (p:pers) (p1:p3:ps)
= let p2 = p +.+ lightningMid d1 p1 p3
@@ -252,15 +323,10 @@ lightningMids d1 (p:pers) (p1:p3:ps)
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
{-
Finds a list of hit things from a given point.
'E3x1' objects are creatures, 'E3x2' objects are points on walls, 'E3x3' objects are points in space.
-}
crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
crsLightChain p d wlAttract w
= case crOrWallSensitive p d wlAttract w of
@@ -271,73 +337,92 @@ crsLightChain p d wlAttract 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
{-
Finds whether a creature or wall is in front of a given point and direction.
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.
Has a parameter to tweak how attracted the test is to walls.
-}
crOrWallSensitive
:: Point2 -- ^ Start point
-> Float -- ^ Direction (radians)
-> Float -- ^ Wall attraction parameter
-> 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 = 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)
. (* wlAttract)
)
[-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
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
{-
Finds whether a creature or wall is in front of a given point and direction.
Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.
-}
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
where
cr = 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
-- | Create a spark.
-- 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 :) . sparkFlashAt pos')) w
= w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . )
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)
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
}
pos' = pos +.+ rotateV dir (5,0)
sparkEff bt p cr
= creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
where
sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
drawBul :: Particle' -> Picture
drawBul :: Particle -> Picture
drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt)
src/Dodge/WorldEvent/ThingsHit.hs
+22 -7
View File
@@ -1,19 +1,27 @@
{-
Find which objects lie upon a line.
-}
module Dodge.WorldEvent.ThingsHit
where
import Dodge.Data
import Dodge.Base
import Geometry
import qualified Data.IntMap.Strict as IM
import Data.List
import Data.Maybe
import Data.Function (on)
thingsHit :: Point2 -> Point2 -> World -> [(Point2, Either3 Creature Wall ForceField)]
{-
List those objects that appear on a line.
-}
thingsHit
:: Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> [(Point2, Either3 Creature Wall ForceField)]
thingsHit sp ep w
| sp == ep = []
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w
@@ -31,9 +39,16 @@ thingsHit sp ep w
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
{-
List objects that appear on a line.
Can filter out a creature.
-}
thingsHitExceptCr
:: Maybe Int -- ^ A possible creature ID
-> Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> [(Point2, Either3 Creature Wall ForceField)]
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where
src/Geometry/Intersect.hs
+8 -4
View File
@@ -1,8 +1,14 @@
{-# LANGUAGE TupleSections #-}
{-
Testing for and finding intersection points.
-}
module Geometry.Intersect
where
import Geometry.Data
import Control.Applicative
import Data.Maybe (isNothing)
-- | If two lines intersect, return 'Just' that point.
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-}
@@ -95,13 +101,12 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin
-- | Polymorphic intersection of fractional line points.
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
| linGrad a b == Nothing = ((,) ax) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0))
| linGrad c d == Nothing = ((,) cx) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0))
| isNothing (linGrad a b) = (ax ,) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0))
| isNothing (linGrad c d) = (cx ,) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0))
| otherwise
= case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing
_ -> liftA2 (,) newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
where
(^-^) = liftA2 (-)
(^+^) = liftA2 (+)
@@ -132,7 +137,6 @@ but is symmetric around 0:
(0.0,0.0)
-}
roundPoint2 :: Point2 -> Point2
roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
src/Picture/Render.hs
+2 -2
View File
@@ -154,11 +154,11 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
-- bind buffer for floor light circle
let lightPtr = (\(_,ptr,_) -> ptr) $ head
$ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
(x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)
(x',y') = zTran $ rotateV (negate rot) $ (x,y) -.- (tranx,trany)
zTran (a,b) = (a*2*zoom / winx, b*2*zoom / winy)
pokeFourOff lightPtr 0 (x',y',r,lum)
-- stencil out walls
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
colorMask $= Color4 Disabled Disabled Disabled Disabled
clear [StencilBuffer]
cullFace $= Just Back
stencilOp $= (OpKeep,OpKeep,OpIncr)
src/Picture/Tree.hs
+3 -2
View File
@@ -8,6 +8,7 @@ import Geometry
import Data.Bifunctor
import Data.List
import Data.Maybe (isNothing)
-- todo: refactor out the layer check somehow
-- consider generalising to alternative rather than using LTree
@@ -48,14 +49,14 @@ picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic))
picToLTree j (OverPic f f' r f'' (Pictures ps))
= LBranches (map (picToLTree j . OverPic f f' r f'') ps)
picToLTree j (OverPic f f' r f'' pic)
= (overPos f . overSca f' . overRot r . overCol f'') <$> picToLTree j pic
= overPos f . overSca f' . overRot r . overCol f'' <$> picToLTree j pic
picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
| otherwise = LBranches []
picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
{-# INLINE filtB #-}
filtB mx i t | Just i == mx || Nothing == mx = t
filtB mx i t | Just i == mx || isNothing mx = t
| otherwise = LBranches []
doubleLine :: [a] -> [a]
test/Spec.hs
+1 -1
View File
@@ -41,7 +41,7 @@ shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
genTri = zip <$> trip <*> trip
where
trip = vectorOf 3 $ fmap fromIntegral $ choose (0,3::Int)
trip = vectorOf 3 $ fromIntegral <$> choose (0,3::Int)
genTris = listOf genTri