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

3 files changed, 153 insertions, 63 deletions

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