Work on bouncing debris

2025-08-02 22:14:25 +01:00
parent eeb7c8ac88
commit 5722ca8204
13 changed files with 141 additions and 1090 deletions
@@ -91,8 +91,8 @@ collide3 sp ep w = collide3Floors sp (w ^. cWorld . chasms)
 collide3Walls :: Point3 -> World -> (Point3, Maybe Point3) -> (Point3, Maybe Point3)
 collide3Walls sp w (ep,mn) = collide3Part sp wsfs (ep,mn)
  where
-    wsfs = fmap f $ wlsNearSeg (xyV3 sp) (xyV3 ep) w
-    f wl = (g x, g $ vNormal (y-x), [(g x,g (y-x)),(g y,g (x-y))])
+    wsfs = f <$> wlsNearSeg (xyV3 sp) (xyV3 ep) w
+    f wl = (g x, g $ vNormal (x-y), [(g x,g (y-x)),(g y,g (x-y))])
      where
        g = (`v2z` 0)
        (x,y) = _wlLine wl
@@ -104,7 +104,7 @@ collide3Floors sp cs (ep,mn) = maybe (ep,mn) (,Just (V3 0 0 1)) mp
        V3 x y z <- intersectSegPlane sp ep (V3 0 0 0) (V3 0 0 1)
        let g (a,b) = isRHS a b (V2 x y)
            f = any g
-        guard (all f $ map loopPairs cs)
+        guard (all (f . loopPairs) cs)
        return $ V3 x y z

 collide3Part :: Point3 -> [(Point3,Point3,[(Point3,Point3)])] 
@@ -1,4 +1,11 @@
-module Dodge.Block.Debris where
+module Dodge.Block.Debris (
+    cubeShape,
+    dirtColor,
+    makeDoorDebris,
+    makeBlockDebris,
+    makeDebris,
+    makeDebrisDirected,
+) where

 import Color
 import Data.Foldable
@@ -36,57 +43,11 @@ makeBlockDebris bl w = foldl' (flip $ makeDebris mt col) w ps
        wl <- w ^? cWorld . lWorld . walls . ix wlid
        return (_wlMaterial wl, _wlColor wl)

-makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World
-makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2 * pi) 0
-
 makeDebris :: Material -> Color -> Point2 -> World -> World
-makeDebris = makeDebrisDirected 1 2 (2 * pi) 0
+makeDebris = makeDebrisDirected (2 * pi) 0

-makeDebrisDirectedHeight ::
-    Float ->
-    Float ->
-    Float ->
-    Float ->
-    Float ->
-    Material ->
-    Color ->
-    Point2 ->
-    World ->
-    World
-makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w =
-    w
-        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
-        & randGen .~ newg
-        & soundOriginsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
-  where
-    dsize = debrisSize bm
-    (thedebris, newg) = mapM f [10, 10 + dsize .. maxh + 5] & runState $ _randGen w
-    f h = do
-        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
-        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
-        spinspeed <- randomR (-0.2, -0.1) & state
-        basedebris <- baseDebris bm
-        return $
-            basedebris
-                & prColor .~ col
-                & prPos .~ p
-                & prVel .~ v
-                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
-                & prQuat .~ q
-                & prVelZ .~ 0
-                & prPosZ .~ h
-
-makeDebrisDirected ::
-    Float ->
-    Float ->
-    Float ->
-    Float ->
-    Material ->
-    Color ->
-    Point2 ->
-    World ->
-    World
-makeDebrisDirected mindist maxdist arcrad dir bm col p w =
+makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
+makeDebrisDirected arcrad dir bm col p w =
    w
        & flip (foldl' (flip $ plNew (cWorld . lWorld . props) prID)) thedebris
        & randGen .~ newg
@@ -94,7 +55,7 @@ makeDebrisDirected mindist maxdist arcrad dir bm col p w =
  where
    (thedebris, newg) = mapM f [35, 55 .. 95] & runState $ _randGen w
    f h = do
-        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
+        v <- rotateV (dir - arcrad / 2) <$> randInArcStrip 1 2 arcrad
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        spinspeed <- randomR (-0.2, -0.1) & state
        basedebris <- baseDebris bm
@@ -1,5 +1,5 @@
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}

 module Dodge.Data.Object where

@@ -44,6 +44,7 @@ data DebrisType =
    Gib {_gibSize :: Float
        ,_gibColor :: Color
        }
+    | BlockDebris {_bdMaterial :: Material}

 data Debris = DebrisChunk
        { _dbPos :: Point3
@@ -64,7 +65,7 @@ data PropDraw
    | PropVerticalLampCover Float
    | PropLampCover Float
    | PropDrawToggle PropDraw
-    | PropDrawGib Float
+--    | PropDrawGib Float
    --deriving (Eq, Ord, Show, Read) --Generic, Flat)

 data PropUpdate
@@ -28,8 +28,6 @@ shatterWall w sp ep p wl =
    w
        & makeDebris (_wlMaterial wl) (_wlColor wl) p
        & makeDebrisDirected
-            1
-            2
            (pi / 2)
            (argV $ vNormal $ uncurry (-) $ _wlLine wl)
            (_wlMaterial wl)
@@ -0,0 +1,18 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Dodge.Material.Color (materialColor) where
+
+import Dodge.Data.Material
+import Color
+
+materialColor :: Material -> Color
+materialColor =
+    withAlpha 0.5 . \case
+        Wood -> dark yellow
+        Dirt -> dark $ dark orange
+        Stone -> greyN 0.5
+        Glass -> white
+        Metal -> orange
+        Crystal -> green
+        Flesh -> red
+        Electronics -> greyN 0.2
@@ -4,6 +4,8 @@ module Dodge.Prop.Draw (
    debrisSPic,
 ) where

+import Dodge.Material.Color
+import Dodge.Block.Debris
 import Control.Lens
 import Dodge.Data.Prop
 import Geometry.Data
@@ -19,7 +21,8 @@ propSPic pr = drawProp (_prDraw pr) pr
 debrisSPic :: Debris -> SPic
 debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
     case db ^. dbType of
-        Gib x col -> noPic $ drawGib' x col
+        Gib x col -> noPic $ drawGib x col
+        BlockDebris m -> noPic . colorSH (materialColor m) $ cubeShape 4

 drawProp :: PropDraw -> Prop -> SPic
 drawProp = \case
@@ -30,23 +33,12 @@ drawProp = \case
    PropVerticalLampCover h -> drawVerticalLampCover h
    PropLampCover h -> drawLampCover h
    PropDrawToggle pd' -> propDrawToggle pd'
-    PropDrawGib x -> noPic . drawGib x
+--    PropDrawGib x -> noPic . drawGib x
    PropDrawFlatTranslate x -> \pr ->
        uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr

-drawGib :: Float -> Prop -> Shape
-drawGib x pr = flesh <> skin
-  where
-    flesh =
-        colorSH (dark $ dark red) $
-            translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
-    skin =
-        colorSH (_prColor pr) $
-            translateSH (V3 1 1 (1 - x)) baseCube
-    baseCube = upperPrismPoly Small Typical (2 * x) $ square x
-
-drawGib' :: Float -> Color -> Shape
-drawGib' x col = flesh <> skin
+drawGib :: Float -> Color -> Shape
+drawGib x col = flesh <> skin
  where
    flesh =
        colorSH (dark $ dark red) $
@@ -7,7 +7,6 @@ import Color
 import Control.Monad
 import Data.Foldable
 import Data.List (zip4)
-import Dodge.Base
 import Dodge.Damage
 import Dodge.Data.World
 import Geometry
@@ -15,58 +14,29 @@ import LensHelp
 import qualified Quaternion as Q
 import RandomHelp

-aGib :: Prop
-aGib =
-    PropZ
-        { _prPos = 0
-        , _prStartPos = 0
-        , _prVel = 0
-        , _prDraw = PropDrawMovingShape (PropDrawGib 3)
-        , _prID = 0
-        , _prUpdate = PropFallSmallBounce
-        , _prPosZ = 10
-        , _prVelZ = 5
-        , _prQuat = Q.axisAngle (V3 1 0 0) 0
-        , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-        , _prColor = white
-        }
-
 addCrGibs :: Creature -> World -> World
 addCrGibs cr = case damageDirection $ _crDamage cr of
    Nothing ->
            addGibAt 25 (_skinHead skin) cpos
-            . addGibsAt 3 7 (_skinLower skin) cpos
-            . addGibsAt 13 20 (_skinUpper skin) cpos
-    Just d ->
-            addGibsAtDir d 3 7 (_skinLower skin) cpos
-            . addGibsAtDir d 13 20 (_skinUpper skin) cpos
+            . addGibsAtDir pi 0 3 7 (_skinLower skin) cpos
+            . addGibsAtDir pi 0 13 20 (_skinUpper skin) cpos
+    Just d -> (testFloat +~ 1)
+            . addGibsAtDir (pi/4) d 3 7 (_skinLower skin) cpos
+            . addGibsAtDir (pi/4) d 13 20 (_skinUpper skin) cpos
            . addGibAtDir d 25 (_skinHead skin) cpos
  where
    skin = crShape $ _crType cr -- this should be cleaned up
    cpos = _crPos cr

-addGibsAt :: Float -> Float -> Color -> Point2 -> World -> World
-addGibsAt minh maxh col p w =
-    foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
-        & randGen .~ newg
-  where
-    (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w
-    hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w
-    dirs = unitVectorAtAngle <$> (randsOnCirc 4 & evalState $ _randGen w)
-    vels = zipWith (*.*) speeds dirs
-    zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
-    quats :: [Q.Quaternion Float]
-    quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
-
 -- this is ugly because it is mostly copy-paste from addGibsAt
-addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World
-addGibsAtDir dir minh maxh col p w =
+addGibsAtDir :: Float -> Float -> Float -> Float -> Color -> Point2 -> World -> World
+addGibsAtDir spread dir minh maxh col p w =
    foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
        & randGen .~ newg
  where
    (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w
    hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w
-    dirs = unitVectorAtAngle <$> (randsSpread (dir - pi / 4, dir + pi / 4) 4 & evalState $ _randGen w)
+    dirs = unitVectorAtAngle <$> (randsSpread (dir - spread, dir + spread) 4 & evalState $ _randGen w)
    vels = zipWith (*.*) speeds dirs
    zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
    quats :: [Q.Quaternion Float]
@@ -82,60 +52,10 @@ addGib4 p col (v, zs, q, h) = cWorld . lWorld . debris
            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
            }
            
-addGib4' :: Point2 -> Color -> (Point2, Float, QFloat, Float) -> World -> World
-addGib4' p col (v, zs, q, h) =
-    plNew
-        (cWorld . lWorld . props)
-        prID
-        ( aGib & prPos .~ p +.+ (5 *.* normalizeV v)
-            & prColor .~ col
-            & prVel .~ v
-            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & prQuat .~ q
-            & prVelZ .~ zs
-            & prPosZ .~ h
-        )
-
 addGibAt :: Float -> Color -> Point2 -> World -> World
 addGibAt h col p w = addGibAtDir d h col p (w & randGen .~ newg)
  where
    (d, newg) = randomR (0, 2 * pi) $ _randGen w
--    f = do
--        s <- state $ randomR (1, 4)
--        dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi))
--        zs <- state $ randomR (-8, 8)
--        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
--        let v = s *.* dir
--        return $ DebrisChunk
--            { _dbPos = p `v2z` h
--            , _dbType = Gib 3 col
--            , _dbVel = v `v2z` zs
--            , _dbRot = q
--            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
--            }
-
-addGibAt' :: Float -> Color -> Point2 -> World -> World
-addGibAt' h col p w =
-    w
-        & plNew (cWorld . lWorld . props) prID gib
-        & randGen .~ newg
-  where
-    (gib, newg) = runState f $ _randGen w
-    f = do
-        s <- state $ randomR (1, 4)
-        dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi))
-        zs <- state $ randomR (-8, 8)
-        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
-        let v = s *.* dir
-        return $
-            aGib
-                & prPos .~ p
-                & prColor .~ col
-                & prVel .~ v
-                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-                & prQuat .~ q
-                & prVelZ .~ zs
-                & prPosZ .~ h

 addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
 addGibAtDir dir h col p w =
@@ -150,31 +70,9 @@ addGibAtDir dir h col p w =
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        let v = s *.* unitVectorAtAngle dir
        return $ DebrisChunk
-            { _dbPos = (p +.+ (5 *.* normalizeV v)) `v2z` h
+            { _dbPos = p `v2z` h
            , _dbType = Gib 3 col
            , _dbVel = v `v2z` zs
            , _dbRot = q
            , _dbSpin = Q.axisAngle (vNormal v `v2z` 0) (-0.1)
            }
-
-addGibAtDir' :: Float -> Float -> Color -> Point2 -> World -> World
-addGibAtDir' dir h col p w =
-    w
-        & plNew (cWorld . lWorld . props) prID gib
-        & randGen .~ newg
-  where
-    (gib, newg) = runState f $ _randGen w
-    f = do
-        s <- state $ randomR (1, 4)
-        zs <- state $ randomR (-8, 8)
-        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
-        let v = s *.* unitVectorAtAngle dir
-        return $
-            aGib
-                & prPos .~ p
-                & prColor .~ col
-                & prVel .~ v
-                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-                & prQuat .~ q
-                & prVelZ .~ zs
-                & prPosZ .~ h
@@ -30,8 +30,8 @@ updateDebrisChunk w db = (w, mdb)
            & dbVel .~ (0.7 * reflectInNormal n sv) - V3 0 0 1
    dospin = (_dbSpin db *)
    mdb = do
-        guard (np > -100)
-        return $ cdb'
+        guard (np ^. _z > -100)
+        return cdb'

 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w =
@@ -28,13 +28,16 @@ import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M

 testStringInit :: Universe -> [String]
-testStringInit u = map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
-  where
-    g db = (pz,z,norm v)
-      where
-        v@(V3 _ _ z) = db ^. dbVel
-        (V3 _ _ pz) = db ^. dbPos
-        --return . foldMap (prettyLDT (show . (^. _1 . itType))) . invLDT $ _crInv cr
+testStringInit u = [show $ u ^. uvWorld . testFloat
+    , show . length $ u ^. uvWorld . cWorld . lWorld . debris
+    ]
+-- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
+--  where
+--    g db = (pz,z,norm v)
+--      where
+--        v@(V3 _ _ z) = db ^. dbVel
+--        (V3 _ _ pz) = db ^. dbPos
+--        --return . foldMap (prettyLDT (show . (^. _1 . itType))) . invLDT $ _crInv cr
 --  where
 --    idp = invDisplayParams $ u ^. uvWorld
 --    cfig = u ^. uvConfig
@@ -2,7 +2,7 @@

 module Shader.Poke.Cloud (pokeCloud,pokeDust) where

-import Dodge.Data.Material
+import Dodge.Material.Color
 import Color
 import Control.Lens
 import qualified Data.Vector.Unboxed as UV
@@ -71,18 +71,6 @@ pokeDustVerx ptr cl nv i (dx, dy) =
 dustColor :: Dust -> Color
 dustColor = materialColor . _dsType

-materialColor :: Material -> Color
-materialColor = withAlpha 0.5 . \case
-    Wood -> dark yellow
-    Dirt -> dark $ dark orange
-    Stone -> greyN 0.5
-    Glass -> white
-    Metal -> orange
-    Crystal -> green
-    Flesh -> red
-    Electronics-> greyN 0.2
-
-
 pokeDustFloat :: Ptr Float -> Int -> Int -> Float -> IO ()
 {-# INLINE pokeDustFloat #-}
 pokeDustFloat ptr nv i = pokeElemOff ptr (nv * 16 + i)