From 0b01da5b4c2c9de8e3f0b7454cc5cb177aba1dd4 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 25 Feb 2026 16:48:21 -0700 Subject: [bugfix] use better algorithm to determine navigating screens in 2D. --- src/Geometry.hs | 230 ----------------------------------------- src/Rahm/Desktop/Geometry.hs | 108 +++++++++++++++++++ src/Rahm/Desktop/Keys/Wml.hs | 8 +- src/Rahm/Desktop/Workspaces.hs | 100 ++++++++---------- 4 files changed, 153 insertions(+), 293 deletions(-) delete mode 100644 src/Geometry.hs create mode 100644 src/Rahm/Desktop/Geometry.hs 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 -- cgit