Prop reification/splitting

src/Dodge/Block/Debris.hs

@@ -1,12 +1,8 @@
 module Dodge.Block.Debris where
 import Dodge.Material.Sound
-import Dodge.Prop.Moving
 import Dodge.WorldEvent.Sound
---import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
---import Dodge.Damage
---import ShapePicture
 import Shape
 import Geometry
 import Color
@@ -50,7 +46,7 @@ makeDebris = makeDebrisDirected 1 2 (2*pi) 0
 makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material 
     -> Color -> Point2 -> World -> World
 makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
-        & flip (foldl' (flip $ plNew props pjID)) thedebris
+        & flip (foldl' (flip $ plNew props prID)) thedebris
         & randGen .~ newg
         & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
   where
@@ -62,13 +58,13 @@ makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
         spinspeed <- randomR (-0.2,-0.1) & state
         basedebris <- baseDebris bm
         return $ basedebris
-            & pjColor .~ col
+            & prColor .~ col
             & prPos .~ p
-            & pjVel .~ v
+            & prVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
-            & pjQuat .~ q
+            & prQuat .~ q
-            & pjVelZ .~ 0
+            & prVelZ .~ 0
-            & pjPosZ .~ h
+            & prPosZ .~ h
 
 makeDebrisDirected :: Float 
     -> Float 
@@ -79,7 +75,7 @@ makeDebrisDirected :: Float
     -> Point2 
     -> World -> World
 makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
-        & flip (foldl' (flip $ plNew props pjID)) thedebris
+        & flip (foldl' (flip $ plNew props prID)) thedebris
         & randGen .~ newg
         & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
   where
@@ -90,13 +86,13 @@ makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
         spinspeed <- randomR (-0.2,-0.1) & state
         basedebris <- baseDebris bm
         return $ basedebris
-            & pjColor .~ col
+            & prColor .~ col
             & prPos .~ p
-            & pjVel .~ v
+            & prVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
-            & pjQuat .~ q
+            & prQuat .~ q
-            & pjVelZ .~ 0
+            & prVelZ .~ 0
-            & pjPosZ .~ h
+            & prPosZ .~ h
 
 debrisSize :: Material -> Float
 debrisSize mt = case mt of
@@ -119,45 +115,45 @@ baseDebris mt = case mt of
     Metal   -> do
         sh <- jaggedShape
         return $ metalDebris
-            & prDraw .~ (`drawMovingShapeCol` sh)
+            & prDraw .~ PropDrawMovingShapeCol sh
     Electronics -> baseDebris Metal
-    Flesh   -> baseDebris Dirt <&> pjColor .~ red
+    Flesh   -> baseDebris Dirt <&> prColor .~ red
 
 stoneDebris :: Prop
 stoneDebris = PropZ
     {_prPos = 0
-    ,_pjStartPos = 0
+    ,_prStartPos = 0
-    ,_pjVel = 0
+    ,_prVel = 0
-    ,_prDraw = \pr -> drawMovingShapeCol pr (cubeShape 4)
+    ,_prDraw = PropDrawMovingShapeCol (cubeShape 4)
-    ,_pjID = 0
+    ,_prID = 0
-    ,_pjUpdate = fallSmallBounceDamage
+    ,_prUpdate = PropFallSmallBounceDamage
-    ,_pjPosZ = 10
+    ,_prPosZ = 10
-    ,_pjVelZ = 5
+    ,_prVelZ = 5
-    ,_pjTimer = 20
+    ,_prTimer = 20
-    ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
+    ,_prQuat = Q.axisAngle (V3 1 0 0) 0
-    ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
+    ,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-    ,_pjColor = greyN 0.5
+    ,_prColor = greyN 0.5
     }
 dirtDebris :: Prop
 dirtDebris = stoneDebris
-    & pjColor .~ dirtColor
+    & prColor .~ dirtColor
-    & pjUpdate .~ fallSmallBounce
+    & prUpdate .~ PropFallSmallBounce
 dirtColor :: Color
 dirtColor = V4 (150/256) ( 75/256)  0 ( 250/256)
 
 metalDebris :: Prop
 metalDebris = stoneDebris
-    & prDraw    .~ (\pr -> drawMovingShapeCol pr (shardShape 4))
+    & prDraw    .~ PropDrawMovingShapeCol (shardShape 4)
-    & pjUpdate  .~ fallSmallBounce
+    & prUpdate  .~ PropFallSmallBounceDamage
 
 glassDebris :: Prop
 glassDebris = stoneDebris
-    & prDraw    .~ (\pr -> drawMovingShapeCol pr (shardShape 4))
+    & prDraw    .~ PropDrawMovingShapeCol (shardShape 4)
-    & pjUpdate  .~ fallSmallBounce
+    & prUpdate  .~ PropFallSmallBounce
-    & pjColor   .~ withAlpha 0.5 cyan
+    & prColor   .~ withAlpha 0.5 cyan
 crystalDebris :: Prop
 crystalDebris = glassDebris
-    & pjColor .~ withAlpha 0.5 aquamarine
+    & prColor .~ withAlpha 0.5 aquamarine
 
 shardShape :: Float -> Shape
 shardShape size = translateSHz (-size) $ upperPrismPoly size

src/Dodge/Data.hs

@@ -80,7 +80,13 @@ module Dodge.Data
     , module Dodge.Data.Laser
     , module Dodge.Data.TeslaArc
     , module Dodge.Data.Shockwave
+    , module Dodge.Data.Prop
+    , module Dodge.Data.LinearShockwave
+    , module Dodge.Data.TractorBeam
     ) where
+import Dodge.Data.TractorBeam
+import Dodge.Data.LinearShockwave
+import Dodge.Data.Prop
 import Dodge.Data.Shockwave
 import Dodge.Data.TeslaArc
 import Dodge.Data.Laser
@@ -161,10 +167,7 @@ import Dodge.GameRoom
 import Color
 import Data.Tile
 import MaybeHelp
---import StreamingHelp.Data
 
---import qualified Data.Vector as V
-import qualified Linear.Quaternion as Q
 import Control.Lens
 import Control.Monad.State
 import System.Random
@@ -230,6 +233,8 @@ data World = World
     , _shockwaves       :: [Shockwave]
     , _lasers           :: [LaserStart]
     , _lasersToDraw     :: [Laser]
+    , _linearShockwaves :: IM.IntMap LinearShockwave
+    , _tractorBeams     :: [TractorBeam]
     , _walls            :: IM.IntMap Wall
     , _wallDamages      :: IM.IntMap [Damage]
     , _doors            :: IM.IntMap Door
@@ -287,6 +292,7 @@ data World = World
     , _lSelect          :: Point2
     , _rSelect          :: Point2
     }
+  --deriving (Eq,Ord,Show,Read)
 data WorldHammer
     = SubInvHam
     | DoubleMouseHam
@@ -396,72 +402,6 @@ type HitEffect' = Flame
     -> World 
     -> (World,Maybe Flame)
 
-data Prop 
-    = PropZ
-        { _prPos :: Point2
-        , _pjStartPos :: Point2
-        , _pjVel :: Point2
-        , _prDraw :: Prop -> SPic
-        , _pjID :: Int
-        , _pjUpdate :: Prop -> World -> World
-        , _pjPosZ :: Float
-        , _pjVelZ :: Float
-        , _pjTimer :: Int
-        , _pjQuat  :: Q.Quaternion Float
-        , _pjQuatSpin  :: Q.Quaternion Float
-        , _pjColor :: Color
-        }
-    | Drone
-        { _prPos :: Point2
-        , _pjStartPos :: Point2
-        , _pjVel :: Point2
-        , _prDraw :: Prop -> SPic
-        , _pjID :: Int
-        , _pjUpdate :: Prop -> World -> World
-        }
-    | RecursiveProp
-        { _prPos    :: Point2
-        , _pjID     :: Int
-        , _pjDraw   :: Prop -> SPic
-        , _pjUpdate :: Prop -> World -> World
-        , _pjProp   :: Prop
-        }
-    | ProjectileTimed
-        { _prPos :: Point2
-        , _pjStartPos :: Point2
-        , _pjVel :: Point2
-        , _prDraw :: Prop -> SPic
-        , _pjID :: Int
-        , _pjUpdate :: Prop -> World -> World
-        , _pjTime :: Int
-        }
-    | ShapeProp
-        { _prPos :: Point2
-        , _pjID :: Int
-        , _pjRot :: Float
-        , _pjUpdate :: Prop -> World -> World
-        , _prDraw :: Prop -> SPic
-        , _prToggle :: Bool
-        }
-    | Bomb 
-        { _prPos :: Point2
-        , _pjVel :: Point2
-        , _pjZ   :: Float
-        , _pjVelZ :: Float
-        , _prDraw :: Prop -> SPic
-        , _pjID :: Int
-        , _pjUpdate :: Prop -> World -> World
-        , _pjPayload :: Point2 -> World -> World
-        , _pjTimer :: Int
-        }
-    | LinearShockwave
-        { _prDraw :: Prop -> SPic
-        , _prPos :: Point2
-        , _pjID :: Int
-        , _pjUpdate :: Prop -> World -> World
-        , _pjPoints :: [(Point2,Point2)]
-        , _pjTimer :: Int
-        }
 data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)
@@ -653,7 +593,6 @@ data InPlacement = InPlacement
     }
 makeLenses ''World
 makeLenses ''FloorItem
-makeLenses ''Prop
 makeLenses ''Particle
 makeLenses ''Door
 makeLenses ''Terminal

src/Dodge/Data/Cloud.hs

@@ -17,7 +17,6 @@ data Cloud = Cloud
     , _clAlt :: Float
     , _clTimer :: Int
     , _clType :: CloudType
---    , _clEffect :: Cloud -> World -> World
     }
   deriving (Eq,Ord,Show,Read)
 data CloudType

src/Dodge/Data/LinearShockwave.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.LinearShockwave where
+import Geometry.Data
+import Control.Lens
+data LinearShockwave = LinearShockwave
+    { _lwPos :: Point2
+    , _lwID :: Int
+    , _lwPoints :: [(Point2,Point2)]
+    , _lwTimer :: Int
+    }
+  deriving (Eq,Ord,Show,Read)
+makeLenses ''LinearShockwave

src/Dodge/Data/Prop.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.Prop
+    where
+import Dodge.Data.WorldEffect
+import Shape.Data
+import Color
+import qualified Linear.Quaternion as Q
+import Geometry.Data
+import ShapePicture.Data
+import Control.Lens
+
+data PropDraw = PropDrawSPic SPic
+    | PropDrawMovingShapeCol Shape
+    | PropDrawMovingShape PropDraw
+    | PropDrawFlatTranslate PropDraw
+    | PropDoubleLampCover Float
+    | PropVerticalLampCover Float
+    | PropLampCover Float
+    | PropDrawToggle PropDraw
+    | PropDrawGib Float
+  deriving (Eq,Ord,Show,Read)
+data PropUpdate -- = UpdatePropZ
+    = PropUpdateAnd PropUpdate PropUpdate
+--    | UpdateShapeProp
+    | PropFallSmallBounceDamage
+    | PropFallSmallBounce
+    | PropUpdateId
+    | PropRotate Float
+    | PropSetToggleAnd WdBl PropUpdate
+    | PropUpdates [PropUpdate]
+    | PropUpdateLS Int PrWdLsLs -- Prop -> World -> LightSource -> LightSource
+    | PropUpdatePosition WdP2f
+    | PropUpdateWhen WdBl PropUpdate
+    | PropUpdateIf WdBl PropUpdate PropUpdate
+  deriving (Eq,Ord,Show,Read)
+data PrWdLsLs = PrWdLsId
+    | PrWdLsSetPosition WdP2f Point3
+    | PrWdLsSetColor Point3
+  deriving (Eq,Ord,Show,Read)
+data Prop 
+    = PropZ
+        { _prPos :: Point2
+        , _prDraw :: PropDraw
+        , _prUpdate :: PropUpdate
+        , _prStartPos :: Point2
+        , _prVel :: Point2
+        , _prID :: Int
+        , _prPosZ :: Float
+        , _prVelZ :: Float
+        , _prTimer :: Int
+        , _prQuat  :: Q.Quaternion Float
+        , _prQuatSpin  :: Q.Quaternion Float
+        , _prColor :: Color
+        }
+    | ShapeProp
+        { _prPos :: Point2
+        , _prDraw :: PropDraw
+        , _prUpdate :: PropUpdate
+        , _prID :: Int
+        , _prRot :: Float
+        , _prToggle :: Bool
+        }
+  deriving (Eq,Ord,Show,Read)
+makeLenses ''Prop

src/Dodge/Data/TractorBeam.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Data.TractorBeam where
+import Geometry.Data
+import Control.Lens
+data TractorBeam = TractorBeam
+    { _tbPos :: Point2
+    , _tbStartPos :: Point2
+    , _tbVel :: Point2
+    , _tbTime :: Int
+    }
+  deriving (Eq,Ord,Show,Read)
+makeLenses ''TractorBeam

src/Dodge/Data/WorldEffect.hs

@@ -2,7 +2,6 @@ module Dodge.Data.WorldEffect where
 import Sound.Data
 import Geometry.Data
 import Dodge.Data.SoundOrigin
-
 data WorldEffect = NoWorldEffect
     | SetTrigger Bool Int 
     | WorldEffects [WorldEffect]
@@ -21,3 +20,9 @@ data MdWdWd = MdWdId
     | MdSetLSCol Point3
     | MdFlickerUpdate
   deriving (Eq,Ord,Show,Read)
+data WdBl = WdTrig Int
+    | WdBlDoorMoving Int
+  deriving (Eq,Ord,Show,Read)
+data WdP2f = WdP2f0
+    | WdP2fDoorPosition Int
+  deriving (Eq,Ord,Show,Read)

src/Dodge/Default/Prop.hs

@@ -4,18 +4,9 @@ import Geometry
 defaultProp :: Prop
 defaultProp = ShapeProp
     { _prPos = V2 0 0
-    , _prDraw = const mempty
+    , _prDraw = PropDrawSPic mempty
-    , _pjID = 0
+    , _prID = 0
-    , _pjUpdate = const id
+    , _prUpdate = PropUpdateId
-    , _prToggle = True
-    , _pjRot = 0
-    }
-defaultShapeProp :: Prop
-defaultShapeProp = ShapeProp
-    { _prPos = 0
-    , _pjID  = 0
-    , _pjRot = 0
-    , _pjUpdate = const id
-    , _prDraw = const mempty
     , _prToggle = True
+    , _prRot = 0
     }

src/Dodge/Default/World.hs

@@ -49,6 +49,8 @@ defaultWorld = World
     , _shockwaves       = []
     , _lasers           = []
     , _lasersToDraw     = []
+    , _tractorBeams     = mempty
+    , _linearShockwaves = mempty
     , _walls            = IM.empty
     , _wallDamages = IM.empty
     , _blocks = IM.empty

src/Dodge/Item/Equipment/Booster.hs

@@ -8,9 +8,6 @@ import Dodge.Default.Weapon
 import Geometry
 import qualified IntMapHelp as IM
 import Picture
-import ShapePicture
-import ListHelp (safeHead)
---import Shape
 
 import Data.Maybe
 import Control.Lens
@@ -60,51 +57,16 @@ addBoostShockwave
     -> Point2
     -> World
     -> World
-addBoostShockwave pjid p v w = w & props %~
+addBoostShockwave pjid p v w = w & linearShockwaves %~
     IM.insertWith f pjid thePJ
   where
     thePJ = LinearShockwave
-        { _prDraw = drawBoostShockwave
+        { _lwPos = p
-        , _prPos = p
+        , _lwID = pjid
-        , _pjID = pjid
+        , _lwPoints = [(p,v)]
-        , _pjUpdate = updateLinearShockwave
+        , _lwTimer = maxT
-        , _pjPoints = [(p,v)]
-        , _pjTimer = maxT
         }
-    f newVal oldVal = newVal & pjPoints %~ (++ _pjPoints oldVal)
+    f newVal oldVal = newVal & lwPoints %~ (++ _lwPoints oldVal)
-
-updateLinearShockwave :: Prop -> World -> World
-updateLinearShockwave pj w
-    | t < 1 = w & props %~ IM.delete pjid
-    | otherwise = w & props . ix (_pjID pj) . pjTimer -~ 1
-  where
-    pjid = _pjID pj
-    t = _pjTimer pj
-
-drawBoostShockwave :: Prop -> SPic
-drawBoostShockwave pj = (,) mempty $ setLayer BloomLayer $ setDepth 20 $ pictures $
-    theArc ++
-    [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
-    , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
-    ]
-  where
--- drawing half a circle here is not perfect, a slightly smaller arc would fit
--- better, but this depends upon the angle formed by the following lines, which
--- is not fixed (it varies with speed and angle of last turn)
-    theArc = maybeToList $ do
-        (hp,hv) <- safeHead pvs
-        r <- safeHead xs
-        return $ color (snd $ last lpairs) $ uncurryV translate hp 
-            $ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv
-    cols = map (`withAlpha` white) [0,0.05..]
-    lpairs = zip (reverse lps) cols
-    pvs = _pjPoints pj
-    t = _pjTimer pj
-    xs = take t $ drop (20 - t) [1,1.2..]
-    lps = zipWith f pvs xs
-    rps = zipWith g pvs xs
-    f (p,v) x = p  +.+ x *.* vNormal v
-    g (p,v) x = p  -.- x *.* vNormal v
 
 maxT :: Int
 maxT = 20

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -29,15 +29,8 @@ import Dodge.Base
 --import Dodge.Zone
 import Geometry
 import Picture
-import ShapePicture
 import LensHelp
---import Dodge.RandomHelp
---import MonadHelp
 
---import Data.Maybe
---import Data.List (sortOn)
---import System.Random
---import Data.Tuple
 import qualified IntMapHelp as IM
 import qualified Data.Map.Strict as M
 --import Control.Monad.State
@@ -353,8 +346,7 @@ dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev p
     & bmType .~ bt
 
 aTractorBeam :: Item -> Creature -> World -> World
---aTractorBeam _ cr w = w & props %~  tractorBeamAt i spos outpos dir power
+aTractorBeam _ cr w = w & tractorBeams .:~ tractorBeamAt spos outpos dir power
-aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power)
   where 
     cpos = _crPos cr
     spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir
@@ -363,71 +355,13 @@ aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power)
     outpos = fst $ collidePointWallsFilterStream (const True) cpos xpos w
     power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr
 
-tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop
+tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> TractorBeam
-tractorBeamAt pos outpos dir power = ProjectileTimed
+tractorBeamAt pos outpos dir power = TractorBeam
-    { _prPos = pos
+    { _tbPos = pos
-    , _pjStartPos = outpos
+    , _tbStartPos = outpos
-    , _pjVel = d
+    , _tbVel = d
-    , _prDraw = tractorSPic
+    , _tbTime = 10
-    , _pjID = 0
-    , _pjUpdate = updateTractor
-    , _pjTime = 10
     }
   where 
     d  = unitVectorAtAngle dir * power
-{- |
-The interaction of this with objects, walls etc needs more thought.  -}
-updateTractor :: Prop -> World -> World
-updateTractor pj w
-    | _pjTime pj <= 0 = w & props %~ IM.delete i
-    | otherwise = w
-        & props . ix i . pjTime -~ 1
-        & creatures     %~ IM.map (tractCr   pullVel pos outpos)
-        & floorItems    %~ IM.map (tractFlIt pullVel pos outpos)
-  where 
-    i = _pjID pj
-    pullVel = _pjVel pj
-    pos = _prPos pj
-    outpos = _pjStartPos pj
 
-tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
-tractFlIt q p1 outpos it 
-    | segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
-    | otherwise = it
-
-tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
-tractCr q p1 outpos cr
-    | segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
-    | otherwise = cr
-
-tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
-tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
-  where
-    x' = abs y + 1
-    y = errorClosestPointOnLineParam 1 p1 p3 p
-    m | dist p p1 < 350 = 1
-      | otherwise        = (400 - dist p p1) / 50
-    g x | x > 5 = (10 - x) / 250
-        | x > 1 = 0.02
-        | x > -1 = x * 0.02
-        | x > -5 = -0.02
-        | otherwise = (x - 10) / 250
-    --p4 = vNormal p5
-    p4 = vNormal $ squashNormalizeV q
-    p3 = p1 +.+ p4
-
-tractorSPic :: Prop -> SPic
-tractorSPic pj = (,) mempty $ setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon 
-    [ spos  -- not sure if this is anticlockwise...
-    , spos +.+ size *.* (d +.+ n)
-    , xpos +.+ size *.* n
-    , xpos -.- size *.* n
-    , spos +.+ size *.* (d -.- n)
-    ]
-  where
-    size = fromIntegral (_pjTime pj)
-    spos = _prPos pj
-    xpos = _pjStartPos pj
-    d = squashNormalizeV $ spos -.- xpos
-    n = vNormal d
-    col = mixColors 0.5 0.5 white blue

src/Dodge/Item/Weapon/Grenade.hs

@@ -1,15 +1,9 @@
 module Dodge.Item.Weapon.Grenade where
-import Dodge.Zoning.Wall
 import Dodge.Data
-import Dodge.Base
-import Dodge.SoundLogic
 import Picture
 import Geometry
 import ShapePicture
 import Shape
-import qualified IntMapHelp as IM
-
-import Control.Lens
 
 --grenade :: Item
 --grenade = Item
@@ -40,27 +34,27 @@ import Control.Lens
 --    fuseTime = 50
 --    f x = 50 / fromIntegral x
 
-moveGrenade :: Prop -> World -> World
+--moveGrenade :: Prop -> World -> World
-moveGrenade pj w
+--moveGrenade pj w
-    | _pjTimer pj <= 0 = w 
+--    | _pjTimer pj <= 0 = w 
-        & props %~ IM.delete pID 
+--        & props %~ IM.delete pID 
-        & _pjPayload pj (_prPos (_props w IM.! pID)) 
+--        & _pjPayload pj (_prPos (_props w IM.! pID)) 
-                                                            -- this should maybe
+--                                                            -- this should maybe
-                                                            -- be wallsAlongLine
+--                                                            -- be wallsAlongLine
-                                                            -- or something vvv
+--                                                            -- or something vvv
-    | otherwise = case bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w of
+--    | otherwise = case bounceBall 1 oldPos newPos 4 $ wlsNearPoint newPos w of
-        Nothing -> w & props . ix pID %~ normalUpdate
+--        Nothing -> w & props . ix pID %~ normalUpdate
-        Just (p,v)  -> w
+--        Just (p,v)  -> w
-            & soundStart (Tap 0) p tapQuietS Nothing
+--            & soundStart (Tap 0) p tapQuietS Nothing
-            & props . ix pID %~ ( ( prPos .~ p ) . ( pjTimer -~ 1 ) . (pjVel .~ v) )
+--            & props . ix pID %~ ( ( prPos .~ p ) . ( pjTimer -~ 1 ) . (pjVel .~ v) )
-  where 
+--  where 
-    pID = _pjID pj
+--    pID = _pjID pj
-    normalUpdate = (pjTimer -~ 1) 
+--    normalUpdate = (pjTimer -~ 1) 
-        . (pjZ %~ (max 0 . (+ _pjVelZ pj))) 
+--        . (pjZ %~ (max 0 . (+ _pjVelZ pj))) 
-        . (pjVelZ -~ 0.1)
+--        . (pjVelZ -~ 0.1)
-        . ( prPos .~ newPos )
+--        . ( prPos .~ newPos )
-    oldPos = _prPos pj
+--    oldPos = _prPos pj
-    newPos = _pjVel pj +.+ oldPos
+--    newPos = _pjVel pj +.+ oldPos
 
 grenadePic :: Int -> SPic
 grenadePic time = 
@@ -72,9 +66,9 @@ grenadePic time =
         ]
     )
 
-grenadeDraw :: Float -> Prop -> SPic
+--grenadeDraw :: Float -> Prop -> SPic
-grenadeDraw dir prop = translateSPz (_pjZ prop) $ uncurryV translateSPf (_prPos prop) 
+--grenadeDraw dir prop = translateSPz (_pjZ prop) $ uncurryV translateSPf (_prPos prop) 
-    $ rotateSP dir $ grenadePic $ _pjTimer prop
+--    $ rotateSP dir $ grenadePic $ _pjTimer prop
 
 --throwGrenade 
 --    :: (Point2 -> World -> World)   -- ^ Payload

src/Dodge/LinearShockwave/Draw.hs

@@ -0,0 +1,34 @@
+module Dodge.LinearShockwave.Draw
+    where
+import Geometry.Vector
+import Geometry.Data
+import ListHelp
+import Dodge.Data.LinearShockwave
+import Picture
+
+import Data.Maybe
+
+drawLinearShockwave :: LinearShockwave -> Picture
+drawLinearShockwave lw = setLayer BloomLayer $ setDepth 20 $ pictures $
+    theArc ++
+    [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
+    , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
+    ]
+  where
+-- drawing half a circle here is not perfect, a slightly smaller arc would fit
+-- better, but this depends upon the angle formed by the following lines, which
+-- is not fixed (it varies with speed and angle of last turn)
+    theArc = maybeToList $ do
+        (hp,hv) <- safeHead pvs
+        r <- safeHead xs
+        return $ color (snd $ last lpairs) $ uncurryV translate hp 
+            $ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv
+    cols = map (`withAlpha` white) [0,0.05..]
+    lpairs = zip (reverse lps) cols
+    pvs = _lwPoints lw
+    t = _lwTimer lw
+    xs = take t $ drop (20 - t) [1,1.2..]
+    lps = zipWith f pvs xs
+    rps = zipWith g pvs xs
+    f (p,v) x = p  +.+ x *.* vNormal v
+    g (p,v) x = p  -.- x *.* vNormal v

src/Dodge/LinearShockwave/Update.hs

@@ -0,0 +1,16 @@
+module Dodge.LinearShockwave.Update
+    where
+import Dodge.Data
+import qualified IntMapHelp as IM
+
+import Control.Lens
+
+updateLinearShockwave :: LinearShockwave -> World -> World
+updateLinearShockwave lw w
+    | t < 1 = w & linearShockwaves %~ IM.delete lwid
+    | otherwise = w & linearShockwaves . ix lwid . lwTimer -~ 1
+  where
+    lwid = _lwID lw
+    t = _lwTimer lw
+
+

src/Dodge/Placement/Instance/LightSource.hs

@@ -16,36 +16,35 @@ import ShapePicture
 import Control.Lens
 import Data.Maybe
 
-propLSThen :: (Prop -> World -> World)
+propLSThen :: PropUpdate
-    -> (Prop -> World -> LightSource -> LightSource)
+    -> PrWdLsLs --(Prop -> World -> LightSource -> LightSource)
     -> LightSource 
     -> Prop
     -> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements
     -> Placement
 propLSThen propf lsf ls prop cont = pt0 (PutLS ls)
-    $ \lspl -> Just $ pt0 (PutProp $ prop & pjUpdate .~ theupdate (fromJust $ _plMID lspl))
+    $ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf])
+      --  theupdate (fromJust $ _plMID lspl))
     $ cont lspl
   where
-    theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
+    --theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
 
-moveLSThen :: (World -> (Point2,Float))
+moveLSThen :: WdP2f --(World -> (Point2,Float))
     -> Point3   -- ^ light source offset
     -> Shape
     -> (Placement -> Placement -> Maybe Placement)
     -> Placement
-moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
+moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop
   where
-    propupdate pr w = w 
+    --lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
-        & props . ix (_pjID pr) . prPos .~ fst (posf w)
-        & props . ix (_pjID pr) . pjRot .~ snd (posf w)
-    lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off
     thels = defaultLS
     theprop = ShapeProp
         { _prPos = 0
-        , _pjID = 0
+        , _prID = 0
-        , _pjRot = 0
+        , _prRot = 0
-        , _pjUpdate = const id
+        , _prUpdate = PropUpdateId
-        , _prDraw = \pr -> noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
+        --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
+        , _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh
         , _prToggle = True
         }
     

src/Dodge/Placement/Instance/LightSource/Cover.hs

@@ -1,85 +1,35 @@
 module Dodge.Placement.Instance.LightSource.Cover where
 import Dodge.Data
-import Dodge.Base
 import Geometry.Data
-import ShapePicture
-import Shape
-import Geometry
 import Dodge.Default.Prop
-
-import Control.Lens
-
 lampCover :: Float -> Prop
 lampCover h = ShapeProp
     { _prPos = V2 0 0
-    , _pjID  = 0
+    , _prID  = 0
-    , _pjRot = 0
+    , _prRot = 0
-    , _pjUpdate = rotateProp 0.15
+    , _prUpdate = PropRotate 0.15
-    , _prDraw = drawLampCover h
+    , _prDraw = PropLampCover h
     , _prToggle = True
     }
-lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop
+lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
-lampCoverWhen cond pos h = defaultShapeProp
+lampCoverWhen cond pos h = defaultProp
     { _prPos = pos
-    , _pjUpdate = setToggle cond `dbArgChain` rotateProp 0.15
+    , _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
-    , _prDraw = drawLampCover h
+    , _prDraw = PropLampCover h
     , _prToggle = True
     }
 
 doubleLampCover :: Float -> Prop
-doubleLampCover h = defaultShapeProp
+doubleLampCover h = defaultProp
     { _prPos = V2 0 0
-    , _pjUpdate = rotateProp 0.15
+    , _prUpdate = PropRotate 0.15
-    , _prDraw = drawDoubleLampCover h
+    , _prDraw = PropDoubleLampCover h
     }
 
 -- on the current (27/9/21) version of shadow stencilling, this glitches
 -- slightly when the shadow rotates towards the screen
 verticalLampCover :: Float -> Prop
-verticalLampCover h = defaultShapeProp
+verticalLampCover h = defaultProp
-    { _pjUpdate = rotateProp 0.15
+    { _prUpdate = PropRotate 0.15
-    , _prDraw = drawVerticalLampCover h
+    , _prDraw = PropVerticalLampCover h
     }
-
-rotateProp :: Float -> Prop -> World -> World
-rotateProp rotAmount pr w = w
-    & props . ix (_pjID pr) . pjRot +~ rotAmount
-
-setToggle :: (World -> Bool) -> Prop -> World -> World
-setToggle cond pr w = w & props . ix (_pjID pr) . prToggle .~ cond w
-
-drawLampCover :: Float -> Prop -> SPic
-drawLampCover h pr 
-    | not (_prToggle pr) = mempty
-    | otherwise = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
-        $ rotateSH (_pjRot pr) $ mconcat
-        [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
-        , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
-        , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
-        , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
-        , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
-        ]
-        , mempty
-        )
-
-drawDoubleLampCover :: Float -> Prop -> SPic
-drawDoubleLampCover h pr =
-    ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) 
-        $ rotateSH (_pjRot pr) $ mconcat
-        [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5       (-6) 6
-        , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
-        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
-        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
-        ]
-    , mempty
-    )
-
-drawVerticalLampCover :: Float -> Prop -> SPic
-drawVerticalLampCover h pr =
-    ( translateSHz h . uncurryV translateSHf (_prPos pr) 
-        $ rotateSHx (_pjRot pr) $ mconcat
-        [ 
-        translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
-        ]
-    , mempty
-    )

src/Dodge/Placement/PlaceSpot.hs

@@ -86,7 +86,7 @@ placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
 placeSpotID ps pt w = case pt of
     PutTrigger  cnd         -> plNewID   triggers cnd w
     PutMod      mdi         -> plNewUpID modifications mdID mdi w
-    PutProp     prp         -> plNewUpID props pjID (mvProp p rot prp) w
+    PutProp     prp         -> plNewUpID props prID (mvProp p rot prp) w
     PutButton   bt          -> plNewUpID buttons btID (mvButton p rot bt) w
     PutTerminal tm          -> plNewUpID terminals tmID tm w
     PutFlIt     itm         -> plNewUpID floorItems flItID (createFlIt p rot itm) w
@@ -150,7 +150,7 @@ addPane wl w l = w & plNew walls wlID (wl & wlLine .~ l)
 --    wlid = IM.newKey (_walls w)
 
 mvProp :: Point2 -> Float -> Prop -> Prop
-mvProp p a = (pjRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
+mvProp p a = (prRot +~ a) . (prPos %~ ( (p +.+) . rotateV a ))
 
 mvButton :: Point2 -> Float -> Button -> Button
 mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))

src/Dodge/PrWdLsLs.hs

@@ -0,0 +1,13 @@
+module Dodge.PrWdLsLs
+    where
+import Dodge.WdP2f
+import Geometry.Vector3D
+import Dodge.Data
+import Control.Lens
+
+doPrWdLsLs :: PrWdLsLs  -> Prop -> World -> LightSource -> LightSource
+doPrWdLsLs x = case x of
+    PrWdLsId -> \_ _ -> id 
+    PrWdLsSetPosition y off -> \_ w 
+        -> lsParam . lsPos .~ addZ 0 (fst (doWdP2f y w)) +.+.+ rotate3z (snd (doWdP2f y w)) off
+    PrWdLsSetColor c -> \_ _ -> lsParam . lsCol .~ c

src/Dodge/Prop/Draw.hs

@@ -0,0 +1,87 @@
+module Dodge.Prop.Draw
+    where
+import Geometry.Polygon
+import Geometry.Data
+import Dodge.Data.Prop
+import ShapePicture
+import Shape
+import Picture
+import qualified Quaternion as Q
+
+drawProp' :: Prop -> SPic
+drawProp' pr = drawProp (_prDraw pr) pr
+
+drawProp :: PropDraw -> Prop -> SPic
+drawProp pd = case pd of
+    PropDrawSPic spic -> const spic
+    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr)
+    PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr sh
+    PropDoubleLampCover h -> drawDoubleLampCover h
+    PropVerticalLampCover h -> drawVerticalLampCover h
+    PropLampCover h -> drawLampCover h
+    PropDrawToggle pd' -> propDrawToggle pd'
+    PropDrawGib x -> noPic . drawGib x
+    PropDrawFlatTranslate x -> \pr 
+        -> uncurryV translateSPf (_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)
+        $ upperPrismPoly (2*x) $ square x
+    skin = colorSH (_prColor pr)
+        . translateSH (V3 1 1 (1 - x))
+        $ upperPrismPoly (2*x) $ square x
+
+propDrawToggle :: PropDraw -> Prop -> SPic
+propDrawToggle pd pr
+    | not (_prToggle pr) = mempty
+    | otherwise = drawProp pd pr
+
+drawLampCover :: Float -> Prop -> SPic
+drawLampCover h pr = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
+    $ rotateSH (_prRot pr) $ mconcat
+    [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+    ]
+    , mempty
+    )
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf (_prPos pr) 
+        $ rotateSHx (_prRot pr) $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
+        ]
+    , mempty
+    )
+
+drawMovingShape :: Prop -> Shape -> SPic
+drawMovingShape pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+
+drawMovingShapeCol :: Prop -> Shape -> SPic
+drawMovingShapeCol pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+    . colorSH (_prColor pr)
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) 
+        $ rotateSH (_prRot pr) $ mconcat
+        [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5       (-6) 6
+        , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
+        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
+        ]
+    , mempty
+    )

src/Dodge/Prop/Gib.hs

@@ -1,16 +1,11 @@
 module Dodge.Prop.Gib 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 Dodge.Base.NewID
 
 import qualified Quaternion as Q
 import Data.List (zip4)
@@ -19,28 +14,18 @@ import Data.Foldable
 aGib :: Prop
 aGib = PropZ
     {_prPos = 0
-    ,_pjStartPos = 0
+    ,_prStartPos = 0
-    ,_pjVel = 0
+    ,_prVel = 0
-    ,_prDraw = \pr -> drawMovingShape pr (drawGib 3 pr)
+    ,_prDraw = PropDrawMovingShape (PropDrawGib 3)
-    ,_pjID = 0
+    ,_prID = 0
-    ,_pjUpdate = fallSmallBounce
+    ,_prUpdate = PropFallSmallBounce
-    ,_pjPosZ = 10
+    ,_prPosZ = 10
-    ,_pjVelZ = 5
+    ,_prVelZ = 5
-    ,_pjTimer = 20
+    ,_prTimer = 20
-    ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
+    ,_prQuat = Q.axisAngle (V3 1 0 0) 0
-    ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
+    ,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-    ,_pjColor = white
+    ,_prColor = white
     }
-drawGib :: Float -> Prop -> Shape
-drawGib x pr = flesh <> skin
-  where
-    flesh = colorSH (dark $ dark red)
-        . translateSHz (negate x)
-        $ upperPrismPoly (2*x) $ square x
-    skin = colorSH (_pjColor pr)
-        . translateSH (V3 1 1 (1 - x))
-        $ upperPrismPoly (2*x) $ square x
-
 
 addCrGibs :: Creature -> World -> World
 addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
@@ -83,18 +68,18 @@ addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels
   
 addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float)
     -> World -> World
-addGib4 p col (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
+addGib4 p col (v,zs,q,h) = plNew props prID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
-    & pjColor .~ col
+    & prColor .~ col
-    & pjVel .~ v
+    & prVel .~ v
-    & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+    & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-    & pjQuat .~ q
+    & prQuat .~ q
-    & pjVelZ .~ zs
+    & prVelZ .~ zs
-    & pjPosZ .~ h
+    & prPosZ .~ h
     )
 
 addGibAt :: Float -> Color -> Point2 -> World -> World
 addGibAt h col p w = w
-    & plNew props pjID gib
+    & plNew props prID gib
     & randGen .~ newg
   where
     (gib,newg) = runState f $ _randGen w
@@ -106,16 +91,16 @@ addGibAt h col p w = w
         let v = s *.* dir
         return $ aGib
             & prPos .~ p
-            & pjColor .~ col
+            & prColor .~ col
-            & pjVel .~ v
+            & prVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & pjQuat .~ q
+            & prQuat .~ q
-            & pjVelZ .~ zs
+            & prVelZ .~ zs
-            & pjPosZ .~ h
+            & prPosZ .~ h
 
 addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
 addGibAtDir dir h col p w = w
-    & plNew props pjID gib
+    & plNew props prID gib
     & randGen .~ newg
   where
     (gib,newg) = runState f $ _randGen w
@@ -126,9 +111,9 @@ addGibAtDir dir h col p w = w
         let v = s *.* unitVectorAtAngle dir
         return $ aGib
             & prPos .~ p
-            & pjColor .~ col
+            & prColor .~ col
-            & pjVel .~ v
+            & prVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & pjQuat .~ q
+            & prQuat .~ q
-            & pjVelZ .~ zs
+            & prVelZ .~ zs
-            & pjPosZ .~ h
+            & prPosZ .~ h

src/Dodge/Prop/Moving.hs

@@ -1,77 +1,52 @@
 module Dodge.Prop.Moving 
-    ( drawMovingShape
+    ( fallSmallBounceDamage
-    , drawMovingShapeCol
-    , fallSmallBounceDamage
     , fallSmallBounce
     ) 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)
---
 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w = w 
     & dodamage
-    & props . ix (_pjID pr) %~ fallSmallBounce' w
+    & props . ix (_prID pr) %~ fallSmallBounce' w
   where
     p = _prPos pr
-    v = _pjVel pr
+    v = _prVel pr
     dodamage
-        | _pjPosZ pr < 25 = creatures %~ fmap dodamage'
+        | _prPosZ pr < 25 = creatures %~ fmap dodamage'
         | otherwise = id
     dodamage' cr
         | dist (_crPos cr) p < _crRad cr + 5 = cr & crState . csDamage 
-            .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _pjVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
+            .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
         | otherwise = cr
 
 fallSmallBounce :: Prop -> World -> World
 fallSmallBounce pr w = w 
-    & props . ix (_pjID pr) %~ fallSmallBounce' w
+    & props . ix (_prID pr) %~ fallSmallBounce' w
 
 fallSmallBounce' :: World -> Prop -> Prop
 fallSmallBounce' w pr
     | newposz < 0 && velz < (-2) = pr 
-        & pjVelZ %~ ((*0.5) . negate)
+        & prVelZ %~ ((*0.5) . negate)
 --        & pjPos +~ (0.5*.* vel)
         & updateWithVel (0.5 *.* vel)
-        & pjVel %~ (0.5 *.*)
+        & prVel %~ (0.5 *.*)
 --        & pjPos +~ (0.5*.* vel)
-    | newposz < 0 = pr & pjUpdate .~ const id
+    | newposz < 0 = pr & prUpdate .~ PropUpdateId
-        & pjZ .~ 0
+        & prPosZ .~ 0
 --        & pjQuat *~ (_pjQuatSpin pr)
     | otherwise = pr
-        & pjVelZ -~ 1
+        & prVelZ -~ 1
-        & pjPosZ +~ velz
+        & prPosZ +~ velz
         & updateWithVel vel
-        & pjQuat *~ _pjQuatSpin pr
+        & prQuat *~ _prQuatSpin pr
   where
-    newposz = _pjPosZ pr + velz
+    newposz = _prPosZ pr + velz
-    velz = _pjVelZ pr
+    velz = _prVelZ pr
-    vel  = _pjVel pr
+    vel  = _prVel pr
     pos  = _prPos pr
     updateWithVel v = case bouncePoint (const True) 0.5 pos (pos + v) w of
         Nothing -> prPos +~ v
-        Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
+        Just (p,v') -> (prPos .~ p) . (prVel .~ v')
 
-drawMovingShape :: Prop -> Shape -> SPic
-drawMovingShape pr = noPic
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat pr))
-
-drawMovingShapeCol :: Prop -> Shape -> SPic
-drawMovingShapeCol pr = noPic
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat pr))
-    . colorSH (_pjColor pr)

src/Dodge/Prop/Update.hs

@@ -0,0 +1,53 @@
+module Dodge.Prop.Update
+    where
+import Dodge.WdP2f
+import Dodge.PrWdLsLs
+import Dodge.WorldBool
+import Dodge.Data
+import Dodge.Prop.Moving
+
+import Data.Foldable
+import Control.Lens
+
+updateProp :: Prop -> World -> World
+updateProp pr = case _prUpdate pr of
+    PropFallSmallBounceDamage -> fallSmallBounceDamage pr
+    PropFallSmallBounce -> fallSmallBounce pr
+    PropUpdateId -> id
+    PropRotate x -> rotateProp x pr
+    PropSetToggleAnd wb pu -> propSetToggleAnd wb pu pr
+    PropUpdates pus -> doPropUpdates pr pus
+    PropUpdateLS lsid x -> \w -> w & lightSources . ix lsid %~ doPrWdLsLs x pr w
+    PropUpdatePosition x -> propUpdatePosition x pr
+    PropUpdateWhen t x -> propUpdateIf t x PropUpdateId pr
+    PropUpdateAnd x y -> doPropUpdates pr [x,y]
+    PropUpdateIf t x y -> propUpdateIf t x y pr
+
+propUpdateIf :: WdBl -> PropUpdate -> PropUpdate -> Prop -> World -> World
+propUpdateIf wb x y pr w
+    | doWdBl wb w   = updateProp (pr & prUpdate .~ x) w
+    | otherwise     = updateProp (pr & prUpdate .~ y) w
+
+
+
+propUpdatePosition :: WdP2f -> Prop -> World -> World
+propUpdatePosition x pr w = w
+    & props . ix (_prID pr) . prPos .~ fst (doWdP2f x w)
+    & props . ix (_prID pr) . prRot .~ snd (doWdP2f x w)
+
+doPropUpdates :: Prop -> [PropUpdate] -> World -> World
+doPropUpdates pr pus w = foldl' f w pus
+  where
+    f w' pu = updateProp (pr & prUpdate .~ pu) w'
+
+propSetToggleAnd :: WdBl -> PropUpdate -> Prop -> World -> World
+propSetToggleAnd wb pu pr = setToggle (doWdBl wb) pr . updateProp (pr & prUpdate .~ pu)
+    -- fugly
+
+setToggle :: (World -> Bool) -> Prop -> World -> World
+setToggle cond pr w = w & props . ix (_prID pr) . prToggle .~ cond w
+
+rotateProp :: Float -> Prop -> World -> World
+rotateProp rotAmount pr w = w
+    & props . ix (_prID pr) . prRot +~ rotAmount
+

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,9 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.LinearShockwave.Draw
+import Dodge.Prop.Draw
+import Dodge.TractorBeam.Draw
 import Dodge.Shockwave.Draw
 import Dodge.Tesla.Arc.Draw
 import Dodge.Laser.Draw
@@ -62,7 +65,7 @@ singleSPic = id
 worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w 
     =  singleSPic (mempty, extraPics cfig w)
-    <> foldup (dbArg _prDraw) (filtOn _prPos _props)                             
+    <> foldup drawProp' (filtOn _prPos _props)                             
     <> foldup drawProjectile (filtOn _prjPos _projectiles)                             
     <> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)           
     <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)   
@@ -129,6 +132,8 @@ cullPoint cfig w p
 
 extraPics :: Configuration -> World -> Picture
 extraPics cfig w = pictures (_decorations w)
+    <> concatMapPic drawTractorBeam (_tractorBeams w)
+    <> concatMapPic drawLinearShockwave (_linearShockwaves w)
     <> concatMapPic drawShockwave (_shockwaves w)
     <> concatMapPic drawLaser (_lasersToDraw w)
     <> concatMapPic drawTeslaArc (_teslaArcs w)

src/Dodge/Room/LongDoor.hs

@@ -6,7 +6,6 @@ import Dodge.Data
 import Dodge.Default.Door
 import Dodge.Cleat
 import Dodge.RoomLink
-import Dodge.Base
 import Dodge.Tree
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
@@ -49,7 +48,7 @@ twinSlowDoorRoom w h x = defaultRoom
             $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h))
             $ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h))
             $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampheight)))
-            $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampheight
+            $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h-1)) lampheight
         ]
     , _rmBound  = ps
     , _rmName   = "twinSlowDoorRoom"
@@ -58,13 +57,9 @@ twinSlowDoorRoom w h x = defaultRoom
   where
     thewall = switchWallCol red
     wlSpeed = 0.5
-    addColorChange lsid drid = over pjUpdate $ dbArgChain $ const f
+    addColorChange lsid drid = over prUpdate $ PropUpdateAnd $ PropUpdateIf (WdBlDoorMoving drid) 
-      where
+        (PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0)))
-        f u | _drStatus (_doors u IM.! drid) == DoorHalfway 
+        (PropUpdateLS lsid (PrWdLsSetColor 0.7))
-                        = u & updatelscol (V3 8 0 0)
-            | otherwise = u & updatelscol 0.7
-        updatelscol c = lightSources . ix lsid . lsParam . lsCol .~ c
-    drmoving i w' = DoorHalfway == _drStatus (_doors w' IM.! i)
     lampheight = 41
     ps = 
         [rectNSWE h    0 (-w) w
@@ -107,7 +102,7 @@ addButtonSlowDoor x h rm = do
     openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3*x/2) (-x/2)
     belowH y = (sndV2 . fst) y < h - 40
     aboveH y = (sndV2 . fst) y > h + 40
-    amountedlight dr xoff mpl = Just . moveLSThen (getdoorpos (fromJust $ _plMID dr)) 
+    amountedlight dr xoff mpl = Just . moveLSThen (WdP2fDoorPosition (fromJust $ _plMID dr)) 
                 (V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90)) 
         $ \plls plpr -> Just $ ptCont (PutWorldUpdate (const $ setmount dr plls plpr))
         $ const mpl
@@ -126,8 +121,6 @@ addButtonSlowDoor x h rm = do
         $ amountedlight dr2   50
         $ amountedlight dr2 (-50)
          Nothing
-    getdoorpos drid w = let Just (a,b) = w ^? doors . ix drid . drPos
-        in (b, argV (a-.-b))
     col = dim $ light red
     cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff
 

src/Dodge/TractorBeam/Draw.hs

@@ -0,0 +1,24 @@
+module Dodge.TractorBeam.Draw
+    where
+import Dodge.Data.TractorBeam
+import Geometry
+import Picture
+
+drawTractorBeam :: TractorBeam -> Picture
+drawTractorBeam = tractorSPic
+
+tractorSPic :: TractorBeam -> Picture
+tractorSPic pj = setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon 
+    [ spos  -- not sure if this is anticlockwise...
+    , spos +.+ size *.* (d +.+ n)
+    , xpos +.+ size *.* n
+    , xpos -.- size *.* n
+    , spos +.+ size *.* (d -.- n)
+    ]
+  where
+    size = fromIntegral (_tbTime pj)
+    spos = _tbPos pj
+    xpos = _tbStartPos pj
+    d = squashNormalizeV $ spos -.- xpos
+    n = vNormal d
+    col = mixColors 0.5 0.5 white blue

src/Dodge/TractorBeam/Update.hs

@@ -0,0 +1,45 @@
+module Dodge.TractorBeam.Update
+    where
+import Geometry
+import Dodge.Data
+import qualified IntMapHelp as IM
+import Control.Lens
+
+updateTractorBeam :: World -> TractorBeam -> (World, Maybe TractorBeam)
+updateTractorBeam w pj
+    | _tbTime pj <= 0 = (w, Nothing)
+    | otherwise = (w
+        & creatures     %~ IM.map (tractCr   pullVel pos outpos)
+        & floorItems    %~ IM.map (tractFlIt pullVel pos outpos)
+        , Just (pj & tbTime -~ 1))
+  where 
+    pullVel = _tbVel pj
+    pos     = _tbPos pj
+    outpos  = _tbStartPos pj
+
+tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
+tractFlIt q p1 outpos it 
+    | segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
+    | otherwise = it
+
+tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
+tractCr q p1 outpos cr
+    | segOnCirc p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
+    | otherwise = cr
+
+tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
+tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
+  where
+    x' = abs y + 1
+    y = errorClosestPointOnLineParam 1 p1 p3 p
+    m | dist p p1 < 350 = 1
+      | otherwise        = (400 - dist p p1) / 50
+    g x | x > 5 = (10 - x) / 250
+        | x > 1 = 0.02
+        | x > -1 = x * 0.02
+        | x > -5 = -0.02
+        | otherwise = (x - 10) / 250
+    --p4 = vNormal p5
+    p4 = vNormal $ squashNormalizeV q
+    p3 = p1 +.+ p4
+

src/Dodge/Update.hs

@@ -4,6 +4,9 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.TractorBeam.Update
+import Dodge.Prop.Update
+import Dodge.LinearShockwave.Update
 import Dodge.Shockwave.Update
 import Dodge.Tesla.Arc
 import Dodge.Laser.Update
@@ -61,7 +64,7 @@ updateUniverse u = case _menuLayers u of
     (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
         ( updateParticles 
         . (radarBlips .~ [])
-        . updateIMl _props _pjUpdate 
+--        . updateIMl _props _pjUpdate 
         . updateLightSources
         . updateClouds )
     (_ : _) -> u
@@ -100,7 +103,9 @@ functionalUpdate w = checkEndGame
     . over uvWorld updateBeams
     . over uvWorld updateLasers
     . over uvWorld updateTeslaArcs
-    . over uvWorld (updateIMl _props _pjUpdate              )
+    . over uvWorld updateTractorBeams
+    . over uvWorld (updateIMl' _linearShockwaves updateLinearShockwave)
+    . over uvWorld (updateIMl' _props updateProp              )
     . over uvWorld (updateIMl' _projectiles updateProjectile)
     . over uvWorld updateLightSources
     . over uvWorld updateClouds
@@ -238,6 +243,11 @@ updateTeslaArcs w = w' & teslaArcs .~ catMaybes newtas
   where
     (w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs w
 
+updateTractorBeams :: World -> World
+updateTractorBeams w = w' & tractorBeams .~ catMaybes newtas
+  where
+    (w',newtas) = mapAccumR updateTractorBeam w $ _tractorBeams  w
+
 
 {- Apply internal particle updates, delete 'Nothing's.  -}
 updateBullets :: World -> World

src/Dodge/WdP2.hs

@@ -0,0 +1 @@
+module Dodge.WdP2 where

src/Dodge/WdP2f.hs

@@ -0,0 +1,12 @@
+module Dodge.WdP2f
+    where
+import Geometry.Vector
+import Dodge.Data
+import Geometry.Data
+import Control.Lens
+
+doWdP2f :: WdP2f -> World -> (Point2,Float)
+doWdP2f x = case x of
+    WdP2f0 -> const (0,0)
+    WdP2fDoorPosition drid -> \w -> let Just (a,b) = w ^? doors . ix drid . drPos
+        in (b, argV (a-.-b))

src/Dodge/WorldBool.hs

@@ -0,0 +1,12 @@
+module Dodge.WorldBool
+    where
+import Dodge.Data
+import Data.Maybe
+import Control.Lens
+
+doWdBl :: WdBl -> World -> Bool
+doWdBl wb w = case wb of
+    WdTrig i -> fromMaybe False $ w ^? triggers . ix i
+    WdBlDoorMoving i -> fromMaybe False $ do
+        dr <- w ^? doors . ix i
+        return (DoorHalfway == _drStatus dr)

src/Shape/Data.hs

@@ -32,17 +32,17 @@ data ShapeObj = ShapeObj
     { _shType   :: ShapeType 
     , _shVs     :: [ShapeV]
     }
-  deriving ()
+  deriving (Eq,Ord,Show,Read)
 
 newtype ShapeType = TopPrism Int
-  deriving (Eq,Ord,Show)
+  deriving (Eq,Ord,Show,Read)
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV
     {_svPos :: Point3
     ,_svCol :: Point4
     }
-  deriving (Eq,Ord,Show)
+  deriving (Eq,Ord,Show,Read)
 pairToSV :: (Point3,Point4) -> ShapeV
 {-# INLINE pairToSV #-}
 pairToSV = uncurry ShapeV