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

Move towards introducing pipes, generalise blocks

Browse Source
This commit is contained in:
justin
2022-06-16 02:18:22 +01:00
parent f404f32241
commit a7201b8fb6
13 changed files with 154 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/You.hs
+1 -1
View File
@@ -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
src/Dodge/Block.hs
+1
View File
@@ -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
src/Dodge/Block/Debris.hs
+50
View File
@@ -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
src/Dodge/Creature.hs
-3
View File
@@ -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
src/Dodge/Data.hs
+9 -6
View File
@@ -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
src/Dodge/Floor.hs
+2 -1
View File
@@ -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
src/Dodge/Placement/Instance/Pipe.hs
+5
View File
@@ -0,0 +1,5 @@
module Dodge.Placement.Instance.Pipe where
import Shape
verticalPipe :: Float -> Shape
verticalPipe = flip upperPrismPoly $ polyCirc 4 5
src/Dodge/Placement/PlaceSpot/Block.hs
+9 -4
View File
@@ -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]
src/Dodge/Prop/Gib.hs
+7 -37
View File
@@ -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
src/Dodge/Prop/Moving.hs
+49
View File
@@ -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))
src/Dodge/Reloading.hs
+14 -13
View File
@@ -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
src/Dodge/Render/ShapePicture.hs
+1
View File
@@ -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)
src/Dodge/Room/Tanks.hs
+6
View File
@@ -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)