Move towards introducing pipes, generalise blocks

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

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

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

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

src/Dodge/Data.hs

@@ -529,7 +529,6 @@ data Targeting
         , _tgID     :: Maybe Int
         , _tgActive :: Bool
         }
-
 data ItemDimension = ItemDimension
     { _dimRad    :: Float
     , _dimCenter :: Point3
@@ -921,8 +920,12 @@ data Block = Block
     { _blID         :: Int
     , _blWallIDs    :: IS.IntSet
     , _blHPs        :: [Int]
-    , _blShadows :: [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

@@ -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

@@ -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

@@ -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}
+        , _blHPs = [5,5], _blShadows = shadowsAt i, _blMaterial = bm
-    insertBlocks = flip (foldr insertBlock) is
+        , _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

@@ -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 :: Float -> Prop -> Shape
-drawGib x pr = noPic
+drawGib x pr = flesh <> skin
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat 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

@@ -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

@@ -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,12 +34,14 @@ 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
+
+loadItem :: Item -> Item
+loadItem it = case _laReloadType itcon of
     ActivePartial x 
         | x + _laLoaded itcon < itMaxAmmo -> it & itConsumption . laLoaded %~ (+ x)
             & itConsumption . laReloadState .~ Just' (_laReloadTime itcon)

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)

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)