Improve debris slightly

2026-03-31 21:57:15 +01:00
parent 5701261ace
commit 074d354970
8 changed files with 227 additions and 210 deletions
@@ -5,14 +5,17 @@ module Dodge.Block.Debris (
    makeBlockDebris,
    makeDebris,
    makeDebrisDirected,
+    makeMachineDebris,
 ) where

+import Control.Monad
+import Dodge.Machine.Draw
+import Color
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.Maybe
 import Dodge.Data.World
-import Dodge.Material.Color
 import Dodge.Material.Sound
 import Dodge.ShiftPoint
 import Dodge.WorldEvent.Sound
@@ -23,8 +26,20 @@ import qualified Quaternion as Q
 import RandomHelp
 import Shape

+makeMachineDebris :: Machine -> World -> World
+makeMachineDebris mc w = foldl' (flip $ makeDebrisZ 20 (MetalDebris $ mcColor mc) mt) w ps
+  where
+    pa = (mc ^. mcPos, mc ^. mcDir)
+    dsize = debrisSize mt
+    ps = fmap (shiftPointBy pa) 
+        . gridInPolygon dsize 
+        . shrinkPolyOnEdges dsize 
+        $ reverse (fst <$> mc ^.. mcFootPrint . each)
+    mt = mc ^. mcSkin
+
+
 makeDoorDebris :: Door -> World -> World
-makeDoorDebris dr w = w & makeDebris mt p
+makeDoorDebris dr w = w & makeDebris (BlockDebris drcol) mt p
  where
    p2a = lerpP2A (dr ^. drZeroPos) (dr ^. drOnePos) (dr ^. drLerp)
    p = centroid . fmap fst $ (dr ^. drFootPrint) & each . each %~ shiftPointBy p2a
@@ -32,9 +47,15 @@ makeDoorDebris dr w = w & makeDebris mt p
        wlids <- w ^? cWorld . lWorld . doors . ix (_drID dr) . drFootPrint
        ((wlid, _), _) <- IM.minViewWithKey wlids
        w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
+    drcol = case dr ^. drTrigger of
+        WdBlCrFilterNearPoint {} -> yellow
+        _ -> red
+
+blColor :: Block -> Color
+blColor _ = orange

 makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
+makeBlockDebris bl w = foldl' (flip $ makeDebris (BlockDebris $ blColor bl) mt) w ps
  where
    dsize = debrisSize mt
    ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
@@ -45,21 +66,38 @@ makeBlockDebris bl w = foldl' (flip $ makeDebris mt) w ps
        return $ _wlMaterial wl

 -- makeDebris :: Material -> Color -> Point2 -> World -> World
-makeDebris :: Material -> Point2 -> World -> World
+makeDebris :: DebrisType -> Material -> Point2 -> World -> World
 makeDebris = makeDebrisDirected (2 * pi) 0

-makeDebrisDirected :: Float -> Float -> Material -> Point2 -> World -> World
-- makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
-- makeDebrisDirected arcrad dir bm col p w =
-makeDebrisDirected arcrad dir bm p w =
+makeDebrisZ :: Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisZ = makeDebrisDirectedZ (2 * pi) 0
+
+makeDebrisDirectedZ :: Float -> Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisDirectedZ arcrad dir z dt bm p w =
    w
-        --        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
-        & cWorld
-        . lWorld
-        . debris
-        <>~ thedebris
-        & randGen
-        .~ newg
+        & cWorld . lWorld . debris <>~ thedebris
+        & randGen .~ newg
+        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
+  where
+    (thedebris, newg) = replicateM 4 f & runState $ _randGen w
+    f = do
+        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
+        spinspeed <- randomR (-0.2, -0.1) & state
+        --        basedebris <- baseDebris bm
+        return $
+            DebrisChunk
+                { _dbPos = p `v2z` z
+                , _dbType = dt
+                , _dbVel = v `v2z` 0
+                , _dbRot = Q.qID
+                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
+                }
+
+makeDebrisDirected :: Float -> Float -> DebrisType -> Material -> Point2 -> World -> World
+makeDebrisDirected arcrad dir dt bm p w =
+    w
+        & cWorld . lWorld . debris <>~ thedebris
+        & randGen .~ newg
        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
  where
    (thedebris, newg) = mapM f [35, 55, 75, 95] & runState $ _randGen w
@@ -70,8 +108,7 @@ makeDebrisDirected arcrad dir bm p w =
        return $
            DebrisChunk
                { _dbPos = p `v2z` h
-                , --            , _dbType = BlockDebris col
-                  _dbType = BlockDebris (materialColor bm)
+                , _dbType = dt
                , _dbVel = v `v2z` 0
                , _dbRot = Q.qID
                , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) spinspeed
@@ -12,6 +12,7 @@ module Dodge.Data.Machine (
    module Dodge.Data.GenParams,
 ) where

+import Color.Data
 import ShortShow
 import Dodge.Data.AmmoType
 import Control.Lens
@@ -21,6 +21,7 @@ data Prop = ShapeProp
 data DebrisType
    = Gib { _gibSize :: Float , _gibColor :: Color }
    | BlockDebris {_bdColor :: Color}
+    | MetalDebris {_bdColor :: Color}

 data Debris = DebrisChunk
    { _dbPos :: Point3
@@ -1,6 +1,7 @@
-module Dodge.Machine.Destroy where
+module Dodge.Machine.Destroy (destroyMachine) where

-import Geometry.Vector3D
+import Linear
+import Dodge.Block.Debris
 import Dodge.FloorItem
 import Data.Maybe
 import Dodge.Data.World
@@ -15,7 +16,7 @@ destroyMachine mc =
    (cWorld . lWorld . machines %~ IM.delete (_mcID mc))
        . deleteWallIDs (IM.keysSet $ _mcFootPrint mc)
        . makeMachineDebris mc
-        . makeSmallExplosionAt (_mcPos mc `v2z` 20) 0
+        . makeSmallExplosionAt (20 & _xy .~ _mcPos mc) 0
        . mcKillTerm mc
        . mcKillBut mc
        . destroyMcType (mc ^. mcType) mc
@@ -23,18 +24,6 @@ destroyMachine mc =
 --explodeMachine :: Machine -> MachineType -> World -> World
 --explodeMachine mc = \case

-makeMachineDebris :: Machine -> World -> World
-makeMachineDebris _ = id -- foldl' (flip $ makeDebris mt) w ps
--makeMachineDebris mc = id -- foldl' (flip $ makeDebris mt) w ps
--  where
--    dsize = debrisSize mt
--    ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_mcFootprint bl)
--    mt = fromMaybe Stone $ do
--        wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
--        (wlid, _) <- IS.minView wlids
--        wl <- w ^? cWorld . lWorld . walls . ix wlid
--        return $ _wlMaterial wl
-
 destroyMcType :: MachineType -> Machine -> World -> World
 destroyMcType mt mc w = case mt of
    McTurret tu _ -> fromMaybe w $ do
@@ -1,4 +1,4 @@
-module Dodge.Machine.Draw (drawMachine) where
+module Dodge.Machine.Draw (drawMachine,mcColor) where

 import Control.Lens
 import qualified Data.Map.Strict as M
@@ -110,23 +110,13 @@ placeSpotID rid ps pt w = case pt of
        let i = IM.newKey (w ^. gwWorld . cWorld . lWorld . items)
         in ( i
            , w
-                & gwWorld
-                . cWorld
-                . lWorld
-                . floorItems
-                . at i
-                ?~ FlIt p rot
-                & gwWorld
-                . cWorld
-                . lWorld
-                . items
-                . at i
-                ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor)
+                & gwWorld . cWorld . lWorld . floorItems . at i ?~ FlIt p rot
+                & gwWorld . cWorld . lWorld . items . at i ?~ (itm & itID .~ NInt i & itLocation .~ OnFloor)
            )
    PutCrit cr -> plNewUpID (gwWorld . cWorld . lWorld . creatures) crID (mvCr p rot cr) w
    PutForeground fs ->
        (0, w & gwWorld . cWorld . lWorld . foreShapes .:~ mvFS p rot fs)
-    PutMachine mc mitm -> plMachine mc mitm p rot w
+    PutMachine mc mitm -> plMachine (mc & mcPos .~ p & mcDir .~ rot) mitm 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 dr wl -> plDoor (dr & drZeroPos %~ pashift & drOnePos %~ pashift) wl w
@@ -161,7 +151,6 @@ placeChasm rid ps shiftps cfs =
        . (genRooms . ix rid . rmPos %~ filter (\rp -> not $ any (pointInPoly (_rpPos rp)) ps))
        . (gwWorld %~ f)
  where
-    -- f w = foldl' g w (loopPairs shiftps)
    f w = foldl' g w cfs
    g w (x, y) = obstructPathsCrossing (S.singleton ChasmObstacle) x y w

@@ -188,22 +177,20 @@ mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
 mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +) . rotateV a))

 plMachine ::
--    [Point2] ->
    Machine ->
    Maybe Item ->
-    Point2 ->
-    Float ->
    GenWorld ->
    (Int, GenWorld)
-plMachine mc mitm p rot gw =
+plMachine mc mitm gw =
    ( mcid
    , gw
        & tolw . machines . at mcid ?~ themc
        & tolw %~ maybe id placeturretitm mitm
        & gwWorld %~ addwalls
-        -- & gwWorld %~ placeMachineWalls (_mcSkin mc) wallpoly mcid wlid
    )
  where
+    p = mc ^. mcPos
+    rot = mc ^. mcDir
    addwalls =
        insertStructureWalls
            MachinePart
@@ -220,8 +207,6 @@ plMachine mc mitm p rot gw =
    mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
    wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
    themc = mc
-        & mcPos .~ p
-        & mcDir .~ rot  
        & mcID .~ mcid
        & mcFootPrint .~ IM.fromDistinctAscList (zip [wlid..] pps)
    placeturretitm itm =
@@ -12,12 +12,16 @@ import Picture
 import qualified Quaternion as Q
 import Shape
 import ShapePicture
+import Linear

 debrisSPic :: Debris -> SPic
-debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
+debrisSPic db = translateSP (_dbPos db & _z +~ 1) . overPosSP (Q.rotate (_dbRot db)) $
    case db ^. dbType of
        Gib x col -> noPic $ drawGib x col
        BlockDebris m -> noPic . colorSH m $ cubeShape 4
+        --MetalDebris c -> noPic . colorSH c $ upperPrismPolySU 1 $ [0, V2 5 0, V2 4 2]
+        MetalDebris c -> noPic . colorSH c $ upperPrismPolySU 1 $ [0, V2 8 0, V2 6 3]
+        --MetalDebris c -> noPic . colorSH c $ upperPrismPolySU 1 $ [0, V2 10 0, V2 8 4]

 propSPic :: Prop -> SPic
 propSPic pr =