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