Fix bugs in zones near segments

src/Dodge/Data/Config.hs

@@ -66,6 +66,8 @@ windowYFloat = fromIntegral . _windowY
 data DebugBool
     = Show_ms_frame
     | Display_debug
+    | Debug_get
+    | Debug_put
     | Show_sound
     | Noclip
     | Cr_status

src/Dodge/Data/Universe.hs

@@ -11,6 +11,7 @@ module Dodge.Data.Universe (
     module Loop.Data,
 ) where
 
+import qualified Data.IntMap.Strict as IM
 import Geometry.Data
 import Sound.Data
 import qualified Data.Map.Strict as M
@@ -44,6 +45,7 @@ data Universe = Universe
     , _uvDebugFloat2 :: Float
     , _uvDebugV2_1 :: Point2
     , _uvDebugV2_2 :: Point2
+    , _uvDebugPut :: IM.IntMap String
     , _uvDebugPathShowType :: PathShowType
     , _uvDebugMessageOffset :: Int
     , _uvSoundQueue :: [SoundID]  -- sounds without a position, to be played once

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

src/Dodge/Debug/Picture.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS -Wno-incomplete-uni-patterns #-}
 module Dodge.Debug.Picture where
 
-import Linear (_xy)
+import Linear (_xy, (*^))
 import Control.Lens
 import Data.Foldable
 --import qualified Data.Graph.Inductive as FGL
@@ -147,11 +147,12 @@ drawWallsNearSegment w = concat $ do
 
 -- # OPTIONS -Wno-incomplete-uni-patterns #-}
 drawZoneCol :: Color -> Float -> V2 Int -> Picture
-drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
+drawZoneCol col = drawZone (\ps -> color col $ thickLine 2 (ps ++ [head ps]))
+
+drawZone :: ([Point2] -> Picture) -> Float -> V2 Int -> Picture
+drawZone f s (V2 x y) = setLayer DebugLayer $ f ps
   where
-    (p : ps) =
-        zipWith (+.+) (square 1) $
-            map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
+    ps = rectNSWE s 0 0 s <&> (+ s *^ (V2 x y & each %~ fromIntegral))
 
 --showEnabledDebugs :: Config -> Picture
 --{-# INLINE showEnabledDebugs #-}
@@ -310,11 +311,21 @@ drawZoneCirc w = concat $ do
 drawDDATest :: World -> Picture
 drawDDATest w =
     foldMap (drawZoneCol orange 50) ps
-        <> setLayer DebugLayer (color yellow (line [cvf, mwp]))
+        <> foldMap (drawZone f 50) qs
+        <> foldMap (drawZone g 50) rs
+        <> foldMap (drawCrossCol yellow) xs
+--        <> foldMap (drawCrossCol cyan) xs'
+        <> setLayer DebugLayer (color yellow (line [x, y]))
   where
-    cvf = w ^. wCam . camViewFrom
-    mwp = mouseWorldPos (w ^. input) (w ^. wCam)
-    ps = zoneOfSeg 50 cvf mwp
+    x = w ^. wCam . camViewFrom
+    y = mouseWorldPos (w ^. input) (w ^. wCam)
+    f [a,b,c,d] = color red $ thickLine 2 [a,c]
+    g [a,b,c,d] = color blue $ thickLine 2 [b,d]
+    ps = zoneOfSeg 50 x y
+    qs = map (zoneOfPoint 50) $ xIntercepts' 50 x y
+    rs = map (zoneOfPoint 50) $ yIntercepts' 50 x y
+    xs = xIntercepts' 50 x y
+--    xs' = xIntercepts' 50 x y
 
 drawWallSearchRays :: World -> Picture
 drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w

src/Dodge/Path.hs

@@ -1,5 +1,6 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Path (
+    nodesNear,
     pointTowardsImpulse,
     makePathBetween,
     makePathBetweenPs,
@@ -72,9 +73,11 @@ pathEdgeObstructed pe = any (`Set.member` pe) [WallObstacle WallNotAutoOpen, Cha
 
 walkableNodeNear :: World -> Point2 -> Maybe Int
 {-# INLINE walkableNodeNear #-}
-walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
-  where
-    nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
+walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear w p
+--  where
+--    nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
+
+nodesNear w p = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
 
 snailAround :: Int2 -> [Int2]
 snailAround x = (x +) <$> smallSnailInt2

src/Dodge/TestString.hs

@@ -32,8 +32,9 @@ import Data.Foldable
 import Data.Monoid
 
 testStringInit :: Universe -> [String]
-testStringInit u = [show $ foldMap (foldMap (Sum . length . (^. seObstacles))) 
-    $ u ^. uvWorld . cWorld . incGraph]
+testStringInit _ = []
+--    [show $ foldMap (foldMap (Sum . length . (^. seObstacles))) 
+--    $ u ^. uvWorld . cWorld . incGraph]
     -- foldMap prettyShort $ u ^? uvWorld . cWorld . lWorld . machines . ix 0 . mcType . _McProxSensor
 --testStringInit u = foldMap prettyShort $ u ^.. uvWorld . cWorld . lWorld . machines
 

src/Dodge/Zoning/Base.hs

@@ -11,6 +11,8 @@ module Dodge.Zoning.Base
     , zoneOfCirc
     , zonesAroundPoint
     , xIntercepts
+    , xIntercepts'
+    , yIntercepts'
     , yIntercepts
     , updateInt2Map
     ) where
@@ -48,7 +50,8 @@ zoneOfPoint = fmap . divTo
 
 zoneOfSeg :: Float -> Point2 -> Point2 -> [Int2]
 {-# INLINE zoneOfSeg #-}
-zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+--zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts s sp ep ++ yIntercepts s sp ep)
+zoneOfSeg s sp ep = map (zoneOfPoint s) (sp : xIntercepts' s sp ep ++ yIntercepts' s sp ep)
 
 zoneOfSegSet :: Float -> Point2 -> Point2 -> S.Set Int2
 {-# INLINE zoneOfSegSet #-}
@@ -79,12 +82,30 @@ xIntercepts s (V2 sx sy) (V2 ex ey)
         | xdx < 0 = sx - modTo s sx
         | otherwise = s + sx - modTo s sx
 
+xIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE xIntercepts' #-}
+xIntercepts' s (V2 sx sy) (V2 ex ey) 
+    | divTo s sx == divTo s ex = []
+    | otherwise = g <$> [a, a + s .. b]
+  where
+    (a,b) | sx < ex = (ceilingTo s sx,floorTo s ex)
+          | otherwise = (ceilingTo s ex,floorTo s sx)
+    g x = V2 (h + x) (f x)
+    h = 0.5 * s * signum (ex - sx)
+    f x = sy + (x - sx) * (ey - sy) / (ex - sx)
+
 yIntercepts :: Float -> Point2 -> Point2 -> [Point2]
 {-# INLINE yIntercepts #-}
 yIntercepts s sp ep = map f $ xIntercepts s (f sp) (f ep)
   where
     f (V2 x y) = V2 y x
 
+yIntercepts' :: Float -> Point2 -> Point2 -> [Point2]
+{-# INLINE yIntercepts' #-}
+yIntercepts' s sp ep = map f $ xIntercepts' s (f sp) (f ep)
+  where
+    f (V2 x y) = V2 y x
+
 -- consider using: at x . non mempty . at y . non mempty <>~ a
 zoneMonoid :: Semigroup m => Int2 -> m -> IM.IntMap (IM.IntMap m) -> IM.IntMap (IM.IntMap m)
 {-# INLINE zoneMonoid #-}

src/Geometry/Zone.hs

@@ -1,12 +1,20 @@
 module Geometry.Zone
     ( divTo
     , modTo
+    , floorTo
+    , ceilingTo
     ) where
 
 divTo :: Float -> Float -> Int
 {-# INLINE divTo #-}
 divTo s = floor . (/s)
 
+floorTo :: Float -> Float -> Float
+floorTo s x = s * fromIntegral (divTo s x)
+
+ceilingTo :: Float -> Float -> Float
+ceilingTo s x = s * (1 + fromIntegral (divTo s x))
+
 modTo :: Float -> Float -> Float
 {-# INLINE modTo #-}
 modTo s x = x - s * fromIntegral (divTo s x)