Fix bugs in zones near segments

src/Dodge/Debug.hs

@@ -2,6 +2,13 @@
 
 module Dodge.Debug (debugEvents, drawDebug) where
 
+import Geometry.Data
+import Dodge.WorldBool
+import Dodge.Zoning.Pathing
+import Dodge.Door.DoorLerp
+import Dodge.ShiftPoint
+import Dodge.Path
+import Dodge.Zoning.Base
 import Control.Lens
 import Control.Monad
 import qualified Data.IntMap.Strict as IM
@@ -67,6 +74,87 @@ debugItem = \case
     Show_path_between -> Just . return . debugShowPath
     Show_writable_values -> debugWritableValues
     Show_mouse_click_pos -> debugMouseClickPos
+    Debug_get -> doDebugGet
+    Debug_put -> debugPutItems
+
+debugGet :: Universe -> [String]
+debugGet u = [maybe "DebugGetFail" show $ debugGet1 u
+    , maybe "DebugGetFail" show $ debugGet2 u
+    , maybe "DebugGetFail" show $ debugGet3 u
+    ]
+
+--debugGet1 :: Show a => Universe -> Maybe a
+debugGet1 u = do
+    dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
+    let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+        ps = wlposs (dr ^. drLerp)
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
+    return $ S.toList is
+
+debugGet2 u = do
+    let w = u ^. uvWorld
+    dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
+    let clerp = dr ^. drLerp
+        speed = dr ^?! drUpdate . drLerpSpeed
+        toOpen = doWdBl (_drTrigger dr) w
+        newlerp
+            | toOpen && clerp < 1 = Just . min 1 $ clerp + speed
+            | clerp > 0 && not toOpen = Just . max 0 $ clerp - speed
+            | otherwise = Nothing
+    x <- newlerp
+    let wlposs y = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr y)
+        ps = wlposs x
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
+    return $ show is
+    
+
+debugGet3 u = do
+    dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
+    let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+        ps = wlposs (dr ^. drLerp)
+        is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
+    return $ show is
+
+debugPutItems :: Universe -> Maybe [DebugItem]
+debugPutItems u = Just $ f <$> [0..debugPutN]
+  where
+    f i = DebugItem (g i) (doDebugPut i) -- (uvIOEffects %~ doDebugPut i)
+    g i = fromMaybe "Not assigned" $ u ^? uvDebugPut . ix i
+
+debugPutN :: Int
+debugPutN = 5
+
+doDebugPut :: Int -> Universe -> Universe
+doDebugPut i u
+    | u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0 = u 
+        & uvIOEffects %~ \ f u' -> do 
+            s <- getClipboard
+            f $ u & uvDebugPut . at i ?~ s
+    | otherwise = u
+
+debugPutDraw :: IM.IntMap String -> Universe -> Picture
+debugPutDraw _ u = drawthedoor u <> drawthezones u
+
+drawthezones u = fold $ do
+    is <- readMaybe =<< u ^? uvDebugPut . ix 0
+    let f :: [Int2] -> [Int2]
+        f = id
+    return $ foldMap (drawZoneCol yellow peZoneSize) $ f is
+
+drawthedoor u = fold $ do
+    dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
+    let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+        ps = wlposs (dr ^. drLerp)
+    return $ setLayer DebugLayer $ color blue $ foldMap g ps
+  where
+    g (x,y) = line [x,y]
+
+doDebugGet :: Universe -> Maybe [DebugItem]
+doDebugGet u =
+    Just $ f <$> debugGet u
+  where
+    f s = DebugItem s (setClip s)
+
 
 debugShowPath :: Universe -> DebugItem
 debugShowPath u =
@@ -172,6 +260,8 @@ setClip s u = fromMaybe u $ do
 
 drawDebug :: Universe -> DebugBool -> Picture
 drawDebug u = \case
+    Debug_put -> debugPutDraw (u ^. uvDebugPut) u
+    Debug_get -> mempty
     Collision_test -> drawCollisionTest $ _uvWorld u
     Circ_collision_test -> drawCircCollisionTest $ _uvWorld u
     Show_walls_near_point_cursor -> drawWallsNearCursor $ _uvWorld u