From a7201b8fb6534ec08a66690153cdcd8b77ba6ca9 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 16 Jun 2022 02:18:22 +0100 Subject: [PATCH] Move towards introducing pipes, generalise blocks --- src/Dodge/Base/You.hs | 2 +- src/Dodge/Block.hs | 1 + src/Dodge/Block/Debris.hs | 50 ++++++++++++++++++++++++++ src/Dodge/Creature.hs | 3 -- src/Dodge/Data.hs | 15 ++++---- src/Dodge/Floor.hs | 3 +- src/Dodge/Placement/Instance/Pipe.hs | 5 +++ src/Dodge/Placement/PlaceSpot/Block.hs | 13 ++++--- src/Dodge/Prop/Gib.hs | 44 ++++------------------- src/Dodge/Prop/Moving.hs | 49 +++++++++++++++++++++++++ src/Dodge/Reloading.hs | 27 +++++++------- src/Dodge/Render/ShapePicture.hs | 1 + src/Dodge/Room/Tanks.hs | 6 ++++ 13 files changed, 154 insertions(+), 65 deletions(-) create mode 100644 src/Dodge/Block/Debris.hs create mode 100644 src/Dodge/Placement/Instance/Pipe.hs create mode 100644 src/Dodge/Prop/Moving.hs diff --git a/src/Dodge/Base/You.hs b/src/Dodge/Base/You.hs index 40f287432..bb5d9c5ac 100644 --- a/src/Dodge/Base/You.hs +++ b/src/Dodge/Base/You.hs @@ -14,4 +14,4 @@ yourInv :: World -> IM.IntMap Item yourInv w = _crInv (you w) yourInvSel :: World -> Int -yourInvSel w = _crInvSel (you w) +yourInvSel = _crInvSel . you diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index d093c6163..b2f9b1fee 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -50,6 +50,7 @@ destroyBlock bl w = w & deleteWallIDs wlids & blocks %~ IM.delete (_blID bl) & matDesSound (_blMaterial bl) pos + & _blDeath bl bl & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) where wlids = _blWallIDs bl diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs new file mode 100644 index 000000000..e783f046b --- /dev/null +++ b/src/Dodge/Block/Debris.hs @@ -0,0 +1,50 @@ +module Dodge.Block.Debris where +import Dodge.Prop.Moving +--import Dodge.Zone +import Dodge.Base +import Dodge.Data +--import Dodge.Damage +--import ShapePicture +import Shape +import Geometry +import Color +import LensHelp +import RandomHelp +import qualified Quaternion as Q +--import Data.List (zip4) + +makeBlockDebris :: BlockMaterial -> Block -> World -> World +makeBlockDebris _ bl w = w + & flip (foldr (plNew props pjID)) thedebris + & randGen .~ newg + where + (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w + f h = do + v <- randInCirc 2 + q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere + return $ someDebris + & prPos .~ _blPos bl + & pjColor .~ greyN 0.5 + & pjVel .~ v + & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & pjQuat .~ q + & pjVelZ .~ 0 + & pjPosZ .~ h + +someDebris :: Prop +someDebris = PropZ + {_prPos = 0 + ,_pjStartPos = 0 + ,_pjVel = 0 + ,_prDraw = \pr -> drawMovingShape pr (debrisShape pr) + ,_pjID = 0 + ,_pjUpdate = fallSmallBounce + ,_pjPosZ = 10 + ,_pjVelZ = 5 + ,_pjTimer = 20 + ,_pjQuat = Q.axisAngle (V3 1 0 0) 0 + ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 + ,_pjColor = white + } +debrisShape :: Prop -> Shape +debrisShape pr = colorSH (_pjColor pr) . translateSHz (-5) $ upperPrismPoly 10 $ square 5 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 87051e753..752d10782 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -77,7 +77,6 @@ miniGunCrit = defaultCreature -- , _crInv = IM.fromList [(0,autoRifle & itConsumption . ammoLoaded .~ 1000)] , _crInv = IM.fromList [(0,miniGunX 3)] -- , _crInv = IM.fromList [(0,autoRifle)] - , _crInvSel = 0 , _crRad = 10 , _crState = defaultState , _crHP = 500 @@ -96,7 +95,6 @@ longCrit = defaultCreature , _crGoal = [] } , _crInv = IM.fromList [(0,sniperRifle),(1,medkit 100)] - , _crInvSel = 0 , _crRad = 10 , _crHP = 150 } @@ -106,7 +104,6 @@ multGunCrit = defaultCreature { _crPict = basicCrPict -- , _crUpdate = stateUpdate (twitchMissAI 300 350) , _crInv = IM.fromList [(0,bangCaneX 4),(1,medkit 100)] - , _crInvSel = 0 , _crRad = 10 , _crHP = 300 , _crUpdate = defaultImpulsive [sentinelExtraWatchUpdate diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index f09101cba..44f7aa86c 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -529,7 +529,6 @@ data Targeting , _tgID :: Maybe Int , _tgActive :: Bool } - data ItemDimension = ItemDimension { _dimRad :: Float , _dimCenter :: Point3 @@ -918,11 +917,15 @@ data Prop } data Either3 a b c = E3x1 a | E3x2 b | E3x3 c data Block = Block - { _blID :: Int - , _blWallIDs :: IS.IntSet - , _blHPs :: [Int] - , _blShadows :: [Int] - , _blMaterial :: BlockMaterial + { _blID :: Int + , _blWallIDs :: IS.IntSet + , _blHPs :: [Int] + , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists + , _blMaterial :: BlockMaterial + , _blFootprint :: [Point2] + , _blPos :: Point2 + , _blDraw :: Block -> SPic + , _blDeath :: Block -> World -> World } data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 9898d05de..df59e8fa8 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -40,7 +40,8 @@ initialAnoTree :: Annotation initialAnoTree = OnwardList $ intersperse (AnTree corDoor) [ IntAnno $ AnTree . startRoom --- , AnRoom roomPillarsSquare + , AnRoom roomPillarsPassage + , AnRoom tanksPipesRoom , AnTree firstBreather -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) , AnRoom $ roomCCrits 10 diff --git a/src/Dodge/Placement/Instance/Pipe.hs b/src/Dodge/Placement/Instance/Pipe.hs new file mode 100644 index 000000000..5406cd0a1 --- /dev/null +++ b/src/Dodge/Placement/Instance/Pipe.hs @@ -0,0 +1,5 @@ +module Dodge.Placement.Instance.Pipe where +import Shape + +verticalPipe :: Float -> Shape +verticalPipe = flip upperPrismPoly $ polyCirc 4 5 diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 627420cd7..1a6a339a5 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -6,6 +6,7 @@ module Dodge.Placement.PlaceSpot.Block where import Dodge.Data import Dodge.Path +import Dodge.Block.Debris --import Dodge.LevelGen.LevelStructure import Dodge.Base import Dodge.Zone @@ -31,7 +32,9 @@ addBlock (p:ps) wl hp hps bm w & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes & walls %~ IM.union panes & blocks %~ IM.insert blid Block - {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[], _blMaterial = bm} + {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[], _blMaterial = bm + , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty + , _blDeath = makeBlockDebris bm} where blid = IM.newKey $ _blocks w lns = zip (p:ps) (ps ++ [p]) @@ -85,10 +88,12 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0 linesAt p = loopPairs $ cornersAt p wlid = IM.newKey $ _walls gw blid = IM.newKey $ _blocks gw - insertBlock i = over blocks $ IM.insert (i+blid) Block + insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i - , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm} - insertBlocks = flip (foldr insertBlock) is + , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm + , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) + , _blPos = p, _blDraw = const mempty , _blDeath = const id} + insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] visibilityAt i | i == 0 = [False,True,True ,True] diff --git a/src/Dodge/Prop/Gib.hs b/src/Dodge/Prop/Gib.hs index b096b32d6..28ffd9f98 100644 --- a/src/Dodge/Prop/Gib.hs +++ b/src/Dodge/Prop/Gib.hs @@ -1,9 +1,10 @@ module Dodge.Prop.Gib where -import Dodge.Zone +import Dodge.Prop.Moving +--import Dodge.Zone import Dodge.Base import Dodge.Data import Dodge.Damage -import ShapePicture +--import ShapePicture import Shape import Geometry import Color @@ -19,9 +20,9 @@ aGib = PropZ {_prPos = 0 ,_pjStartPos = 0 ,_pjVel = 0 - ,_prDraw = drawGib 3 + ,_prDraw = \pr -> drawMovingShape pr (drawGib 3 pr) ,_pjID = 0 - ,_pjUpdate = updateGib + ,_pjUpdate = fallSmallBounce ,_pjPosZ = 10 ,_pjVelZ = 5 ,_pjTimer = 20 @@ -29,12 +30,8 @@ aGib = PropZ ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 ,_pjColor = white } -drawGib :: Float -> Prop -> SPic -drawGib x pr = noPic - . translateSHz (_pjPosZ pr) - . uncurryV translateSHf (_prPos pr) - . overPosSH (Q.rotate (_pjQuat pr)) - $ flesh <> skin +drawGib :: Float -> Prop -> Shape +drawGib x pr = flesh <> skin where flesh = colorSH (dark $ dark red) . translateSHz (negate x) @@ -43,33 +40,6 @@ drawGib x pr = noPic . translateSH (V3 1 1 (1 - x)) $ upperPrismPoly (2*x) $ square x -updateGib :: Prop -> World -> World -updateGib pr w = w & props . ix (_pjID pr) %~ updateGib' w - -updateGib' :: World -> Prop -> Prop -updateGib' w pr - | newposz < 0 && velz < (-2) = pr - & pjVelZ %~ ((*0.5) . negate) --- & pjPos +~ (0.5*.* vel) - & updateWithVel (0.5 *.* vel) - & pjVel %~ (0.5 *.*) --- & pjPos +~ (0.5*.* vel) - | newposz < 0 = pr & pjUpdate .~ const id - & pjZ .~ 0 --- & pjQuat *~ (_pjQuatSpin pr) - | otherwise = pr - & pjVelZ -~ 1 - & pjPosZ +~ velz - & updateWithVel vel - & pjQuat *~ _pjQuatSpin pr - where - newposz = _pjPosZ pr + velz - velz = _pjVelZ pr - vel = _pjVel pr - pos = _prPos pr - updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of - Nothing -> prPos +~ v - Just (p,v') -> (prPos .~ p) . (pjVel .~ v') addCrGibs :: Creature -> World -> World addCrGibs cr w = case damageDirection $ _crDamage $ _crState cr of diff --git a/src/Dodge/Prop/Moving.hs b/src/Dodge/Prop/Moving.hs new file mode 100644 index 000000000..887e2a565 --- /dev/null +++ b/src/Dodge/Prop/Moving.hs @@ -0,0 +1,49 @@ +module Dodge.Prop.Moving where +import Dodge.Zone +import Dodge.Base +import Dodge.Data +--import Dodge.Damage +import ShapePicture +import Shape +import Geometry +--import Color +import LensHelp +--import RandomHelp +--import Dodge.Base.NewID + +import qualified Quaternion as Q +--import Data.List (zip4) + +fallSmallBounce :: Prop -> World -> World +fallSmallBounce pr w = w & props . ix (_pjID pr) %~ fallSmallBounce' w + +fallSmallBounce' :: World -> Prop -> Prop +fallSmallBounce' w pr + | newposz < 0 && velz < (-2) = pr + & pjVelZ %~ ((*0.5) . negate) +-- & pjPos +~ (0.5*.* vel) + & updateWithVel (0.5 *.* vel) + & pjVel %~ (0.5 *.*) +-- & pjPos +~ (0.5*.* vel) + | newposz < 0 = pr & pjUpdate .~ const id + & pjZ .~ 0 +-- & pjQuat *~ (_pjQuatSpin pr) + | otherwise = pr + & pjVelZ -~ 1 + & pjPosZ +~ velz + & updateWithVel vel + & pjQuat *~ _pjQuatSpin pr + where + newposz = _pjPosZ pr + velz + velz = _pjVelZ pr + vel = _pjVel pr + pos = _prPos pr + updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of + Nothing -> prPos +~ v + Just (p,v') -> (prPos .~ p) . (pjVel .~ v') + +drawMovingShape :: Prop -> Shape -> SPic +drawMovingShape pr = noPic + . translateSHz (_pjPosZ pr) + . uncurryV translateSHf (_prPos pr) + . overPosSH (Q.rotate (_pjQuat pr)) diff --git a/src/Dodge/Reloading.hs b/src/Dodge/Reloading.hs index 73f60711e..ace987d88 100644 --- a/src/Dodge/Reloading.hs +++ b/src/Dodge/Reloading.hs @@ -7,11 +7,10 @@ import Dodge.Data import Dodge.Base --import qualified Data.IntMap.Strict as IM ---import Data.Maybe import Control.Lens startReloadingWeapon :: Creature -> World -> Maybe World -startReloadingWeapon cr = (creatures . ix (_crID cr) . crInv . ix (_crInvSel cr)) +startReloadingWeapon cr = creatures . ix (_crID cr) . crInv . ix (_crInvSel cr) %%~ icTryStartReloading -- TODO clean this up, rethink datatypes @@ -35,22 +34,24 @@ crStopReloading cr = cr & crInv . ix (_crInvSel cr) . itConsumption . laReloadSt -- ugly TODO cleanup stepReloading :: Creature -> Creature stepReloading cr = case cr ^? crInv . ix isel . itConsumption . laReloadState . _Just' of - Just 0 -> cr & crInv . ix isel %~ doload + Just 0 -> cr & crInv . ix isel %~ loadItem Just _ -> cr & crInv . ix isel . itConsumption . laReloadState . _Just' %~ decreaseToZero Nothing -> cr where isel = _crInvSel cr - doload it = case _laReloadType itcon of - ActivePartial x - | x + _laLoaded itcon < itMaxAmmo -> it & itConsumption . laLoaded %~ (+ x) - & itConsumption . laReloadState .~ Just' (_laReloadTime itcon) - | otherwise -> it & itConsumption . laLoaded .~ itMaxAmmo - & itConsumption . laReloadState .~ Nothing' - _ -> it & itConsumption . laLoaded .~ itMaxAmmo + +loadItem :: Item -> Item +loadItem it = case _laReloadType itcon of + ActivePartial x + | x + _laLoaded itcon < itMaxAmmo -> it & itConsumption . laLoaded %~ (+ x) + & itConsumption . laReloadState .~ Just' (_laReloadTime itcon) + | otherwise -> it & itConsumption . laLoaded .~ itMaxAmmo & itConsumption . laReloadState .~ Nothing' - where - itcon = _itConsumption it - itMaxAmmo = _laMax itcon + _ -> it & itConsumption . laLoaded .~ itMaxAmmo + & itConsumption . laReloadState .~ Nothing' + where + itcon = _itConsumption it + itMaxAmmo = _laMax itcon --{- | Start reloading if clip is empty. -} --crAutoReload :: Creature -> Creature diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 9a9b82480..500bb8132 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -32,6 +32,7 @@ worldSPic :: Configuration -> World -> SPic worldSPic cfig w = (extraShapes w, extraPics cfig w) <> foldMap (dbArg _prDraw) (filtOn _prPos _props) + <> foldMap (dbArg _blDraw) (filtOn _blPos _blocks) <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses) <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures) <> foldMap floorItemSPic (filtOn _flItPos _floorItems) diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index 9e13eb04c..70a340830 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -29,6 +29,12 @@ randomTank = takeOne $ map (\f -> f (dim orange) orange) , tankSquareDec plusDecoration ] +tanksPipesRoom :: RandomGen g => State g Room +tanksPipesRoom = do + thetank <- randomTank + let rm = roomRectAutoLinks 200 400 & rmPmnts .:~ thetank + return rm + tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room tanksRoom crs its = do w <- state $ randomR (100,400)