Work on gibs and chasms

src/Dodge/Prop/Draw.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Prop.Draw (
     propSPic,
+    debrisSPic,
 ) where
 
 import Control.Lens
@@ -15,6 +16,11 @@ import ShapePicture
 propSPic :: Prop -> SPic
 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
+
 drawProp :: PropDraw -> Prop -> SPic
 drawProp = \case
     PropDrawSPic spic -> const spic
@@ -39,6 +45,17 @@ drawGib x pr = flesh <> skin
             translateSH (V3 1 1 (1 - x)) baseCube
     baseCube = upperPrismPoly Small Typical (2 * x) $ square x
 
+drawGib' :: Float -> Color -> Shape
+drawGib' x col = flesh <> skin
+  where
+    flesh =
+        colorSH (dark $ dark red) $
+            translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
+    skin =
+        colorSH col $
+            translateSH (V3 1 1 (1 - x)) baseCube
+    baseCube = upperPrismPoly Small Typical (2 * x) $ square x
+
 propDrawToggle :: PropDraw -> Prop -> SPic
 propDrawToggle pd pr
     | not (_prToggle pr) = mempty

src/Dodge/Prop/Gib.hs

@@ -26,7 +26,6 @@ aGib =
         , _prUpdate = PropFallSmallBounce
         , _prPosZ = 10
         , _prVelZ = 5
-        , _prTimer = 20
         , _prQuat = Q.axisAngle (V3 1 0 0) 0
         , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
         , _prColor = white
@@ -73,13 +72,18 @@ addGibsAtDir dir minh maxh col p w =
     quats :: [Q.Quaternion Float]
     quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
 
-addGib4 ::
-    Point2 ->
-    Color ->
-    (Point2, Float, Q.Quaternion Float, Float) ->
-    World ->
-    World
-addGib4 p col (v, zs, q, h) =
+addGib4 :: Point2 -> Color -> (Point2, Float, QFloat, Float) -> World -> World
+addGib4 p col (v, zs, q, h) = cWorld . lWorld . debris
+        .:~ DebrisChunk
+            { _dbPos = p `v2z` h
+            , _dbType = Gib 3 col
+            , _dbVel = v `v2z` zs
+            , _dbRot = q
+            , _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
@@ -93,7 +97,25 @@ addGib4 p col (v, zs, q, h) =
         )
 
 addGibAt :: Float -> Color -> Point2 -> World -> World
-addGibAt h col p w =
+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
@@ -117,6 +139,26 @@ addGibAt h col p w =
 
 addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
 addGibAtDir dir h col p w =
+    w
+        & cWorld . lWorld . debris .:~ gib
+        & randGen .~ newg
+  where
+    (gib, newg) = runState f $ _randGen w
+    f = do
+        s <- state $ randomR (1, 4)
+        zs <- state $ randomR (-4, 4)
+        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
+        let v = s *.* unitVectorAtAngle dir
+        return $ DebrisChunk
+            { _dbPos = (p +.+ (5 *.* normalizeV v)) `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

src/Dodge/Prop/Moving.hs

@@ -1,13 +1,37 @@
 module Dodge.Prop.Moving (
     fallSmallBounceDamage,
     fallSmallBounce,
+    updateDebrisChunk,
 ) where
 
+import Linear.Metric
+import Linear.V3
 import Dodge.Damage
 import Dodge.Base
 import Dodge.Data.World
 import Geometry
 import LensHelp
+import Control.Monad
+
+updateDebrisChunk :: World -> Debris -> (World, Maybe Debris)
+updateDebrisChunk w db = (w, mdb)
+  where
+    cdb' 
+        | norm sv < 0.5 && abs (sp ^. _z) < 0.5 = db
+        | otherwise = cdb
+    sv = db ^. dbVel
+    sp = _dbPos db
+    np = sp + sv
+    cdb = case collide3 sp np w of
+        (p,Nothing) -> db & dbPos .~ p
+            & dbVel -~ V3 0 0 1
+            & dbRot %~ dospin
+        (p,Just n) -> db & dbPos .~ p + (0.0001 * normalize n)
+            & dbVel .~ (0.7 * reflectInNormal n sv) - V3 0 0 1
+    dospin = (_dbSpin db *)
+    mdb = do
+        guard (np > -100)
+        return $ cdb'
 
 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w =