Allow for easier mounted objects on doors

src/Dodge/Data/GenWorld.hs

@@ -52,7 +52,7 @@ data PSType
         , _putEndPoint :: Point2
         }
     | PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
-    | PutDoor Door Wall
+    | PutDoor {_putDoorDoor :: Door, _putDoorWall :: Wall}
     | RandPS (State StdGen PSType)
     | PutForeground ForegroundShape
     | PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld)

src/Dodge/Data/LWorld.hs

@@ -42,6 +42,7 @@ module Dodge.Data.LWorld (
     module Dodge.Data.PulseLaser,
 ) where
 
+import ShapePicture.Data
 import Dodge.Data.PulseLaser
 import Dodge.Data.Equipment.Misc
 import Control.Lens
@@ -105,6 +106,7 @@ data LWorld = LWorld
     , _sparks :: [Spark]
     , _radarBlips :: [RadarBlip]
     , _flares :: Picture -- picture drawn for one frame
+    , _tempSPic :: SPic
     , _teslaArcs :: [TeslaArc]
     , _arcNode :: M.Map ArcNodeType Int
     , _shockwaves :: [Shockwave]

src/Dodge/Data/MountedObject.hs

@@ -3,12 +3,16 @@
 
 module Dodge.Data.MountedObject where
 
+import ShapePicture.Data
+import Geometry.Data
 import Data.Aeson
 import Data.Aeson.TH
 
 data MountedObject
     = MountedLS Int
     | MountedProp Int
+    | MountedLight Point3 Float Point3
+    | MountedSPic SPic
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 deriveJSON defaultOptions ''MountedObject

src/Dodge/Data/Prop.hs

@@ -18,7 +18,7 @@ data Prop = ShapeProp
     , _prUpdate :: PropUpdate
     , _prID :: Int
     , _prRot :: Float
-    , _prToggle :: Bool
+--    , _prToggle :: Bool
     }
 
 data DebrisType
@@ -35,9 +35,6 @@ data Debris = DebrisChunk
 
 data PropUpdate
     = PropUpdateId
-    | PropUpdateAnd PropUpdate PropUpdate
-    | PropRotate Float
-    | PropSetToggleAnd WdBl PropUpdate
     | PropUpdates [PropUpdate]
     | PropUpdateLS Int PrWdLsLs
     | PropUpdatePosition WdP2f

src/Dodge/Default/Prop.hs

@@ -10,6 +10,5 @@ defaultProp =
         , _prDraw = mempty
         , _prID = 0
         , _prUpdate = PropUpdateId
-        , _prToggle = True
         , _prRot = 0
         }

src/Dodge/Default/World.hs

@@ -158,6 +158,7 @@ defaultLWorld =
         , _lAimPos = 0
         , _lInvLock = False
         , _respawnPos = (V2 20 20, pi / 2)
+        , _tempSPic = mempty
         }
 
 defaultHUD :: HUD

src/Dodge/DrWdWd.hs

@@ -1,41 +1,64 @@
+{-# LANGUAGE LambdaCase #-}
+
 module Dodge.DrWdWd (updateDoor) where
 
+import Data.Foldable
+import qualified Data.IntMap.Strict as IM
+import Data.Maybe
+import qualified Data.Set as S
+import Dodge.Block.Debris
+import Dodge.Data.World
 import Dodge.Door.DoorLerp
 import Dodge.LightSource
-import Data.Foldable
-import Dodge.Wall.Delete
-import Dodge.Block.Debris
-import qualified Data.IntMap.Strict as IM
-import Dodge.Zoning.Pathing
-import Dodge.Zoning.Base
-import Geometry.Data
-import Control.Lens
-import Data.Maybe
-import Dodge.Data.World
 import Dodge.ShiftPoint
 import Dodge.SoundLogic
+import Dodge.Wall.Delete
 import Dodge.Wall.Move
 import Dodge.WorldBool
-import qualified Data.Set as S
+import Dodge.Zoning.Base
+import Dodge.Zoning.Pathing
+import Geometry.Data
+import LensHelp
+import Linear
+import Picture.Data
+import Shape.Data
 
-updateDoor ::  Door -> World -> (S.Set Int2, World)
+updateDoor :: Door -> World -> (S.Set Int2, World)
 updateDoor dr w
-    | dr ^. drHP < 1 =  destroyDoor dr w
+    | dr ^. drHP < 1 = destroyDoor dr w
     | DoorLerp x <- dr ^. drUpdate = doorLerp x dr w
-    | otherwise = (mempty,w)
+    | otherwise =
+        ( mempty
+        , foldl' (doDoorMount (doDoorLerp dr (dr ^. drLerp))) w (dr ^. drMounts)
+        )
 
-doorLerp :: Float -> Door -> World -> (S.Set Int2,World)
-doorLerp speed dr w = fromMaybe (mempty,w) $ do
+doDoorMount :: Point2A -> World -> MountedObject -> World
+doDoorMount pa w = \case
+    MountedLight p r c ->
+        w & cWorld . lWorld . lights
+            .:~ LSParam (p & _xy %~ shiftPointBy pa) r c
+    MountedSPic x ->
+        w & cWorld . lWorld . tempSPic
+            <>~ ( x & _1 . each . sfVs . each . _xy %~ shiftPointBy pa
+                    & _2 . each . vxPos . _xy %~ shiftPointBy pa
+                )
+    _ -> w
+
+doorLerp :: Float -> Door -> World -> (S.Set Int2, World)
+doorLerp speed dr w = fromMaybe (mempty,domounts (dr ^. drLerp) w) $ do
     x <- newlerp
     let ps = wlposs x
         is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
     -- it seems possible that this will miss some paths: we don't add zones for the
     -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
-    return (is,
-        f x
+    return
+        ( is
+        , domounts x $ f x
             & playSound x
-            & cWorld . lWorld . doors . ix drid . drLerp .~ x)
+            & cWorld . lWorld . doors . ix drid . drLerp .~ x
+        )
   where
+    domounts x w' = foldl' (doDoorMount (doDoorLerp dr x)) w' (dr ^. drMounts)
     f = ifoldl' (flip . moveWallID) w . wlposs
     wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
     clerp = dr ^. drLerp
@@ -52,14 +75,16 @@ doorLerp speed dr w = fromMaybe (mempty,w) $ do
 
 destroyDoor :: Door -> World -> (S.Set Int2, World)
 destroyDoor dr w =
-    (is,w
+    ( is
+    , w
         & makeDoorDebris dr
         & deleteWallIDs wlids
         & cWorld . lWorld . doors %~ IM.delete (_drID dr)
---        & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr))
---        & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps)
+        --        & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr))
+        --        & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps)
         & stopPushing (_drPushes dr)
-        & destroyMounts (_drMounts dr))
+        & destroyMounts (_drMounts dr)
+    )
   where
     is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
     ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr (dr ^. drLerp))
@@ -72,6 +97,8 @@ destroyMount :: MountedObject -> World -> World
 destroyMount mo = case mo of
     MountedLS lsid -> destroyLS lsid
     MountedProp prid -> cWorld . lWorld . props . at prid .~ Nothing
+    MountedLight{} -> id -- should make sound + flash
+    MountedSPic{} -> id -- make debris?
 
 stopPushing :: Maybe Int -> World -> World
 stopPushing mdrid w = fromMaybe w $ do

src/Dodge/Placement/Instance/LightSource.hs

@@ -58,7 +58,6 @@ moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition
             , _prUpdate = PropUpdateId
             , --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
               _prDraw = noPic sh
-            , _prToggle = True
             }
 
 -- | mount a light source on a shape

src/Dodge/Prop/Update.hs

@@ -1,4 +1,4 @@
-module Dodge.Prop.Update where
+module Dodge.Prop.Update (updateProp) where
 
 import Control.Lens
 import Data.Foldable
@@ -11,13 +11,10 @@ import Dodge.WorldBool
 updateProp :: Prop -> World -> World
 updateProp pr = case _prUpdate pr of
     PropUpdateId -> id
-    PropRotate x -> rotateProp x pr
-    PropSetToggleAnd wb pu -> propSetToggleAnd wb pu pr
     PropUpdates pus -> doPropUpdates pr pus
     PropUpdateLS lsid x -> \w -> w & cWorld . lWorld . 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
@@ -35,16 +32,3 @@ 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 & cWorld . lWorld . props . ix (_prID pr) . prToggle .~ cond w
-
-rotateProp :: Float -> Prop -> World -> World
-rotateProp rotAmount pr w =
-    w
-        & cWorld . lWorld . props . ix (_prID pr) . prRot +~ rotAmount

src/Dodge/Render/ShapePicture.hs

@@ -41,6 +41,7 @@ worldSPic cfig u =
         <> foldup btSPic (filtOn _btPos _buttons)
         <> foldup (mcSPic (w ^. cWorld)) (filtOn _mcPos _machines)
         <> foldMap' drawChasm (w ^. cWorld . chasms)
+        <> w ^. cWorld . lWorld . tempSPic
   where
     w = u ^. uvWorld
     lw = w ^. cWorld . lWorld

src/Dodge/Room/Airlock.hs

@@ -3,6 +3,8 @@
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
 
+import Dodge.Room.Foreground
+import ShapePicture
 import Control.Lens
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
@@ -16,7 +18,6 @@ import Dodge.LevelGen.PlacementHelper
 import Dodge.LevelGen.Switch
 import Dodge.Placement.Instance
 import Dodge.Placement.Instance.Analyser
-import Dodge.Room.Foreground
 import Dodge.Room.Path
 import Dodge.RoomLink
 import Geometry
@@ -208,7 +209,8 @@ airlock90 =
                 (PS (V2 120 120) (3 * pi / 4))
                 xSwitch
                 $ \btid -> jsps (V2 5 5) 0 $ putDoor (WdBlBtOn btid) l1 x1 y1
-            , mntLS vShape (V2 35 35) (V3 70 70 50)
+                        & putDoorDoor . drMounts .~ themounts
+--            , mntLS vShape (V2 35 35) (V3 70 70 50)
             ]
         , _rmBound =
             pure
@@ -221,7 +223,14 @@ airlock90 =
         , _rmName = "airlock90"
         }
   where
+    themounts = 
+        [ MountedLight (V3 hl hl 50) 150 0.5
+        , MountedLight (V3 hl (-hl) 50) 150 0.5
+        , MountedSPic . noPic $ thinHighBar 55 (V2 hl (-hl')) (V2 hl hl')
+        ]
     lnks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)]
+    hl = 27.5
+    hl' = 30
     l1 = 55
     y1 = (0, 0)
     x1 = (0, pi / 2)

src/Dodge/Room/Tutorial.hs

@@ -45,13 +45,14 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
---        , return $ tToBTree "cor" $ return $ cleatOnward airlock90
-        , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , return $ tToBTree "cor" $ return $ cleatOnward airlock0
-        , return $ tToBTree "cor" $ return $ cleatOnward corridor
-        , tToBTree "x" . return . cleatOnward <$> airlockSimple
+        , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
+        , return $ tToBTree "cor" $ return $ cleatOnward airlock90
+        , corDoor
+--        , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , return $ tToBTree "cor" $ return $ cleatOnward airlock0
+--        , return $ tToBTree "cor" $ return $ cleatOnward corridor
+--        , tToBTree "x" . return . cleatOnward <$> airlockSimple
 --        , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor
 --        , return $ tToBTree "cor" $ return $ cleatOnward corridor

src/Dodge/Update.hs

@@ -299,8 +299,9 @@ functionalUpdate =
         -- . over uvWorld updateInventorySelectionList
         . set (uvWorld . cWorld . lWorld . flares) []
         . set (uvWorld . cWorld . lWorld . lights) []
+        . set (uvWorld . cWorld . lWorld . tempSPic) mempty
         . updateAimPos
-        . over uvWorld updatePastWorlds
+        . over uvWorld updatePastWorlds  -- it might be possible to do this without storing stuff such as the temporary lights/flares etc
 
 updateAimPos :: Universe -> Universe
 updateAimPos u =