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

Hlinting

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