Work on bouncing debris

src/Dodge/Prop/Draw.hs

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

src/Dodge/Prop/Gib.hs

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

src/Dodge/Prop/Moving.hs

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