Implement moving mounted lights

src/Dodge/Placement/Instance/LightSource.hs

@@ -11,8 +11,44 @@ import Dodge.Default
 import Dodge.RandomHelp 
 import Color
 import Shape
+import ShapePicture
 
 import Control.Lens
+import Data.Maybe
+
+propLSThen :: (Prop -> World -> World)
+    -> (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))
+    $ cont lspl
+  where
+    theupdate lsid pr w = propf pr w & lightSources . ix lsid %~ lsf pr w
+
+moveLSThen :: (World -> (Point2,Float))
+    -> Point3   -- ^ light source offset
+    -> Shape
+    -> (Placement -> Placement -> Maybe Placement)
+    -> Placement
+moveLSThen posf off sh = propLSThen propupdate lsupdate thels theprop
+  where
+    propupdate pr w = w 
+        & props . ix (_pjID pr) . pjPos .~ 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
+        { _pjPos = 0
+        , _pjID = 0
+        , _pjRot = 0
+        , _pjUpdate = const id
+        , _prDraw = \pr -> noPic $ uncurryV translateSHf (_pjPos pr) $ rotateSH (_pjRot pr) sh
+        , _prToggle = True
+        }
+    
 
 -- | mount a light source on a shape
 mntLSOn