[fix] - Make the up/down/left/right workspace navigation robust.HEADmain

3 files changed, 340 insertions, 36 deletions

diff --git a/src/Geometry.hs b/src/Geometry.hs
new file mode 100644
index 0000000..dd8d8e1
--- /dev/null
+++ b/src/Geometry.hs
@@ -0,0 +1,230 @@
+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/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 19538fc..e5c45e7 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -480,11 +480,11 @@ readNextWorkspace =
     case key of
       (mask, keysym, _)
         | (Just macro) <- Map.lookup (mask, keysym) macros -> do
-            pushKeys macro
-            readNextWorkspace
+          pushKeys macro
+          readNextWorkspace
       (_, _, [ch])
         | isAlphaNum ch || ch == '*' ->
-            return $ justWorkspace [ch]
+          return $ justWorkspace [ch]
       (_, _, "[") ->
         justWorkspace
           <$> ( lift1 (adjacentWorkspaceNotVisible prev)
@@ -538,36 +538,23 @@ readNextWorkspace =
         floatWorkspace <$> readNextWorkspace
       -- Workspace to the next screen to the right of the next workspace.
       (_, _, ",") -> do
-        ws <- readNextWorkspace
-        screens <-
-          liftXToFeed $
-            map (W.tag . W.workspace . snd)
-              <$> withWindowSet (return . getScreensOnSamePlane)
+        ws <- readNextWorkspaceName
+        liftXToFeed $ justWorkspace <$> getWorkspaceToTheRight ws
 
-        let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
-
-        justWorkspace <$> hoistMaybe (head $ tail rest)
+      -- Workspace on the screen below the current workspace..
+      (_, _, "%") -> do
+        ws <- readNextWorkspaceName
+        liftXToFeed $ justWorkspace <$> getWorkspaceAbove ws
 
       -- Workspace on the screen above the current workspace..
       (_, _, "+") -> do
-        screens <-
-          liftXToFeed $
-            map (W.tag . W.workspace . snd)
-              <$> withWindowSet (return . getScreensOnDifferentPlane)
-
-        justWorkspace <$> hoistMaybe (head screens)
+        ws <- readNextWorkspaceName
+        liftXToFeed $ justWorkspace <$> getWorkspaceAbove ws
 
       -- Workspace to the next screen to the left of the next workspace.
       (_, _, ";") -> do
-        ws <- readNextWorkspace
-        screens <-
-          liftXToFeed $
-            map (W.tag . W.workspace . snd)
-              <$> withWindowSet (return . reverse . getHorizontallyOrderedScreens)
-
-        let (_, rest) = break ((== workspaceName ws) . Just) (screens ++ screens)
-
-        justWorkspace <$> hoistMaybe (head $ tail rest)
+        ws <- readNextWorkspaceName
+        liftXToFeed $ justWorkspace <$> getWorkspaceToTheLeft ws
 
       -- The workspace with the searched for window.
       (_, _, "/") ->
@@ -695,7 +682,7 @@ readNextLocationSet' =
       -- Windows in a workspace
       (_, _, s)
         | s == "\t" || s == "@" || s == "\n" ->
-            (liftXToFeed . workspaceWindows) =<< readNextWorkspace
+          (liftXToFeed . workspaceWindows) =<< readNextWorkspace
       -- The first window in the next window set.
       (_, _, "!") -> (: []) <$> absorbMaybe (head <$> readNextLocationSet)
       -- The windows except the first in a window set.
diff --git a/src/Rahm/Desktop/Workspaces.hs b/src/Rahm/Desktop/Workspaces.hs
index 47a4e31..48ed523 100644
--- a/src/Rahm/Desktop/Workspaces.hs
+++ b/src/Rahm/Desktop/Workspaces.hs
@@ -17,6 +17,11 @@ module Rahm.Desktop.Workspaces
     workspaceWithWindow,
     getScreensOnSamePlane,
     getScreensOnDifferentPlane,
+    getWorkspacesAlongLine,
+    getWorkspaceToTheRight,
+    getWorkspaceToTheLeft,
+    getWorkspaceAbove,
+    getWorkspaceBelow,
     WorkspaceState (..),
   )
 where
@@ -24,11 +29,13 @@ where
 import Control.Arrow (Arrow ((&&&)))
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
-import Data.Char (isUpper, toLower, toUpper, chr, ord, isDigit)
+import Data.Char (chr, isDigit, isUpper, ord, toLower, toUpper)
+import Data.Int (Int32)
 import Data.List (find, sort, sortBy, sortOn, (\\))
 import Data.List.Safe ((!!))
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import Debug.Trace
+import qualified Geometry
 import Rahm.Desktop.Common (getCurrentWorkspace, gotoWorkspace, runMaybeT_)
 import Rahm.Desktop.Logger
 import qualified Rahm.Desktop.StackSet as W
@@ -128,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
 
@@ -144,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]
@@ -186,11 +193,12 @@ viewAdjacentTo wsM (Selector sel) = runMaybeT_ $ do
   lift $ logs Debug "viewAdjacentTo"
   tag <- MaybeT wsM
   lift $ logs Debug "from: %s" tag
-  ws <- MaybeT $ withWindowSet $ \ws ->
-    let vis = map (W.tag . W.workspace) (W.screens ws)
-        allW = sort $ map (W.tag . snd) (getPopulatedWorkspaces ws)
-        final = allW \\ (vis \\ [tag])
-     in return $ sel (== tag) final
+  ws <- MaybeT $
+    withWindowSet $ \ws ->
+      let vis = map (W.tag . W.workspace) (W.screens ws)
+          allW = sort $ map (W.tag . snd) (getPopulatedWorkspaces ws)
+          final = allW \\ (vis \\ [tag])
+       in return $ sel (== tag) final
   lift $ logs Debug "to: %s" ws
   lift $ windows $ W.switchWorkspaces tag ws
 
@@ -215,3 +223,82 @@ workspaceWithWindow wid = withWindowSet $ \(W.StackSet c v h _) ->
       <$> find
         (\(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
+
+getWorkspaceToTheRight :: WorkspaceId -> X WorkspaceId
+getWorkspaceToTheRight w = getWorkspaceAlong w (1, 0) False
+
+getWorkspaceToTheLeft :: WorkspaceId -> X WorkspaceId
+getWorkspaceToTheLeft w = getWorkspaceAlong w (1, 0) True
+
+getWorkspaceAbove :: WorkspaceId -> X WorkspaceId
+getWorkspaceAbove w = getWorkspaceAlong w (0, 1) True
+
+getWorkspaceBelow :: WorkspaceId -> X WorkspaceId
+getWorkspaceBelow w = getWorkspaceAlong w (0, 1) False
+
+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)
+
+getWorkspaceCenter :: WorkspaceId -> X (Maybe (Int32, Int32))
+getWorkspaceCenter w = withWindowSet $ \(W.StackSet cur vis _ _) ->
+  let currentCenter = getScreenCenter cur
+      visibleCenters = map getScreenCenter vis
+      allCenters = currentCenter : visibleCenters
+      matchingCenters = filter ((== w) . snd) allCenters
+   in return $ if null matchingCenters then Nothing else Just (fst (head matchingCenters))
+  where
+    getScreenCenter screen =
+      let SD (Rectangle x y w h) = W.screenDetail screen
+          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 x [] = x
+lookupNext target (x : xs)
+  | x == target = if null xs then target else head xs
+  | otherwise = lookupNext target xs