Work on bouncing debris

src/Dodge/Base/Collide.hs

@@ -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
+    wsfs = 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))])
+    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)])] 

src/Dodge/Block/Debris.hs

@@ -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 ::
+makeDebrisDirected :: Float -> Float -> Material -> Color -> Point2 -> World -> World
-    Float ->
+makeDebrisDirected arcrad dir bm col p w =
-    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 =
     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

src/Dodge/Data/Object.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}
 
 module Dodge.Data.Object where
 

src/Dodge/Data/Prop.hs

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

src/Dodge/Item/Weapon/Shatter.hs

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

src/Dodge/Material/Color.hs

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

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 :: Float -> Color -> Shape
-drawGib x pr = flesh <> skin
+drawGib x col = 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
   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
+            . addGibsAtDir pi 0 3 7 (_skinLower skin) cpos
-            . addGibsAt 13 20 (_skinUpper skin) cpos
+            . addGibsAtDir pi 0 13 20 (_skinUpper skin) cpos
-    Just d ->
+    Just d -> (testFloat +~ 1)
-            addGibsAtDir d 3 7 (_skinLower skin) cpos
+            . addGibsAtDir (pi/4) d 3 7 (_skinLower skin) cpos
-            . addGibsAtDir d 13 20 (_skinUpper 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 :: Float -> Float -> Float -> Float -> Color -> Point2 -> World -> World
-addGibsAtDir dir minh maxh col p w =
+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)
+        guard (np ^. _z > -100)
-        return $ cdb'
+        return cdb'
 
 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w =

src/Dodge/TestString.hs

@@ -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)
+testStringInit u = [show $ u ^. uvWorld . testFloat
-  where
+    , show . length $ u ^. uvWorld . cWorld . lWorld . debris
-    g db = (pz,z,norm v)
+    ]
-      where
+-- map shortShow (u ^.. uvWorld . cWorld . lWorld . debris . each . to g)
-        v@(V3 _ _ z) = db ^. dbVel
+--  where
-        (V3 _ _ pz) = db ^. dbPos
+--    g db = (pz,z,norm v)
-        --return . foldMap (prettyLDT (show . (^. _1 . itType))) . invLDT $ _crInv cr
+--      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

src/Shader/Poke/Cloud.hs

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