From 5a52b646e14a77852af71120741f6bc37ef36142 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 5 Nov 2021 19:58:55 +0000 Subject: [PATCH] Add forgotten files, many updates concerning turrets and shields --- src/Dodge/Base.hs | 7 ++ src/Dodge/Creature/State.hs | 7 +- src/Dodge/Data.hs | 14 +++- src/Dodge/Data/DamageType.hs | 5 ++ src/Dodge/Default/Wall.hs | 2 + src/Dodge/Default/World.hs | 1 + src/Dodge/Item/Draw.hs | 14 +++- src/Dodge/Item/Equipment.hs | 89 +++++++++++++++++++++++++- src/Dodge/Item/Weapon/BatteryGuns.hs | 5 +- src/Dodge/Layout.hs | 20 ++---- src/Dodge/Placements/LightSource.hs | 4 +- src/Dodge/Placements/Sensor.hs | 54 ++++++++++++++++ src/Dodge/Placements/Turret.hs | 96 ++++++++++++++++++++++++++++ src/Dodge/Update.hs | 12 ++-- src/Dodge/Wall.hs | 8 +++ src/Dodge/Wall/Create.hs | 16 +++++ src/Dodge/Wall/Damage.hs | 1 + src/Dodge/Wall/Delete.hs | 14 ++-- src/Dodge/Wall/Move.hs | 17 +++++ src/Dodge/Wall/Zone.hs | 24 +++++++ src/Dodge/WallCreatureCollisions.hs | 4 +- 21 files changed, 380 insertions(+), 34 deletions(-) create mode 100644 src/Dodge/Placements/Sensor.hs create mode 100644 src/Dodge/Placements/Turret.hs create mode 100644 src/Dodge/Wall.hs create mode 100644 src/Dodge/Wall/Create.hs create mode 100644 src/Dodge/Wall/Move.hs create mode 100644 src/Dodge/Wall/Zone.hs diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 1b2d39ce7..bd1f39486 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -144,6 +144,13 @@ insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton where f _ = IM.insertWith g y $ IM.singleton obid obj g _ = IM.insert obid obj +deleteIMInZone + :: Int -- ^ First key + -> Int -- ^ Second key + -> Int -- ^ Third key + -> IM.IntMap (IM.IntMap (IM.IntMap a)) + -> IM.IntMap (IM.IntMap (IM.IntMap a)) +deleteIMInZone x y z = ix x . ix y %~ IM.delete z adjustIMZone :: (a -> a) -- ^ Update function -> Int -- ^ First key diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 9f7b82f3b..c5431684c 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -21,6 +21,7 @@ import Picture import qualified IntMapHelp as IM --import StrictHelp +import Data.Maybe import Data.Function import Control.Lens --import Control.Applicative @@ -39,10 +40,14 @@ import qualified Data.Vector.Mutable as MV --dummyUpdate cr _ = (Endo id, Just cr) -- | The movement is updated before the ai in order to correctly set the oldpos. +-- This should be made more sensible: should the movement side effects apply to +-- the creature before or after it has moved? +-- currently invSideEffects are applied after the creature moves, to correctly +-- update shield positions stateUpdate :: CRUpdate -> CRUpdate stateUpdate u cr w = case u (updateMovement cr) w of (f, maybeCr) -> - ( Endo $ invSideEff cr . movementSideEff cr . deathEff . appEndo f + ( Endo $ invSideEff (fromMaybe cr maybeCr) . movementSideEff cr . deathEff . appEndo f , fmap (stepReloading . stepItemUseCooldown . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr ) where diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 3f5c33999..6a69a7d4a 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -56,6 +56,7 @@ data World = World , _clouds :: [Cloud] , _cloudsZone :: Zone [Cloud] , _props :: IM.IntMap Prop + , _instantParticles :: [Particle] , _particles :: ![Particle] , _walls :: !(IM.IntMap Wall) , _doors :: IM.IntMap Door @@ -397,6 +398,11 @@ data ItEffect = NoItEffect ,_itFloorEffect :: Int -> World -> World ,_itEffectCounter :: Int } + | ItInvEffectID + {_itInvEffect :: ItEffect -> Creature -> Int -> World -> World + -- the Int is the items inventory position + ,_itEffectID :: Maybe Int + } data ItZoom = ItZoom { _itZoomMax :: Float , _itZoomMin :: Float @@ -568,7 +574,7 @@ data MachineType | Turret { _tuWeapon :: Item , _tuTurnSpeed :: Float - , _tuFiring :: Bool + , _tuFireTime :: Int } data Door = Door { _drID :: Int @@ -587,7 +593,9 @@ data Wall = Wall , _wlSeen :: Bool , _wlOpacity :: Opacity , _wlPathable :: Bool + , _wlWalkable :: Bool , _wlFireThrough :: Bool + , _wlReflect :: Bool , _wlDraw :: Bool , _wlRotateTo :: Bool , _wlStructure :: WallStructure @@ -602,6 +610,10 @@ data WallStructure | DoorPart { _wlStDoor :: Int } | MachinePart { _wlStMachine :: Int } | BlockPart { _wlStBlock :: Int } + | CreaturePart + { _wlStCreature :: Int + , _wlStDamCreature :: DamageType -> Wall -> Int -> World -> World + } -- | Strict maybe data Maybe' a = Just' a | Nothing' diff --git a/src/Dodge/Data/DamageType.hs b/src/Dodge/Data/DamageType.hs index 2d8bf0ab5..6bb3408ab 100644 --- a/src/Dodge/Data/DamageType.hs +++ b/src/Dodge/Data/DamageType.hs @@ -35,4 +35,9 @@ isElectrical :: DamageType -> Bool isElectrical Electrical {} = True isElectrical _ = False +isMovementDam :: DamageType -> Bool +isMovementDam TorqueDam{} = True +isMovementDam PushDam{} = True +isMovementDam _ = False + makeLenses ''DamageType diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index a159b2a57..0c8be1c90 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -13,9 +13,11 @@ defaultWall = Wall , _wlOpacity = Opaque , _wlPathable = False , _wlFireThrough = False + , _wlReflect = False , _wlDraw = True , _wlRotateTo = True , _wlStructure = StandaloneWall + , _wlWalkable = False } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 5f1adb628..f1ea835b9 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -33,6 +33,7 @@ defaultWorld = World , _cloudsZone = Zone IM.empty , _itemPositions = IM.empty , _props = IM.empty + , _instantParticles = [] , _particles = [] , _walls = IM.empty , _blocks = IM.empty diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 366e041f3..27f8aa725 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -55,8 +55,8 @@ pictureWeaponOnAimItem p cr posInInv drawnWep = translateSPf (1.2 * _crRad cr) 0 p twistWep = translateSPf (0.5 * _crRad cr) 0 p oneHandWep = translateSPf (1.5 * _crRad cr) 0 p - holsteredWep = translateSPf (_crRad cr) 0 (rotateSP (sRot + 1.2) p) - holsteredTwoFlat = translateSPf (_crRad cr) 0 (rotateSP (2*sRot) p) + holsteredWep = translateSPf (_crRad cr) 0 (rotateSP (strideRot cr + 1.2) p) + holsteredTwoFlat = translateSPf (_crRad cr) 0 (rotateSP (twoFlatHRot cr) p) holsteredOneHandWep = translateSPf (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) p handPos = case cr^? crStance . carriage of Just (Walking x LeftForward) -> f x * 50 @@ -65,13 +65,21 @@ pictureWeaponOnAimItem p cr posInInv isTwisting = _itAimStance theIt == TwoHandTwist isOneHand = _itAimStance theIt == OneHand isTwoHandFlat = _itAimStance theIt == TwoHandFlat - sRot = case cr ^? crStance . carriage of + f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen + sLen = _strideLength $ _crStance cr + +strideRot :: Creature -> Float +strideRot cr = case cr ^? crStance . carriage of Just (Walking x LeftForward) -> f x Just (Walking x RightForward) -> - f x _ -> 0 + where f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen sLen = _strideLength $ _crStance cr +twoFlatHRot :: Creature -> Float +twoFlatHRot cr = 2*strideRot cr + pictureItem :: SPic -> Creature diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 34280431b..05426f803 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -2,13 +2,23 @@ module Dodge.Item.Equipment where import Dodge.Data import Dodge.Item.Data +import Dodge.Item.Draw import Dodge.Default +import Dodge.Default.Wall import Dodge.Picture.Layer +import Dodge.Item.Weapon.BatteryGuns +import Dodge.Creature.Test +import Dodge.Wall.Reflect +import Dodge.Wall +import Dodge.Creature.State.Data import Picture import Geometry ---import ShapePicture +import ShapePicture import Shape +import qualified Data.IntMap.Strict as IM +import Control.Lens + magShield :: Item magShield = defaultEquipment { _itIdentity = MagShield @@ -43,6 +53,83 @@ frontArmour = defaultEquipment } flatShield :: Item flatShield = defaultEquipment + { _itEquipPict = pictureWeaponOnAim flatShieldEquipSPic + , _itAimStance = TwoHandFlat + , _itEffect = effectOnOffEquip createShieldWall removeShieldWall + } +flatShieldEquipSPic :: Item -> SPic +flatShieldEquipSPic _ = + ( colorSH yellow $ upperPrismPoly 10 (rectWH 2 10) + , mempty + ) +effectOnEquip :: (Creature -> Item -> World -> World) -> ItEffect +effectOnEquip f = ItInvEffectID + { _itInvEffect = g f + , _itEffectID = Nothing + } + where + g f' _ cr invid w + | _crInvSel cr == invid = f' cr (_crInv (_creatures w IM.! _crID cr) IM.! invid) w + | otherwise = w + +shieldWall :: Int -> Wall +shieldWall crid = defaultWall + {_wlColor = yellow + ,_wlOpacity = SeeAbove + ,_wlPathable = True + ,_wlWalkable = True + ,_wlFireThrough = True + ,_wlReflect = True + ,_wlDraw = False + ,_wlRotateTo = False + ,_wlStructure = CreaturePart crid shieldWallDamage + } + +shieldWallDamage :: DamageType -> Wall -> Int -> World -> World +shieldWallDamage dt wl crid w = case dt of + Lasering {_dmFrom=df,_dmAt=da} -> + w & instantParticles %~ (makeLaserAt 5 (da +.+ normalizeV (df -.- da)) (reflDirWall df da wl) :) + d | isMovementDam d -> w & creatures . ix crid . crState . crDamage %~ (d :) + _ -> w + +createShieldWall :: Creature -> Int -> World -> World +createShieldWall cr invid w = case _itEffectID $ _itEffect it of + Nothing -> let (wlid,w') = createWall ((shieldWall crid) {_wlLine = wlline}) w + in w' & creatures . ix crid . crInv . ix invid . itEffect . itEffectID ?~ wlid + Just wid -> moveWallID wid wlline w + where + crid = _crID cr + it = _crInv (_creatures w IM.! crid) IM.! invid + wlline = (a,b) + crdirv = unitVectorAtAngle $ _crDir cr + crpos = _crPos cr + rad = _crRad cr + 2 + a = crpos +.+ rad *.* crdirv -.- 10 *.* therot crdirv + b = crpos +.+ rad *.* crdirv +.+ 10 *.* therot crdirv + therot | crIsAiming' cr = vNormal + | otherwise = rotateV (twoFlatHRot cr) . vNormal +removeShieldWall :: Creature -> Int -> World -> World +removeShieldWall cr invid w = case _itEffectID $ _itEffect it of + Nothing -> w + Just wid -> w & deleteWallID wid + & creatures . ix crid . crInv . ix invid . itEffect . itEffectID .~ Nothing + where + crid = _crID cr + it = _crInv (_creatures w IM.! crid) IM.! invid + +effectOnOffEquip + :: (Creature -> Int -> World -> World) -- ^ effect when equiped + -> (Creature -> Int -> World -> World) -- ^ effect when not equiped + -> ItEffect +effectOnOffEquip f f' = ItInvEffectID + { _itInvEffect = g + , _itEffectID = Nothing + } + where + g _ cr invid w + | _crInvSel cr == invid = f cr invid w + | otherwise = f' cr invid w + {- | Increases speed, reduces friction, cannot only move forwards. -} jetPack :: Item jetPack = defaultEquipment diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index cf3ebc6f9..066b22976 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -188,12 +188,13 @@ moveLaser phaseV pos dir w pt xp = pos +.+ 800 *.* unitVectorAtAngle dir f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2]) f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of + --f seenWs x y = case find (h' seenWs) $ thingsHitExceptCr Nothing x y w of Just (p,Right wl) - | _wlOpacity wl == SeeThrough -> f' p $ f (wl:seenWs) p (h x y wl p) + | _wlOpacity wl == SeeThrough -> addPoint p $ f (wl:seenWs) p (h x y wl p) | otherwise -> (Just (p,Right wl), [p]) Just (p,obj) -> (Just (p,obj), [p]) Nothing -> (Nothing, [y]) - f' p (x,ps') = (x,p:ps') + addPoint p (x,ps') = (x,p:ps') h x y wl p | isEntering = p +.+ rotateV angleRef normalDist | otherwise = p +.+ rotateV angleRef' normalDist' diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index e81c9013a..120ee3c20 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -6,9 +6,9 @@ import Dodge.LevelGen import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.Pathing +import Dodge.Wall.Zone import Dodge.Placements.Spot import Dodge.RandomHelp -import Dodge.Base import Dodge.Zone import Dodge.GameRoom import Dodge.Bounds @@ -41,7 +41,7 @@ import Data.Maybe generateLevelFromRoomList :: State StdGen [Room] -> World -> World generateLevelFromRoomList gr w - = updateWallZoning + = initWallZoning . setupWorldBounds . flip (foldr $ flip placeSpot) plmnts $ w { _walls = wallsFromRooms rs @@ -102,17 +102,11 @@ setupWorldBounds w = w polyhedrasToEdges :: [Polyhedra] -> [Point3] polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges -updateWallZoning :: World -> World -updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w - where - wallInZone wl - | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl - | otherwise = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b wlid wl)) ips - where - (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) - wlid = _wlID wl - ips = map zoneOfPoint $ uncurry (divideLine zoneSize) (_wlLine wl) - +initWallZoning :: World -> World +initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w) +--initWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w +-- where +-- wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl) makePath :: Tree Room -> [(Point2,Point2)] makePath = concatMap _rmPath . flatten diff --git a/src/Dodge/Placements/LightSource.hs b/src/Dodge/Placements/LightSource.hs index 902e565d9..9b139742c 100644 --- a/src/Dodge/Placements/LightSource.hs +++ b/src/Dodge/Placements/LightSource.hs @@ -20,9 +20,7 @@ mountLightOnShape mountLightOnShape shapeF mcol ls wallp lsp = ps0j (PutForeground . setCol $ shapeF wallp lsp) . ps0 (PutLS $ ls {_lsPos = lsp}) where - setCol = case mcol of - Just col -> colorSH col - Nothing -> id + setCol = maybe id colorSH mcol mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement mountLightID = mountLightOnShape f diff --git a/src/Dodge/Placements/Sensor.hs b/src/Dodge/Placements/Sensor.hs new file mode 100644 index 000000000..6b072ce02 --- /dev/null +++ b/src/Dodge/Placements/Sensor.hs @@ -0,0 +1,54 @@ +module Dodge.Placements.Sensor + ( lightSensor + ) where +import Color +import Dodge.Data +import Dodge.LevelGen.Data +import Dodge.Default +import Geometry +import ShapePicture +import Shape + +import Control.Lens +import Data.Either + +damageSensor + :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage + -> Point2 -> Float -> Placement +damageSensor damF p r = Placement (PS p r) ( PutLS theLS) + $ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine + { _mcDraw = sensorSPic + , _mcUpdate = sensorUpdate damF + , _mcLSs = [lsid] + } + where + theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 } + +lightSensor :: Point2 -> Float -> Placement +lightSensor = damageSensor senseLasering + +senseLasering :: DamageType -> Either Int Int +senseLasering Lasering {_dmAmount = x} = Left x +senseLasering _ = Right 0 + +sensorUpdate :: (DamageType -> Either Int Int) -> Machine -> World -> World +sensorUpdate damF mc w = w & machines . ix mcid %~ upmc + & lightSources . ix lsid %~ upls + where + upmc = ( mcSensor %~ \x' -> min 750 (max 0 (x' - 5 + newSense)) ) + . ( mcHP -~ sum dam ) + . (mcDamage .~ []) + x = _mcSensor mc + mcid = _mcID mc + lsid = head (_mcLSs mc) + (senseData,dam) = partitionEithers $ map damF $ _mcDamage mc + newSense = sum senseData + ni = fromIntegral x / 500 + upls = lsIntensity .~ V3 ni ni ni + +sensorSPic :: Machine -> SPic +sensorSPic _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth) + , mempty ) + +wdth :: Float +wdth = 10 diff --git a/src/Dodge/Placements/Turret.hs b/src/Dodge/Placements/Turret.hs new file mode 100644 index 000000000..ed0235311 --- /dev/null +++ b/src/Dodge/Placements/Turret.hs @@ -0,0 +1,96 @@ +module Dodge.Placements.Turret + where +import Color +import Dodge.Data +import Dodge.LevelGen.Data +import Dodge.Default +import Dodge.Wall.Delete +import Dodge.WorldEvent.Explosion +import Dodge.Item.Weapon.BatteryGuns +import Dodge.SoundLogic.LoadSound +import Dodge.SoundLogic +import Dodge.Data.SoundOrigin +import Geometry +import ShapePicture +import Shape +import Dodge.Base +import Dodge.Base.Collide + +import Data.List +import Control.Lens +import qualified Data.IntMap.Strict as IM + +putLasTurret :: Placement +putLasTurret = sps0 $ PutMachine blue (reverse $ square wdth) defaultMachine + { _mcDraw = drawTurret + , _mcUpdate = updateTurret + , _mcType = lasTurret + , _mcHP = 100000 + } +lasTurret :: MachineType +lasTurret = Turret + { _tuWeapon = lasGun + , _tuTurnSpeed = 0.1 + , _tuFireTime = 0 + } + +updateTurret :: Machine -> World -> World +updateTurret mc w + | _mcHP mc < 1 = w & machines %~ IM.delete mcid + & deleteWallIDs (_mcWallIDs mc) + & makeExplosionAt mcpos + | otherwise = w & doDamage & maybeFire & elecDamBranch + where + doDamage = machines . ix mcid %~ + ( (mcDamage .~ [Electrical (min 2500 $ max 0 (elecDam - 10)) 0 0 0]) + . (mcHP -~ dam) + ) + elecDamBranch + | elecDam < 10 = updateFiringStatus . doTurn + | otherwise = id + maybeFire + | _tuFireTime (_mcType mc) > 0 + = ( particles %~ (makeLaserAt 5 (mcpos + 15 *.* unitVectorAtAngle mcdir) mcdir :) ) + . soundContinue (MachineSound mcid) mcpos tone440sawtoothS (Just 1) + + | otherwise = id + mcid = _mcID mc + ypos = _crPos $ you w + mcpos = _mcPos mc + mcdir = _mcDir mc + seesYou = hasLOSIndirect mcpos ypos w + (elecDams, dams) = partition isElectrical $ _mcDamage mc + dam = sum $ map _dmAmount dams + elecDam = sum $ map _dmAmount elecDams + doTurn + | seesYou = machines . ix mcid . mcDir %~ turnTo 0.005 mcpos ypos + | otherwise = id + closeFireAngle = seesYou && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1 + updateFiringStatus + | closeFireAngle = machines . ix mcid . mcType . tuFireTime .~ 20 + | otherwise = machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1) + +turnTo :: Float -> Point2 -> Point2 -> Float -> Float +turnTo turnSpeed sp tp a + | vToTarg == V2 0 0 = a + | angleVV vToTarg vdir <= turnSpeed + = argV vToTarg + | isLHS (sp +.+ vdir) sp tp = a - turnSpeed + | otherwise = a + turnSpeed + where + vdir = unitVectorAtAngle a + vToTarg = tp -.- sp + +drawTurret :: Machine -> SPic +drawTurret mc = (rotateSH (-_mcDir mc) . colorSH blue $ upperPrismPoly 20 (square wdth) + , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc ) + ) + <> translateSPz 20 (_itFloorPict it it) + where + it = _tuWeapon $ _mcType mc + +wdth :: Float +wdth = 10 + + + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index e07d4d1c5..00eb8fa8f 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -33,9 +33,7 @@ import System.Random update :: World -> World update = (frameClock +~ 1) . functionalUpdate - -{- | - The update step. +{- | The update step. For most menus the only way to change the world is using event handling. -} functionalUpdate :: World -> World functionalUpdate w = case _menuLayers w of @@ -149,10 +147,16 @@ updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w {- Apply internal particle updates, delete 'Nothing's. -} updateParticles :: World -> World -updateParticles w = set particles (catMaybes ps) w' +updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' where (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w +updateInstantParticles :: World -> World +updateInstantParticles w = case _instantParticles w of + [] -> w + ps -> let (w',ps') = mapAccumR (\a b -> _ptUpdate b a b) (w {_instantParticles=[]}) ps + in updateInstantParticles $ w' & particles %~ (catMaybes ps' ++) + updateMachines :: World -> World updateMachines w = foldr f w (_machines w) where diff --git a/src/Dodge/Wall.hs b/src/Dodge/Wall.hs new file mode 100644 index 000000000..b8d3a2ccd --- /dev/null +++ b/src/Dodge/Wall.hs @@ -0,0 +1,8 @@ +module Dodge.Wall + ( module Dodge.Wall.Create + , module Dodge.Wall.Move + , module Dodge.Wall.Delete + ) where +import Dodge.Wall.Create +import Dodge.Wall.Move +import Dodge.Wall.Delete diff --git a/src/Dodge/Wall/Create.hs b/src/Dodge/Wall/Create.hs new file mode 100644 index 000000000..d40105b74 --- /dev/null +++ b/src/Dodge/Wall/Create.hs @@ -0,0 +1,16 @@ +module Dodge.Wall.Create + where +import Dodge.Data +import Dodge.Wall.Zone + +import Control.Lens +import qualified IntMapHelp as IM + +createWall :: Wall -> World -> (Int,World) +createWall wl w = (wlid + , w & walls %~ IM.insert wlid newwl + & insertWallInZones newwl + ) + where + newwl = wl {_wlID = wlid} + wlid = IM.newKey $ _walls w diff --git a/src/Dodge/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index a96486005..4fcc1e4cc 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -18,6 +18,7 @@ damageWall :: DamageType -> Wall -> World -> World damageWall dt wl = case _wlStructure wl of MachinePart mcid -> machines . ix mcid . mcDamage %~ (dt :) BlockPart blid -> wallEff dt wl . (blocks . ix blid %~ damageBlockWith dt) + CreaturePart crid f -> f dt wl crid _ -> wallEff dt wl {- | Damage effects on indestructible walls -} -- TODO take into account damage amount for amount of dust/sparks? diff --git a/src/Dodge/Wall/Delete.hs b/src/Dodge/Wall/Delete.hs index 4c1980a29..1ffd702c7 100644 --- a/src/Dodge/Wall/Delete.hs +++ b/src/Dodge/Wall/Delete.hs @@ -1,18 +1,24 @@ module Dodge.Wall.Delete ( deleteWallIDs + , deleteWallID ) where import Dodge.Data -import Dodge.Zone -import Geometry +import Dodge.Wall.Zone import Control.Lens import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS + +deleteWallID :: Int -> World -> World +deleteWallID i w = w & walls %~ IM.delete i + & deleteWallFromZones wl + where + wl = _walls w IM.! i + deleteWall :: Wall -> World -> World deleteWall wl = (walls %~ IM.delete i) - . (wallsZone . znObjects . ix x . ix y %~ IM.delete i) + . deleteWallFromZones wl where - (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) i = _wlID wl deleteWallIDs :: IS.IntSet -> World -> World diff --git a/src/Dodge/Wall/Move.hs b/src/Dodge/Wall/Move.hs new file mode 100644 index 000000000..5c8d858c9 --- /dev/null +++ b/src/Dodge/Wall/Move.hs @@ -0,0 +1,17 @@ +module Dodge.Wall.Move + where +import Dodge.Data +import Geometry +import Dodge.Wall.Zone + +import Control.Lens +moveWallID :: Int -> (Point2,Point2) -> World -> World +moveWallID wlid wlline w = case w ^? walls . ix wlid of + Nothing -> w + Just wl -> moveWall wlid wl wlline w +moveWall :: Int -> Wall -> (Point2,Point2) -> World -> World +moveWall wlid wl wlline w = w & walls . ix wlid .~ newwl + & deleteWallFromZones wl + & insertWallInZones newwl + where + newwl = wl {_wlLine = wlline} diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs new file mode 100644 index 000000000..408acf5c8 --- /dev/null +++ b/src/Dodge/Wall/Zone.hs @@ -0,0 +1,24 @@ +module Dodge.Wall.Zone + where +import Dodge.Data +import Geometry +import Dodge.Zone +import Dodge.Base + +import Control.Lens +import Data.Foldable + +zoneOfWall :: Wall -> [(Int,Int)] +zoneOfWall wl + | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry pHalf wlline ] + | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline + where + wlline = _wlLine wl + +insertWallInZones :: Wall -> World -> World +insertWallInZones wl = wallsZone . znObjects + %~ flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl) + +deleteWallFromZones :: Wall -> World -> World +deleteWallFromZones wl = wallsZone . znObjects + %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 5449aa430..96e376c37 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -29,8 +29,8 @@ colCrWall w c rad = _crRad c + wallBuffer p1 = _crOldPos c p2 = _crPos c - ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w - wls = wallsNearPoint p2 w + ls = IM.elems $ _wlLine <$> wls + wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w --wallPoints = map fst ls noclipIsOn = _debug_noclip $ _config w