Move towards introducing pipes, generalise blocks

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