[bugfix] use better algorithm to determine navigating screens in 2D.

4 files changed, 153 insertions, 293 deletions

diff --git a/src/Geometry.hs b/src/Geometry.hs
deleted file mode 100644
index dd8d8e1..0000000
--- a/src/Geometry.hs
+++ /dev/null
@@ -1,230 +0,0 @@
-module Geometry
-  ( Line (..),
-    lineThrough2Points,
-    lineThroughPointWithAngle,
-    LineSide (..),
-    sideOfLine,
-    proj,
-    perp',
-    orthoproj,
-    distPointLine,
-    distPointSegment,
-    rotate,
-    -- Rectangle types
-    GeometryRectangle (..),
-    rectangleToGeometry,
-    geometryToRectangle,
-    -- Intersection
-    IntersectionResult (..),
-    getIntersectingRectangles,
-  )
-where
-
-import Data.Int (Int32)
-import Data.List (sortOn)
-import Data.Maybe (catMaybes, listToMaybe)
-import Graphics.X11 (Rectangle (..))
-import Prelude hiding (subtract)
-
--- | A line in parametric form: (x + t*dx, y + t*dy) for t ∈ ℝ
-data Line a = Line
-  { x :: !a,
-    y :: !a,
-    dx :: !a,
-    dy :: !a
-  }
-  deriving (Eq, Show, Read)
-
--- | Construct a line passing through two points
-lineThrough2Points :: (Num a, Ord a) => (a, a) -> (a, a) -> Line a
-lineThrough2Points (x1, y1) (x2, y2) =
-  Line
-    { x = x1,
-      y = y1,
-      dx = x2 - x1,
-      dy = y2 - y1
-    }
-
--- | Construct a line through a point with a given angle (in radians)
---   Angle is measured counterclockwise from the positive x-axis
-lineThroughPointWithAngle :: (Floating a, Ord a) => (a, a) -> a -> Line a
-lineThroughPointWithAngle (x, y) angle =
-  Line
-    { x = x,
-      y = y,
-      dx = cos angle,
-      dy = sin angle
-    }
-
--- | Which side of the line is a point on?
-data LineSide
-  = LeftSide
-  | RightSide
-  | OnLine
-  deriving (Eq, Show)
-
--- | Determine which side of the line a point lies on
---   Uses the cross product to determine orientation
-sideOfLine :: (Fractional a, Ord a) => Line a -> (a, a) -> LineSide
-sideOfLine line (px, py) =
-  case compare cross 0 of
-    GT -> LeftSide
-    LT -> RightSide
-    EQ -> OnLine
-  where
-    -- Vector from line origin to point
-    relX = px - x line
-    relY = py - y line
-    -- Cross product in 2D: (dx, dy) × (px, py) = dx*py - dy*px
-    cross = dx line * relY - dy line * relX
-
--- | Project point onto line
-proj :: (Fractional a, Ord a) => Line a -> (a, a) -> (a, a)
-proj line (px, py) =
-  (x line + t * dx line, y line + t * dy line)
-  where
-    -- Vector from line origin to point
-    relX = px - x line
-    relY = py - y line
-    -- t = (rel · direction) / (direction · direction)
-    dotProd = relX * dx line + relY * dy line
-    dirSq = dx line * dx line + dy line * dy line
-    t = dotProd / dirSq
-
--- | Perpendicular vector from point to line
-perp' :: (Fractional a, Ord a) => Line a -> (a, a) -> (a, a)
-perp' line point =
-  (px - projX, py - projY)
-  where
-    (projX, projY) = proj line point
-    (px, py) = point
-
--- | Orthogonal projection (same as proj, but returns the projected point)
-orthoproj :: (Fractional a, Ord a) => Line a -> (a, a) -> (a, a)
-orthoproj = proj
-
--- | Distance from point to line
-distPointLine :: (Floating a, Ord a) => Line a -> (a, a) -> a
-distPointLine line point =
-  sqrt (dx * dx + dy * dy)
-  where
-    (dx, dy) = perp' line point
-
--- | Distance from point to line segment (not infinite line)
-distPointSegment :: (Floating a, Ord a) => (a, a) -> (a, a) -> (a, a) -> a
-distPointSegment (ax, ay) (bx, by) (px, py)
-  | t <= 0 = sqrt (dx1 * dx1 + dy1 * dy1)
-  | t >= 1 = sqrt (dx2 * dx2 + dy2 * dy2)
-  | otherwise = sqrt (dx * dx + dy * dy)
-  where
-    abX = bx - ax
-    abY = by - ay
-    apX = px - ax
-    apY = py - ay
-    t = (apX * abX + apY * abY) / (abX * abX + abY * abY)
-    projX = ax + t * abX
-    projY = ay + t * abY
-    dx = px - projX
-    dy = py - projY
-    dx1 = px - ax
-    dy1 = py - ay
-    dx2 = px - bx
-    dy2 = py - by
-
--- | Rotate a point around the origin by an angle (in radians)
-rotate :: (Floating a, Ord a) => a -> (a, a) -> (a, a)
-rotate angle (x, y) =
-  (x * cos angle - y * sin angle, x * sin angle + y * cos angle)
-
--- | A simple Rectangle type for geometry operations
---   Uses (x, y) as the top-left corner, with width and height
-data GeometryRectangle a = GeometryRectangle
-  { geoX :: !a,
-    geoY :: !a,
-    geoWidth :: !a,
-    geoHeight :: !a
-  }
-  deriving (Eq, Show, Read)
-
--- | Convert X11's Rectangle to Geometry's Rectangle
-rectangleToGeometry :: Num a => Graphics.X11.Rectangle -> GeometryRectangle a
-rectangleToGeometry (Graphics.X11.Rectangle x y w h) =
-  GeometryRectangle
-    { geoX = fromIntegral x,
-      geoY = fromIntegral y,
-      geoWidth = fromIntegral w,
-      geoHeight = fromIntegral h
-    }
-
--- | Convert Geometry's Rectangle to X11's Rectangle
-geometryToRectangle :: Integral a => GeometryRectangle a -> Graphics.X11.Rectangle
-geometryToRectangle (GeometryRectangle x y w h) =
-  Graphics.X11.Rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
-
--- | Alias for GeometryRectangle for backwards compatibility
-type Rectangle a = GeometryRectangle a
-
--- | Result of intersecting a line with a rectangle
-data IntersectionResult a b = IntersectionResult
-  { tag :: a,
-    rectangle :: GeometryRectangle b,
-    intersectionPoint :: (b, b)
-  }
-  deriving (Eq, Show)
-
--- | Find all rectangles that intersect the given line, sorted by distance from origin
---   Returns tags of intersected rectangles in order of their intersection point
---   closest to (0,0)
-getIntersectingRectangles :: (Floating a, Ord a) => Line a -> [(GeometryRectangle a, b)] -> [IntersectionResult b a]
-getIntersectingRectangles line rects = catMaybes $ map (checkIntersection line) rects
-
--- | Check if a line intersects a rectangle, and if so, return the intersection point
---   closest to the origin
-checkIntersection :: (Floating a, Ord a) => Line a -> (GeometryRectangle a, b) -> Maybe (IntersectionResult b a)
-checkIntersection line (rect, tag) = IntersectionResult tag rect <$> findClosestIntersection line rect
-
--- | Find the intersection point closest to the origin
-findClosestIntersection :: (Floating a, Ord a) => Line a -> GeometryRectangle a -> Maybe (a, a)
-findClosestIntersection line rect =
-  listToMaybe $ sortOn distanceFromOrigin $ filter (pointInRectangle rect) candidates
-  where
-    -- Find intersections with each edge of the rectangle
-    topEdge = lineThrough2Points (geoX rect, geoY rect) (geoX rect + geoWidth rect, geoY rect)
-    bottomEdge = lineThrough2Points (geoX rect, geoY rect + geoHeight rect) (geoX rect + geoWidth rect, geoY rect + geoHeight rect)
-    leftEdge = lineThrough2Points (geoX rect, geoY rect) (geoX rect, geoY rect + geoHeight rect)
-    rightEdge = lineThrough2Points (geoX rect + geoWidth rect, geoY rect) (geoX rect + geoWidth rect, geoY rect + geoHeight rect)
-
-    candidates =
-      catMaybes
-        [ intersectLines line topEdge,
-          intersectLines line bottomEdge,
-          intersectLines line leftEdge,
-          intersectLines line rightEdge
-        ]
-
--- | Check if a point is inside a rectangle (including edges)
-pointInRectangle :: (Num a, Ord a) => GeometryRectangle a -> (a, a) -> Bool
-pointInRectangle rect (px, py) =
-  px >= geoX rect
-    && px <= geoX rect + geoWidth rect
-    && py >= geoY rect
-    && py <= geoY rect + geoHeight rect
-
--- | Find the intersection point of two lines, if it exists
-intersectLines :: (Fractional a, Eq a) => Line a -> Line a -> Maybe (a, a)
-intersectLines (Line x1 y1 dx1 dy1) (Line x2 y2 dx2 dy2) =
-  -- Solve: x1 + t*dx1 = x2 + s*dx2 and y1 + t*dy1 = y2 + s*dy2
-  -- Using Cramer's rule
-  let det = dx1 * (- dy2) - dy1 * (- dx2)
-      detT = (x2 - x1) * (- dy2) - (y2 - y1) * (- dx2)
-   in if det == 0
-        then Nothing -- Parallel lines
-        else
-          let t = detT / det
-              intersectionX = x1 + t * dx1
-              intersectionY = y1 + t * dy1
-           in Just (intersectionX, intersectionY)
-
--- | Euclidean distance from origin
-distanceFromOrigin :: (Num a, Floating a) => (a, a) -> a
-distanceFromOrigin (x, y) = sqrt (x * x + y * y)
diff --git a/src/Rahm/Desktop/Geometry.hs b/src/Rahm/Desktop/Geometry.hs
new file mode 100644
index 0000000..a0e8c92
--- /dev/null
+++ b/src/Rahm/Desktop/Geometry.hs
@@ -0,0 +1,108 @@
+module Rahm.Desktop.Geometry where
+
+import Data.List (minimumBy)
+import Data.Maybe (listToMaybe)
+import Data.Ord (comparing)
+import Debug.Trace (trace)
+import Text.Printf (printf)
+
+data GeomRectangle = GeomRectangle
+  { rectX, rectY, rectWidth, rectHeight :: Double
+  }
+  deriving (Show, Eq)
+
+data Direction = N | S | E | W
+  deriving (Show, Eq, Enum, Bounded)
+
+center :: GeomRectangle -> (Double, Double)
+center r = (rectX r + rectWidth r / 2, rectY r + rectHeight r / 2)
+
+-- Distance from reference center to the closest point on candidate in the given direction
+-- Assumes candidate is wholly in the given direction (verified elsewhere)
+distanceToEdgeInDirection :: Direction -> GeomRectangle -> GeomRectangle -> Double
+distanceToEdgeInDirection dir ref cand =
+  let (rx, ry) = center ref
+      (cx, cy) = center cand
+      left   = rectX cand
+      right  = rectX cand + rectWidth cand
+      top    = rectY cand
+      bottom = rectY cand + rectHeight cand
+  in case dir of
+       N -> -- candidate is above: closest point is on bottom edge
+            let dx = if rx < left then left - rx else if rx > right then right - rx else 0
+                dy = top - ry
+            in sqrt (dx*dx + dy*dy)
+       S -> -- candidate is below: closest point is on top edge
+            let dx = if rx < left then left - rx else if rx > right then right - rx else 0
+                dy = ry - bottom
+            in sqrt (dx*dx + dy*dy)
+       W -> -- candidate is to the left: closest point is on right edge
+            let dy = if ry < top then top - ry else if ry > bottom then bottom - ry else 0
+                dx = left - rx
+            in sqrt (dx*dx + dy*dy)
+       E -> -- candidate is to the right: closest point is on left edge
+            let dy = if ry < top then top - ry else if ry > bottom then bottom - ry else 0
+                dx = rx - right
+            in sqrt (dx*dx + dy*dy)
+
+
+boundingBox :: [GeomRectangle] -> (Double, Double, Double, Double)
+boundingBox rs =
+  let xs = map rectX rs
+      ys = map rectY rs
+      xMaxes = zipWith (+) (map rectX rs) (map rectWidth rs)
+      yMaxes = zipWith (+) (map rectY rs) (map rectHeight rs)
+   in (minimum xs, minimum ys, maximum xMaxes - minimum xs, maximum yMaxes - minimum ys)
+
+translate :: GeomRectangle -> Double -> Double -> GeomRectangle
+translate r dx dy =
+  GeomRectangle (rectX r + dx) (rectY r + dy) (rectWidth r) (rectHeight r)
+
+-- "Wholly in direction": candidate is completely in direction, with no overlap
+whollyInDirection :: Direction -> GeomRectangle -> GeomRectangle -> Bool
+whollyInDirection N r1 r2 = bottomEdge r1 <= topEdge r2
+whollyInDirection S r1 r2 = topEdge r1 >= bottomEdge r2
+whollyInDirection E r1 r2 = leftEdge r1 >= rightEdge r2
+whollyInDirection W r1 r2 = rightEdge r1 <= leftEdge r2
+
+topEdge, bottomEdge, leftEdge, rightEdge :: GeomRectangle -> Double
+topEdge r = rectY r
+bottomEdge r = rectY r + rectHeight r
+leftEdge r = rectX r
+rightEdge r = rectX r + rectWidth r
+
+-- Generate up to 2 tile copies: original + one tile in direction
+tileCandidates :: Direction -> Double -> Double -> GeomRectangle -> [GeomRectangle]
+tileCandidates dir sw sh r =
+  case dir of
+    N -> [r, translate r 0 (-sh)]
+    S -> [r, translate r 0 sh]
+    W -> [r, translate r (-sw) 0]
+    E -> [r, translate r sw 0]
+
+closestInDirection ::
+  (Eq a) =>
+  [(GeomRectangle, a)] ->
+  a ->
+  Direction ->
+  Maybe (GeomRectangle, a)
+closestInDirection rects tag dir = do
+  ref <- listToMaybe [r | (r, t) <- rects, t == tag]
+  let allRects = map fst rects
+      (_, _, sw, sh) = boundingBox allRects
+      sw' = if sw == 0 then 1 else sw
+      sh' = if sh == 0 then 1 else sh
+
+  let candidates =
+        [ (r, t, distanceToEdgeInDirection dir ref virt)
+          | (r, t) <- rects,
+            t /= tag,
+            virt <- tileCandidates dir sw' sh' r,
+            whollyInDirection dir virt ref
+        ]
+
+  case candidates of
+    [] -> Nothing
+    _ -> Just (r, t)
+      where
+        (r, t, _) = minimumBy (comparing (\(_, _, d) -> d)) candidates
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index e5c45e7..9122ccb 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -539,22 +539,22 @@ readNextWorkspace =
       -- Workspace to the next screen to the right of the next workspace.
       (_, _, ",") -> do
         ws <- readNextWorkspaceName
-        liftXToFeed $ justWorkspace <$> getWorkspaceToTheRight ws
+        hoistMaybeT $ justWorkspace <$> getWorkspaceToTheRight ws
 
       -- Workspace on the screen below the current workspace..
       (_, _, "%") -> do
         ws <- readNextWorkspaceName
-        liftXToFeed $ justWorkspace <$> getWorkspaceAbove ws
+        hoistMaybeT $ justWorkspace <$> getWorkspaceAbove ws
 
       -- Workspace on the screen above the current workspace..
       (_, _, "+") -> do
         ws <- readNextWorkspaceName
-        liftXToFeed $ justWorkspace <$> getWorkspaceAbove ws
+        hoistMaybeT $ justWorkspace <$> getWorkspaceBelow ws
 
       -- Workspace to the next screen to the left of the next workspace.
       (_, _, ";") -> do
         ws <- readNextWorkspaceName
-        liftXToFeed $ justWorkspace <$> getWorkspaceToTheLeft ws
+        hoistMaybeT $ justWorkspace <$> getWorkspaceToTheLeft ws
 
       -- The workspace with the searched for window.
       (_, _, "/") ->
diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs
index 48ed523..1bd5c51 100644
--- a/src/Rahm/Desktop/Workspaces.hs
+++ b/src/Rahm/Desktop/Workspaces.hs
@@ -17,7 +17,6 @@ module Rahm.Desktop.Workspaces
     workspaceWithWindow,
     getScreensOnSamePlane,
     getScreensOnDifferentPlane,
-    getWorkspacesAlongLine,
     getWorkspaceToTheRight,
     getWorkspaceToTheLeft,
     getWorkspaceAbove,
@@ -35,7 +34,7 @@ import Data.List (find, sort, sortBy, sortOn, (\\))
 import Data.List.Safe ((!!))
 import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import Debug.Trace
-import qualified Geometry
+import Rahm.Desktop.Geometry
 import Rahm.Desktop.Common (getCurrentWorkspace, gotoWorkspace, runMaybeT_)
 import Rahm.Desktop.Logger
 import qualified Rahm.Desktop.StackSet as W
@@ -51,6 +50,7 @@ import XMonad
     windows,
     withWindowSet,
   )
+import XMonad.Util.Loggers (logFileCount)
 import Prelude hiding ((!!))
 
 newtype Selector = Selector (forall a. (a -> Bool) -> [a] -> Maybe a)
@@ -135,7 +135,7 @@ getScreensOnSamePlane ss =
   where
     yCenter
       | (SD (Rectangle _ y _ h)) <- W.screenDetail . W.current $ ss =
-        (y + fromIntegral h) `div` 2
+          (y + fromIntegral h) `div` 2
     matchesYCenter (_, W.screenDetail -> (SD (Rectangle _ y _ h))) =
       y < yCenter && y + fromIntegral h > yCenter
 
@@ -151,7 +151,7 @@ getScreensOnDifferentPlane ss =
       y + (fromIntegral h `div` 2)
     matchesScreen yCenter
       | (SD (Rectangle _ y _ h)) <- W.screenDetail (W.current ss) =
-        yCenter < y + fromIntegral h && yCenter > y
+          yCenter < y + fromIntegral h && yCenter > y
 
 accompanyingWorkspace :: WorkspaceId -> WorkspaceId
 accompanyingWorkspace [s]
@@ -224,65 +224,47 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) ->
         (\(W.Workspace _ _ stack) -> wid `elem` W.integrate' stack)
         (map W.workspace (c : v) ++ h)
 
-getWorkspacesAlongLine :: Geometry.Line Int32 -> X [WorkspaceId]
-getWorkspacesAlongLine line = withWindowSet $ \windowSet ->
-  let extractRect :: ScreenDetail -> Geometry.GeometryRectangle Int32
-      extractRect (SD (Rectangle x y w h)) = Geometry.rectangleToGeometry (Rectangle x y w h)
-      convertRect :: Geometry.GeometryRectangle Int32 -> WorkspaceId -> (Geometry.GeometryRectangle Double, WorkspaceId)
-      convertRect (Geometry.GeometryRectangle x y w h) tag =
-        ( Geometry.GeometryRectangle
-            { Geometry.geoX = fromIntegral x,
-              Geometry.geoY = fromIntegral y,
-              Geometry.geoWidth = fromIntegral w,
-              Geometry.geoHeight = fromIntegral h
-            },
-          tag
-        )
-      currentRect = extractRect . W.screenDetail . W.current $ windowSet
-      currentTag = W.tag $ W.workspace $ W.current windowSet
-      currentWs = convertRect currentRect currentTag
-      visibleRects =
-        map
-          ( \screen ->
-              let rect = extractRect (W.screenDetail screen)
-                  tag = W.tag $ W.workspace screen
-               in convertRect rect tag
-          )
-          (W.visible windowSet)
-      rects = currentWs : visibleRects
-      intersecting = Geometry.getIntersectingRectangles line' rects
-      line' =
-        Geometry.Line
-          { Geometry.x = fromIntegral (Geometry.x line),
-            Geometry.y = fromIntegral (Geometry.y line),
-            Geometry.dx = fromIntegral (Geometry.dx line),
-            Geometry.dy = fromIntegral (Geometry.dy line)
-          }
-   in return $ map Geometry.tag intersecting
+getScreenRectangles :: X [(GeomRectangle, WorkspaceId)]
+getScreenRectangles =
+  withWindowSet $ \(W.StackSet cur vis _ _) -> do
+    return $ ofScreen cur : map ofScreen vis
+  where
+    ofScreen (W.Screen (W.tag -> t) _ (SD rect)) = (toGeom rect, t)
+    toGeom (Rectangle x y w h) =
+      GeomRectangle
+        (fromIntegral x)
+        (fromIntegral y)
+        (fromIntegral w)
+        (fromIntegral h)
 
-getWorkspaceToTheRight :: WorkspaceId -> X WorkspaceId
-getWorkspaceToTheRight w = getWorkspaceAlong w (1, 0) False
+getScreenRect :: WorkspaceId -> X (Maybe GeomRectangle)
+getScreenRect w = do
+  rects <- getScreenRectangles
+  return $ listToMaybe [r | (r, w') <- rects, w' == w]
 
-getWorkspaceToTheLeft :: WorkspaceId -> X WorkspaceId
-getWorkspaceToTheLeft w = getWorkspaceAlong w (1, 0) True
+getWorkspaceToTheRight :: WorkspaceId -> MaybeT X WorkspaceId
+getWorkspaceToTheRight w = do
+  refRect <- lift $ getScreenRect w
+  rects <- lift getScreenRectangles
+  MaybeT $ return (snd <$> closestInDirection rects w E)
 
-getWorkspaceAbove :: WorkspaceId -> X WorkspaceId
-getWorkspaceAbove w = getWorkspaceAlong w (0, 1) True
+getWorkspaceToTheLeft :: WorkspaceId -> MaybeT X WorkspaceId
+getWorkspaceToTheLeft w = do
+  refRect <- lift $ getScreenRect w
+  rects <- lift getScreenRectangles
+  MaybeT $ return (snd <$> closestInDirection rects w W)
 
-getWorkspaceBelow :: WorkspaceId -> X WorkspaceId
-getWorkspaceBelow w = getWorkspaceAlong w (0, 1) False
+getWorkspaceAbove :: WorkspaceId -> MaybeT X WorkspaceId
+getWorkspaceAbove w = do
+  refRect <- lift $ getScreenRect w
+  rects <- lift getScreenRectangles
+  MaybeT $ return (snd <$> closestInDirection rects w N)
 
-getWorkspaceAlong :: WorkspaceId -> (Int32, Int32) -> Bool -> X WorkspaceId
-getWorkspaceAlong w dir reverseResults = do
-  center <- getWorkspaceCenter w
-  case center of
-    Nothing -> return w
-    Just (cx, cy) -> do
-      let p1 = (cx, cy)
-          p2 = (cx + fst dir, cy + snd dir)
-      let line = Geometry.lineThrough2Points p1 p2
-      wss <- getWorkspacesAlongLine line
-      return $ if null wss then w else lookupNext w (if reverseResults then reverse wss else wss)
+getWorkspaceBelow :: WorkspaceId -> MaybeT X WorkspaceId
+getWorkspaceBelow w = do
+  refRect <- lift $ getScreenRect w
+  rects <- lift getScreenRectangles
+  MaybeT $ return (snd <$> closestInDirection rects w S)
 
 getWorkspaceCenter :: WorkspaceId -> X (Maybe (Int32, Int32))
 getWorkspaceCenter w = withWindowSet $ \(W.StackSet cur vis _ _) ->
@@ -297,7 +279,7 @@ getWorkspaceCenter w = withWindowSet $ \(W.StackSet cur vis _ _) ->
           wsTag = W.tag (W.workspace screen)
        in ((x + fromIntegral w `div` 2, y + fromIntegral h `div` 2), wsTag)
 
-lookupNext :: Eq a => a -> [a] -> a
+lookupNext :: (Eq a) => a -> [a] -> a
 lookupNext x [] = x
 lookupNext target (x : xs)
   | x == target = if null xs then target else head xs