diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Geometry.hs | 230 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys/Wml.hs | 41 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Workspaces.hs | 105 |
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 |