Move towards introducing pipes, generalise blocks

src/Dodge/Prop/Gib.hs

@@ -1,9 +1,10 @@
 module Dodge.Prop.Gib where
-import Dodge.Zone
+import Dodge.Prop.Moving
+--import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
 import Dodge.Damage
-import ShapePicture
+--import ShapePicture
 import Shape
 import Geometry
 import Color
@@ -19,9 +20,9 @@ aGib = PropZ
     {_prPos = 0
     ,_pjStartPos = 0
     ,_pjVel = 0
-    ,_prDraw = drawGib 3
+    ,_prDraw = \pr -> drawMovingShape pr (drawGib 3 pr)
     ,_pjID = 0
-    ,_pjUpdate = updateGib
+    ,_pjUpdate = fallSmallBounce
     ,_pjPosZ = 10
     ,_pjVelZ = 5
     ,_pjTimer = 20
@@ -29,12 +30,8 @@ aGib = PropZ
     ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
     ,_pjColor = white
     }
-drawGib :: Float -> Prop -> SPic
-drawGib x pr = noPic
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat pr))
-    $ flesh <> skin
+drawGib :: Float -> Prop -> Shape
+drawGib x pr = flesh <> skin
   where
     flesh = colorSH (dark $ dark red)
         . translateSHz (negate x)
@@ -43,33 +40,6 @@ drawGib x pr = noPic
         . translateSH (V3 1 1 (1 - x))
         $ upperPrismPoly (2*x) $ square x
 
-updateGib :: Prop -> World -> World
-updateGib pr w = w & props . ix (_pjID pr) %~ updateGib' w
-
-updateGib' :: World -> Prop -> Prop
-updateGib' w pr
-    | newposz < 0 && velz < (-2) = pr 
-        & pjVelZ %~ ((*0.5) . negate)
---        & pjPos +~ (0.5*.* vel)
-        & updateWithVel (0.5 *.* vel)
-        & pjVel %~ (0.5 *.*)
---        & pjPos +~ (0.5*.* vel)
-    | newposz < 0 = pr & pjUpdate .~ const id
-        & pjZ .~ 0
---        & pjQuat *~ (_pjQuatSpin pr)
-    | otherwise = pr
-        & pjVelZ -~ 1
-        & pjPosZ +~ velz
-        & updateWithVel vel
-        & pjQuat *~ _pjQuatSpin pr
-  where
-    newposz = _pjPosZ pr + velz
-    velz = _pjVelZ pr
-    vel  = _pjVel pr
-    pos  = _prPos pr
-    updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of
-        Nothing -> prPos +~ v
-        Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
 
 addCrGibs :: Creature -> World -> World
 addCrGibs cr w = case damageDirection $ _crDamage $ _crState cr of

src/Dodge/Prop/Moving.hs

@@ -0,0 +1,49 @@
+module Dodge.Prop.Moving where
+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 Dodge.Base.NewID
+
+import qualified Quaternion as Q
+--import Data.List (zip4)
+
+fallSmallBounce :: Prop -> World -> World
+fallSmallBounce pr w = w & props . ix (_pjID pr) %~ fallSmallBounce' w
+
+fallSmallBounce' :: World -> Prop -> Prop
+fallSmallBounce' w pr
+    | newposz < 0 && velz < (-2) = pr 
+        & pjVelZ %~ ((*0.5) . negate)
+--        & pjPos +~ (0.5*.* vel)
+        & updateWithVel (0.5 *.* vel)
+        & pjVel %~ (0.5 *.*)
+--        & pjPos +~ (0.5*.* vel)
+    | newposz < 0 = pr & pjUpdate .~ const id
+        & pjZ .~ 0
+--        & pjQuat *~ (_pjQuatSpin pr)
+    | otherwise = pr
+        & pjVelZ -~ 1
+        & pjPosZ +~ velz
+        & updateWithVel vel
+        & pjQuat *~ _pjQuatSpin pr
+  where
+    newposz = _pjPosZ pr + velz
+    velz = _pjVelZ pr
+    vel  = _pjVel pr
+    pos  = _prPos pr
+    updateWithVel v = case reflectPointWallsDamp 0.5 pos (pos + v) $ wallsAlongLine pos (pos +v) w of
+        Nothing -> prPos +~ v
+        Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
+
+drawMovingShape :: Prop -> Shape -> SPic
+drawMovingShape pr = noPic
+    . translateSHz (_pjPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_pjQuat pr))