Move towards unifying door movement

src/Dodge/Data/Door.hs

@@ -16,6 +16,7 @@ import Dodge.Data.MountedObject
 import Dodge.Data.PathGraph
 import Dodge.Data.WorldEffect
 import Geometry.Data
+import qualified Data.IntMap.Strict as IM
 
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
     deriving Eq
@@ -35,6 +36,10 @@ data Door = Door
     , _drPos :: (Point2, Point2)
     , _drOpenPos :: (Point2, Point2)
     , _drClosePos :: (Point2, Point2)
+    , _drZeroPos :: (Point2,Float)
+    , _drOnePos :: (Point2,Float)
+    , _drLerp :: Float
+    , _drFootPrint :: IM.IntMap (Point2,Point2)
     , _drHP :: Int
     , _drDeath :: DrWdWd
     , _drSpeed :: Float

src/Dodge/Data/WorldEffect.hs

@@ -67,6 +67,7 @@ data DrWdWd
     | DrWdMakeDoorDebris
     | DrWdMechanismStepwise Int [Int] [(Point2, Point2)]
     | DoorMechanism
+    | DoorLerp
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
     --deriving (Eq, Show, Read) --, Generic)

src/Dodge/Default/Door.hs

@@ -37,6 +37,10 @@ defaultDoor =
         , _drPos = (0, 0)
         , _drOpenPos = (0, 0)
         , _drClosePos = (0, 0)
+        , _drZeroPos = (0,0)
+        , _drOnePos = (0,0)
+        , _drLerp = 0
+        , _drFootPrint = mempty
         , _drHP = 10000
         , _drDeath = DrWdMakeDoorDebris
         , _drSpeed = 1

src/Dodge/DrWdWd.hs

@@ -1,5 +1,8 @@
 module Dodge.DrWdWd where
 
+import Dodge.ShiftPoint
+import Linear
+import Data.IntMap.Merge.Strict
 import Control.Lens
 import Data.Foldable
 import qualified Data.IntSet as IS
@@ -19,6 +22,7 @@ doDrWdWd dww = case dww of
     DrWdMakeDoorDebris -> makeDoorDebris
     DrWdMechanismStepwise nsteps wlids pss -> doorMechanismStepwise nsteps wlids pss
     DoorMechanism -> doorMechanism
+    DoorLerp -> doorLerp
 
 -- TODO sort out why DoorClosed status does not update correctly 22/06/23
 doorMechanism :: Door -> World -> World
@@ -51,6 +55,46 @@ doorMechanism dr w = case mvDir of
         | dist dpos dcp < 1 = cWorld . lWorld . doors . ix drid . drStatus .~ DoorClosed
         | otherwise = cWorld . lWorld . doors . ix drid . drStatus .~ DoorHalfway
 
+doorLerp :: Door -> World -> World
+doorLerp dr w = case newlerp of
+    Just x ->
+        w
+            & cWorld . lWorld . walls %~ merge dropMissing preserveMissing f 
+                (wlposs x)
+            & moveUpdate
+            & cWorld . lWorld . doors . ix drid . drLerp .~ x
+    Nothing -> w
+  where
+    f = zipWithMatched $ \_ l wl -> wl & wlLine .~ l
+    (zp,za) = dr^. drZeroPos
+    (yp,ya) = dr^. drOnePos
+    p2a x = (zp + x *^ (yp - zp) , za + x * diffAngles ya za)
+    wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (p2a x)
+    clerp = dr ^. drLerp
+    newlerp
+        | toOpen && clerp < 1 = Just . min 1 $ clerp + 0.1
+        | clerp > 0 = Just . max 1 $ clerp - 0.1
+        | otherwise = Nothing
+    toOpen = doWdBl (_drTrigger dr) w
+    mvDir
+        | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary
+        | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop
+        | dist dpos dcp > 0.5 = Just $ vecBetweenSpeed speed dpos dcp
+        | otherwise = Nothing
+    speed = _drSpeed dr
+    drid = _drID dr
+    moveUpdate = playSound . setStatus
+    playSound
+        | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
+        | otherwise = id
+    dpos = snd $ _drPos dr
+    dop = snd $ _drOpenPos dr
+    dcp = snd $ _drClosePos dr
+    setStatus
+        | dist dpos dop < 1 = cWorld . lWorld . doors . ix drid . drStatus .~ DoorOpen
+        | dist dpos dcp < 1 = cWorld . lWorld . doors . ix drid . drStatus .~ DoorClosed
+        | otherwise = cWorld . lWorld . doors . ix drid . drStatus .~ DoorHalfway
+
 -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
 -- TODO update _drPos
 -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed

src/Dodge/Placement/PlaceSpot.hs

@@ -39,7 +39,7 @@ placeSpot rid w plmnt = case plmnt of
   where
     shift = _rmShift $ w ^?! genRooms . ix rid
 
-placePlainPSSpot :: GenWorld -> Int -> Placement -> DPoint2 -> GenWorld
+placePlainPSSpot :: GenWorld -> Int -> Placement -> Point2A -> GenWorld
 placePlainPSSpot w rid plmnt shift = case plmnt ^. plType of
     RandPS rgn ->
         let (x, g) = runState rgn (w ^. gwWorld . randGen)
@@ -89,7 +89,7 @@ placeSpotUsingLink w rid plmnt extract eff fallback =
 placeSpotRoomRand ::
     Int ->
     Int ->
-    (DPoint2 -> PlacementSpot) ->
+    (Point2A -> PlacementSpot) ->
     Placement ->
     GenWorld ->
     GenWorld

src/Dodge/Room/Tutorial.hs

@@ -43,6 +43,7 @@ tutAnoTree = do
     foldMTRS
         [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
         , corDoor
+        , tToBTree "asdf" . return . cleatOnward <$> airlockZ 
         , return $ tToBTree "cor" $ return $ cleatOnward corridor
         , tToBTree "t" . return . cleatOnward <$> slowDoorRoom
         , corDoor

src/Dodge/ShiftPoint.hs

@@ -1,12 +1,14 @@
 {-# LANGUAGE BangPatterns #-}
+
 module Dodge.ShiftPoint where
+
 import Geometry
 
-shiftPointBy :: (Point2,Float) -> Point2 -> Point2
-shiftPointBy (pos,rot) !p = pos +.+ rotateV rot p
+shiftPointBy :: Point2A -> Point2 -> Point2
+shiftPointBy (pos, rot) !p = pos +.+ rotateV rot p
 
-invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
-invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
+invShiftPointBy :: (Point2, Float) -> Point2 -> Point2
+invShiftPointBy (p1, r) p2 = rotateV (- r) $ p2 -.- p1
 
-shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
-shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
+shiftPoint3By :: (Point2, Float) -> Point3 -> Point3
+shiftPoint3By (pos, rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)

src/Geometry/Data.hs

@@ -45,7 +45,7 @@ instance ToJSON a => ToJSON (V4 a) where
 
 instance FromJSON a => FromJSON (V4 a)
 
-type DPoint2 = (Point2, Float)
+type Point2A = (Point2, Float)
 
 type QFloat = Q.Quaternion Float