diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index 62fea7114..f52ab137b 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -1,39 +1,36 @@ {-# LANGUAGE LambdaCase #-} -module Dodge.Block ( - splinterBlock, - destroyBlock, -) where +module Dodge.Block (destroyBlock) where import qualified Data.Set as S import Control.Lens import Control.Monad import Data.Foldable -import qualified Data.IntSet as IS +--import qualified Data.IntSet as IS import Data.Maybe import Dodge.Base.Collide import Dodge.Block.Debris import Dodge.Data.World -import Dodge.Material.Sound +--import Dodge.Material.Sound import Dodge.Path import Dodge.Wall.Delete import Dodge.Wall.Zone -import Dodge.WorldEvent.Sound +--import Dodge.WorldEvent.Sound import Dodge.Zoning.Wall import qualified IntMapHelp as IM -splinterBlock :: Block -> World -> World -splinterBlock bl w = - foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) - & soundOriginsIDsAt - [MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2] - (weakenMatS bm) - (_blPos bl) - where - bm = fromMaybe Stone $ do - wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs - (wlid, _) <- IS.minView wlids - w ^? cWorld . lWorld . walls . ix wlid . wlMaterial +--splinterBlock :: Block -> World -> World +--splinterBlock bl w = +-- foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) +-- & soundOriginsIDsAt +-- [MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2] +-- (weakenMatS bm) +-- (_blPos bl) +-- where +-- bm = fromMaybe Stone $ do +-- wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs +-- (wlid, _) <- IS.minView wlids +-- w ^? cWorld . lWorld . walls . ix wlid . wlMaterial unshadowBlock :: World -> Int -> World unshadowBlock w wlid = case w ^? cWorld . lWorld . walls . ix wlid of diff --git a/src/Dodge/Data/Block.hs b/src/Dodge/Data/Block.hs index eacf88665..121427fde 100644 --- a/src/Dodge/Data/Block.hs +++ b/src/Dodge/Data/Block.hs @@ -21,13 +21,13 @@ data Block = Block { _blID :: Int , _blWallIDs :: IS.IntSet , _blHP :: Int - , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists + , _blShadows :: [Int] -- a list of walls that are not shown when this block exists , _blFootprint :: [Point2] -- TODO check whether this should be clockwise/anticlockwise , _blPos :: Point2 , _blDir :: Float , _blHeight :: Float , _blMaterial :: Material - , _blDraw :: BlockDraw --Block -> SPic + , _blDraw :: BlockDraw , _blObstructs :: [(Int,Int)] } deriving (Eq, Ord, Show, Read) --Generic, Flat) diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 7cd51b0b9..f861e95c4 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -1,38 +1,40 @@ module Dodge.Item.Weapon.Shatter (shootShatter) where -import Linear -import Dodge.Base.Collide -import Dodge.Block.Debris +--import Linear +--import Dodge.Base.Collide +--import Dodge.Block.Debris import Dodge.Data.World -import Dodge.Wall.Damage -import Geometry -import LensHelp +--import Dodge.Wall.Damage +--import Geometry +--import LensHelp shootShatter :: Item -> Creature -> World -> World -shootShatter _ cr w = - maybe w (uncurry $ shatterWall w sp ep) $ - sequence $ - collidePointWallsFilter canshatter sp ep w - where - canshatter wl = case _wlOpacity wl of - Opaque {} -> True - SeeThrough -> True - _ -> False - sp = cr ^. crPos ._xy +.+ 10 *.* unitVectorAtAngle dir - -- the 10 is arbtrary and should be changed to a muzzle position - dir = _crDir cr - ep = sp +.+ 200 *.* unitVectorAtAngle dir - -shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World -shatterWall w sp ep p wl = - w --- & makeDebris (_wlMaterial wl) (_wlColor wl) p - & makeDebris (_wlMaterial wl) p - & makeDebrisDirected - (pi / 2) - (argV $ vNormal $ uncurry (-) $ _wlLine wl) - (_wlMaterial wl) --- (_wlColor wl) - p - & damageWall (Shattering 1000 p (ep - sp)) wl +shootShatter _ _ w = w +--shootShatter _ cr w = +-- maybe w (uncurry $ shatterWall w sp ep) $ +-- sequence $ +-- collidePointWallsFilter canshatter sp ep w +-- where +-- canshatter wl = case _wlOpacity wl of +-- Opaque {} -> True +-- SeeThrough -> True +-- _ -> False +-- sp = cr ^. crPos ._xy +.+ 10 *.* unitVectorAtAngle dir +-- -- the 10 is arbtrary and should be changed to a muzzle position +-- dir = _crDir cr +-- ep = sp +.+ 200 *.* unitVectorAtAngle dir +-- +--shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World +----shatterWall w sp ep p wl = +--shatterWall w sp ep p wl = +-- w +---- & makeDebris (_wlMaterial wl) (_wlColor wl) p +-- & makeDebris (_wlMaterial wl) p +-- & makeDebrisDirected +-- (pi / 2) +-- (argV $ vNormal $ uncurry (-) $ _wlLine wl) +-- (_wlMaterial wl) +---- (_wlColor wl) +-- p +---- & damageWall (Shattering 1000 p (ep - sp)) wl diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 8a27001cf..f1d241aed 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -6,15 +6,15 @@ -} module Dodge.Placement.PlaceSpot (placeSpot) where -import Dodge.Default.Wall -import qualified Data.Set as S import Control.Monad.State import Data.Bifunctor import Data.Foldable import qualified Data.IntSet as IS import Data.Maybe +import qualified Data.Set as S import Dodge.Base.NewID import Dodge.Data.GenWorld +import Dodge.Default.Wall import Dodge.Path import Dodge.Placement.PlaceSpot.Block import Dodge.Placement.PlaceSpot.TriggerDoor @@ -134,7 +134,7 @@ placeSpotID rid ps pt w = case pt of PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w - PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2) w + PutDoor eo f l p1 p2 -> plDoor eo f l (pashift p1) (pashift p2) w PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w PutSlideDr wl dr eo off a b -> plSlideDoor wl dr eo off (doShift a) (doShift b) w @@ -165,7 +165,7 @@ placeChasm gw rid ps shiftps = & gwWorld %~ f where f w = foldl' g w (loopPairs shiftps) - g w (x,y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w + g w (x, y) = fst $ obstructPathsCrossing (S.singleton ChasmObstacle) x y w --evaluateRandPS -- :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld) @@ -211,51 +211,24 @@ plMachine :: Float -> GenWorld -> (Int, GenWorld) -plMachine wallpoly mc = \case - Nothing -> plMachine' wallpoly mc - Just itm -> plTurret wallpoly mc itm - -plTurret :: - [Point2] -> - Machine -> --- Wall -> - Item -> - Point2 -> - Float -> - GenWorld -> - (Int, GenWorld) -plTurret wallpoly mc itm p rot gw = +plMachine wallpoly mc mitm p rot gw = ( mcid - , gw & gwWorld . cWorld . lWorld . machines %~ addMc - & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid - & gwWorld . cWorld . lWorld . items . at itid ?~ itm' + , gw & tolw . machines . at mcid ?~ themc + & tolw . walls %~ placeMachineWalls wallpoly mcid wlid + & tolw %~ maybe id placeturretitm mitm ) where - itm' = - itm & itID .~ NInt itid - & itLocation .~ OnTurret mcid - itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items + tolw = gwWorld . cWorld . lWorld mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls - wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] - addMc = - IM.insert - mcid - ( mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids} - & mcType . mctTurret . tuWeapon .~ itid - ) - -plMachine' :: [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int, GenWorld) -plMachine' wallpoly mc p rot gw = - ( mcid - , gw & gwWorld . cWorld . lWorld . machines %~ addMc - & gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid - ) - where - mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines - wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls - wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] - addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}) + wlids = IS.fromList $ take (length wallpoly) [wlid ..] + themc = mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids} + placeturretitm itm = + (items . at itid ?~ itm') + . (machines . ix mcid . mcType . mctTurret . tuWeapon .~ itid) + where + itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items + itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid -- TODO correctly remove/shift pathfinding lines (removePathsCrossing) placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 8d62eef31..4e96152ee 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -250,7 +250,6 @@ functionalUpdate = . over uvWorld updateCreatureSoundPositions . colCrsWalls . over uvWorld simpleCrSprings --- . over uvWorld (updateIMl' (_doors . _lWorld . _cWorld) updateDoor) . over uvWorld updateDoors . over uvWorld doWorldEvents . over uvWorld updateDelayedEvents @@ -290,8 +289,7 @@ functionalUpdate = -- creatures should be updated early so that crOldPos is set before any position change . over (uvWorld . cWorld . lWorld . creatures) (fmap setOldPos) . over uvWorld updateCreatureGroups - . over uvWorld updateWallDamages - -- . over uvWorld updateSeenWalls + . over uvWorld updateWallDamages -- can potentially be combined in some way with update doors so that only one pathing update needs to be done... . over uvWorld checkTermDist . over uvWorld updateRBList . over uvWorld updateCloseObjects diff --git a/src/Dodge/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index 485788e01..28068242c 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -1,10 +1,7 @@ {- | Controls a walls response to external damage. - Indestructible walls may still produce sparks, dust etc -} -module Dodge.Wall.Damage ( --- damageBlocksBy, - damageWall, -) where +module Dodge.Wall.Damage (damageWall) where import Dodge.Material.Damage import Dodge.Block