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

2 files changed, 110 insertions, 36 deletions

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