From 983db9f0cd1d0e4e7e26f53554c6aa368fabef05 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Sun, 22 Feb 2026 22:55:55 -0700 Subject: [fix] - Make the up/down/left/right workspace navigation robust. --- src/Rahm/Desktop/Workspaces.hs | 105 +++++++++++++++++++++++++++++++++++++---- 1 file changed, 96 insertions(+), 9 deletions(-) (limited to 'src/Rahm/Desktop/Workspaces.hs') 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 -- cgit