Move towards introducing pipes, generalise blocks

2022-06-16 02:18:22 +01:00
parent f404f32241
commit a7201b8fb6
13 changed files with 154 additions and 65 deletions
@@ -0,0 +1,50 @@
+module Dodge.Block.Debris where
+import Dodge.Prop.Moving
+--import Dodge.Zone
+import Dodge.Base
+import Dodge.Data
+--import Dodge.Damage
+--import ShapePicture
+import Shape
+import Geometry
+import Color
+import LensHelp
+import RandomHelp
+import qualified Quaternion as Q
+--import Data.List (zip4)
+
+makeBlockDebris :: BlockMaterial -> Block -> World -> World
+makeBlockDebris _ bl w = w
+    & flip (foldr (plNew props pjID)) thedebris
+    & randGen .~ newg
+  where
+    (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w
+    f h = do
+        v <- randInCirc 2
+        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
+        return $ someDebris
+            & prPos .~ _blPos bl
+            & pjColor .~ greyN 0.5
+            & pjVel .~ v
+            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & pjQuat .~ q
+            & pjVelZ .~ 0
+            & pjPosZ .~ h
+
+someDebris :: Prop
+someDebris = PropZ
+    {_prPos = 0
+    ,_pjStartPos = 0
+    ,_pjVel = 0
+    ,_prDraw = \pr -> drawMovingShape pr (debrisShape pr)
+    ,_pjID = 0
+    ,_pjUpdate = fallSmallBounce
+    ,_pjPosZ = 10
+    ,_pjVelZ = 5
+    ,_pjTimer = 20
+    ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
+    ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
+    ,_pjColor = white
+    }
+debrisShape :: Prop -> Shape
+debrisShape pr = colorSH (_pjColor pr) . translateSHz (-5) $ upperPrismPoly 10 $ square 5