{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp, PatternGuards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Layout.LayoutHints
-- Description :  Make layouts respect size hints.
-- Copyright    : (c) David Roundy <droundy@darcs.net>
-- License      : BSD
--
-- Maintainer   : none
-- Stability    : unstable
-- Portability  : unportable
--
-- Make layouts respect size hints.
-----------------------------------------------------------------------------

module XMonad.Layout.LayoutHints
    ( -- * usage
      -- $usage
      layoutHints
    , layoutHintsWithPlacement
    , layoutHintsToCenter
    , LayoutHints
    , LayoutHintsToCenter
    , hintsEventHook
    -- * For developers
    , placeRectangle
    )  where

import XMonad(LayoutClass(runLayout), mkAdjust, Window,
              Dimension, Position, Rectangle(Rectangle), D,
              X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS,
              (<&&>), io, applySizeHints, whenX, isClient, withDisplay,
              getWMNormalHints, WindowAttributes(..))
import XMonad.Prelude
import qualified XMonad.StackSet as W

import XMonad.Layout.Decoration(isInStack)
import XMonad.Layout.LayoutModifier(ModifiedLayout(..),
                                    LayoutModifier(modifyLayout, redoLayout, modifierDescription))
import XMonad.Util.Types(Direction2D(..))
import Control.Arrow(Arrow((***), first, second))

import Data.Set (Set)
import qualified Data.Set as Set

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Layout.LayoutHints
--
-- Then edit your @layoutHook@ by adding the 'layoutHints' layout modifier
-- to some layout:
--
-- > myLayout = layoutHints (Tall 1 (3/100) (1/2))  ||| Full ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
--
-- Or, to center the adapted window in its available area:
--
-- > myLayout = layoutHintsWithPlacement (0.5, 0.5) (Tall 1 (3/100) (1/2))
-- >                   ||| Full ||| etc..
--
-- Or, to make a reasonable attempt to eliminate gaps between windows:
--
-- > myLayout = layoutHintsToCenter (Tall 1 (3/100) (1/2))
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "XMonad.Doc.Extending#Editing_the_layout_hook".
--
-- To make XMonad reflect changes in window hints immediately, add
-- 'hintsEventHook' to your 'handleEventHook'.
--
-- > myHandleEventHook = hintsEventHook <> ...
-- >
-- > main = xmonad def { handleEventHook = myHandleEventHook
-- >                   , ... }

layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a
layoutHints :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHints l a
layoutHints = LayoutHints a -> l a -> ModifiedLayout LayoutHints l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout ((Double, Double) -> LayoutHints a
forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double
0, Double
0))

-- | @layoutHintsWithPlacement (rx, ry) layout@ will adapt the sizes of a layout's
-- windows according to their size hints, and position them inside their
-- originally assigned area according to the @rx@ and @ry@ parameters.
-- (0, 0) places the window at the top left, (1, 0) at the top right, (0.5, 0.5)
-- at the center, etc.
layoutHintsWithPlacement :: (LayoutClass l a) => (Double, Double)
                         -> l a -> ModifiedLayout LayoutHints l a
layoutHintsWithPlacement :: forall (l :: * -> *) a.
LayoutClass l a =>
(Double, Double) -> l a -> ModifiedLayout LayoutHints l a
layoutHintsWithPlacement (Double, Double)
rs = LayoutHints a -> l a -> ModifiedLayout LayoutHints l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout ((Double, Double) -> LayoutHints a
forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double, Double)
rs)

-- | @layoutHintsToCenter layout@ applies hints, sliding the window to the
-- center of the screen and expanding its neighbors to fill the gaps. Windows
-- are never expanded in a way that increases overlap.
--
-- @layoutHintsToCenter@ only makes one pass at resizing the neighbors of
-- hinted windows, so with some layouts (ex. the arrangement with two 'Mirror'
-- 'Tall' stacked vertically), @layoutHintsToCenter@ may leave some gaps.
-- Simple layouts like 'Tall' are unaffected.
layoutHintsToCenter :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter = LayoutHintsToCenter a
-> l a -> ModifiedLayout LayoutHintsToCenter l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout LayoutHintsToCenter a
forall a. LayoutHintsToCenter a
LayoutHintsToCenter

newtype LayoutHints a = LayoutHints (Double, Double)
                     deriving (ReadPrec [LayoutHints a]
ReadPrec (LayoutHints a)
Int -> ReadS (LayoutHints a)
ReadS [LayoutHints a]
(Int -> ReadS (LayoutHints a))
-> ReadS [LayoutHints a]
-> ReadPrec (LayoutHints a)
-> ReadPrec [LayoutHints a]
-> Read (LayoutHints a)
forall a. ReadPrec [LayoutHints a]
forall a. ReadPrec (LayoutHints a)
forall a. Int -> ReadS (LayoutHints a)
forall a. ReadS [LayoutHints a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (LayoutHints a)
readsPrec :: Int -> ReadS (LayoutHints a)
$creadList :: forall a. ReadS [LayoutHints a]
readList :: ReadS [LayoutHints a]
$creadPrec :: forall a. ReadPrec (LayoutHints a)
readPrec :: ReadPrec (LayoutHints a)
$creadListPrec :: forall a. ReadPrec [LayoutHints a]
readListPrec :: ReadPrec [LayoutHints a]
Read, Int -> LayoutHints a -> ShowS
[LayoutHints a] -> ShowS
LayoutHints a -> String
(Int -> LayoutHints a -> ShowS)
-> (LayoutHints a -> String)
-> ([LayoutHints a] -> ShowS)
-> Show (LayoutHints a)
forall a. Int -> LayoutHints a -> ShowS
forall a. [LayoutHints a] -> ShowS
forall a. LayoutHints a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> LayoutHints a -> ShowS
showsPrec :: Int -> LayoutHints a -> ShowS
$cshow :: forall a. LayoutHints a -> String
show :: LayoutHints a -> String
$cshowList :: forall a. [LayoutHints a] -> ShowS
showList :: [LayoutHints a] -> ShowS
Show)

instance LayoutModifier LayoutHints Window where
    modifierDescription :: LayoutHints Atom -> String
modifierDescription LayoutHints Atom
_ = String
"Hinted"
    redoLayout :: LayoutHints Atom
-> Rectangle
-> Maybe (Stack Atom)
-> [(Atom, Rectangle)]
-> X ([(Atom, Rectangle)], Maybe (LayoutHints Atom))
redoLayout LayoutHints Atom
_ Rectangle
_ Maybe (Stack Atom)
Nothing  [(Atom, Rectangle)]
xs = ([(Atom, Rectangle)], Maybe (LayoutHints Atom))
-> X ([(Atom, Rectangle)], Maybe (LayoutHints Atom))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Atom, Rectangle)]
xs, Maybe (LayoutHints Atom)
forall a. Maybe a
Nothing)
    redoLayout (LayoutHints (Double, Double)
al) Rectangle
_ (Just Stack Atom
s) [(Atom, Rectangle)]
xs
        = do [(Atom, Rectangle)]
xs' <- ((Atom, Rectangle) -> X (Atom, Rectangle))
-> [(Atom, Rectangle)] -> X [(Atom, Rectangle)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\x :: (Atom, Rectangle)
x@(Atom
_, Rectangle
r) -> (Rectangle -> Rectangle) -> (Atom, Rectangle) -> (Atom, Rectangle)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Double, Double) -> Rectangle -> Rectangle -> Rectangle
forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (Double, Double)
al Rectangle
r) ((Atom, Rectangle) -> (Atom, Rectangle))
-> X (Atom, Rectangle) -> X (Atom, Rectangle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom, Rectangle) -> X (Atom, Rectangle)
applyHint (Atom, Rectangle)
x) [(Atom, Rectangle)]
xs
             ([(Atom, Rectangle)], Maybe (LayoutHints Atom))
-> X ([(Atom, Rectangle)], Maybe (LayoutHints Atom))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Atom, Rectangle)]
xs', Maybe (LayoutHints Atom)
forall a. Maybe a
Nothing)
     where
        applyHint :: (Atom, Rectangle) -> X (Atom, Rectangle)
applyHint (Atom
w,r :: Rectangle
r@(Rectangle Position
a Position
b Dimension
c Dimension
d)) = do
            (Dimension, Dimension) -> (Dimension, Dimension)
adj <- Atom -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust Atom
w
            let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
            (Atom, Rectangle) -> X (Atom, Rectangle)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Atom
w, if Stack Atom -> Atom -> Bool
forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Atom
s Atom
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
r)

-- | @placeRectangle (rx, ry) r0 r@ will return a new rectangle with the same dimensions
-- as @r@, but positioned inside of @r0@ as specified by the (rx, ry) parameters (see
-- 'layoutHintsWithPlacement').
placeRectangle :: RealFrac r => (r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle :: forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (r
rx, r
ry) (Rectangle Position
x0 Position
y0 Dimension
w Dimension
h) (Rectangle Position
_ Position
_ Dimension
dx Dimension
dy)
    = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position -> Dimension -> Dimension -> r -> Position
forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
x0 Dimension
dx Dimension
w r
rx) (Position -> Dimension -> Dimension -> r -> Position
forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
y0 Dimension
dy Dimension
h r
ry) Dimension
dx Dimension
dy
    where align :: RealFrac r => Position -> Dimension -> Dimension -> r -> Position
          align :: forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
z0 Dimension
dz Dimension
d r
r = Position
z0 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ r -> Position
forall b. Integral b => r -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Dimension -> r
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension
d Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
dz) r -> r -> r
forall a. Num a => a -> a -> a
* r
r)

fitting :: [Rectangle] -> Int
fitting :: [Rectangle] -> Int
fitting [Rectangle]
rects = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ do
    Rectangle
r <- [Rectangle]
rects
    Int -> [Int]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Int]) -> Int -> [Int]
forall a b. (a -> b) -> a -> b
$ [Rectangle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Rectangle] -> Int) -> [Rectangle] -> Int
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (Rectangle -> Rectangle -> Bool
touching Rectangle
r) [Rectangle]
rects

applyOrder :: Rectangle -> [((Window, Rectangle),t)] -> [[((Window, Rectangle),t)]]
applyOrder :: forall t.
Rectangle -> [((Atom, Rectangle), t)] -> [[((Atom, Rectangle), t)]]
applyOrder Rectangle
root [((Atom, Rectangle), t)]
wrs = do
    -- perhaps it would just be better to take all permutations, or apply the
    -- resizing multiple times
    [Position] -> Position
f <- [[Position] -> Position
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum, [Position] -> Position
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum, [Position] -> Position
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum, [Position] -> Position
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Position] -> Position)
-> ([Position] -> [Position]) -> [Position] -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Position) -> [Position] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map Position -> Position
sq]
    [((Atom, Rectangle), t)] -> [[((Atom, Rectangle), t)]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([((Atom, Rectangle), t)] -> [[((Atom, Rectangle), t)]])
-> [((Atom, Rectangle), t)] -> [[((Atom, Rectangle), t)]]
forall a b. (a -> b) -> a -> b
$ (((Atom, Rectangle), t) -> ((Atom, Rectangle), t) -> Ordering)
-> [((Atom, Rectangle), t)] -> [((Atom, Rectangle), t)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Position -> Position -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Position -> Position -> Ordering)
-> (((Atom, Rectangle), t) -> Position)
-> ((Atom, Rectangle), t)
-> ((Atom, Rectangle), t)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Position] -> Position
f ([Position] -> Position)
-> (((Atom, Rectangle), t) -> [Position])
-> ((Atom, Rectangle), t)
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Atom, Rectangle), t) -> [Position]
forall {a} {b}. ((a, Rectangle), b) -> [Position]
distance)) [((Atom, Rectangle), t)]
wrs
    where distFC :: (Position, Position) -> Position
distFC = (Position -> Position -> Position)
-> (Position, Position) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Position -> Position -> Position
forall a. Num a => a -> a -> a
(+) (Position -> Position -> Position)
-> (Position -> Position) -> Position -> Position -> Position
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Position -> Position
sq) ((Position, Position) -> Position)
-> ((Position, Position) -> (Position, Position))
-> (Position, Position)
-> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Position -> Position)
-> (Position, Position)
-> (Position, Position)
-> (Position, Position)
forall {t} {t} {b}. (t -> t -> b) -> (t, t) -> (t, t) -> (b, b)
pairWise (-) (Rectangle -> (Position, Position)
center Rectangle
root)
          distance :: ((a, Rectangle), b) -> [Position]
distance = ((Position, Position) -> Position)
-> [(Position, Position)] -> [Position]
forall a b. (a -> b) -> [a] -> [b]
map (Position, Position) -> Position
distFC ([(Position, Position)] -> [Position])
-> (((a, Rectangle), b) -> [(Position, Position)])
-> ((a, Rectangle), b)
-> [Position]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> [(Position, Position)]
corners (Rectangle -> [(Position, Position)])
-> (((a, Rectangle), b) -> Rectangle)
-> ((a, Rectangle), b)
-> [(Position, Position)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Rectangle) -> Rectangle
forall a b. (a, b) -> b
snd ((a, Rectangle) -> Rectangle)
-> (((a, Rectangle), b) -> (a, Rectangle))
-> ((a, Rectangle), b)
-> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Rectangle), b) -> (a, Rectangle)
forall a b. (a, b) -> a
fst
          pairWise :: (t -> t -> b) -> (t, t) -> (t, t) -> (b, b)
pairWise t -> t -> b
f (t
a,t
b) (t
c,t
d) = (t -> t -> b
f t
a t
c, t -> t -> b
f t
b t
d)
          sq :: Position -> Position
sq = (Position -> Position -> Position) -> Position -> Position
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Position -> Position -> Position
forall a. Num a => a -> a -> a
(*)

data LayoutHintsToCenter a = LayoutHintsToCenter deriving (ReadPrec [LayoutHintsToCenter a]
ReadPrec (LayoutHintsToCenter a)
Int -> ReadS (LayoutHintsToCenter a)
ReadS [LayoutHintsToCenter a]
(Int -> ReadS (LayoutHintsToCenter a))
-> ReadS [LayoutHintsToCenter a]
-> ReadPrec (LayoutHintsToCenter a)
-> ReadPrec [LayoutHintsToCenter a]
-> Read (LayoutHintsToCenter a)
forall a. ReadPrec [LayoutHintsToCenter a]
forall a. ReadPrec (LayoutHintsToCenter a)
forall a. Int -> ReadS (LayoutHintsToCenter a)
forall a. ReadS [LayoutHintsToCenter a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (LayoutHintsToCenter a)
readsPrec :: Int -> ReadS (LayoutHintsToCenter a)
$creadList :: forall a. ReadS [LayoutHintsToCenter a]
readList :: ReadS [LayoutHintsToCenter a]
$creadPrec :: forall a. ReadPrec (LayoutHintsToCenter a)
readPrec :: ReadPrec (LayoutHintsToCenter a)
$creadListPrec :: forall a. ReadPrec [LayoutHintsToCenter a]
readListPrec :: ReadPrec [LayoutHintsToCenter a]
Read, Int -> LayoutHintsToCenter a -> ShowS
[LayoutHintsToCenter a] -> ShowS
LayoutHintsToCenter a -> String
(Int -> LayoutHintsToCenter a -> ShowS)
-> (LayoutHintsToCenter a -> String)
-> ([LayoutHintsToCenter a] -> ShowS)
-> Show (LayoutHintsToCenter a)
forall a. Int -> LayoutHintsToCenter a -> ShowS
forall a. [LayoutHintsToCenter a] -> ShowS
forall a. LayoutHintsToCenter a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> LayoutHintsToCenter a -> ShowS
showsPrec :: Int -> LayoutHintsToCenter a -> ShowS
$cshow :: forall a. LayoutHintsToCenter a -> String
show :: LayoutHintsToCenter a -> String
$cshowList :: forall a. [LayoutHintsToCenter a] -> ShowS
showList :: [LayoutHintsToCenter a] -> ShowS
Show)

instance LayoutModifier LayoutHintsToCenter Window where
    modifyLayout :: forall (l :: * -> *).
LayoutClass l Atom =>
LayoutHintsToCenter Atom
-> Workspace String (l Atom) Atom
-> Rectangle
-> X ([(Atom, Rectangle)], Maybe (l Atom))
modifyLayout LayoutHintsToCenter Atom
_ ws :: Workspace String (l Atom) Atom
ws@(W.Workspace String
_ l Atom
_ Maybe (Stack Atom)
Nothing) Rectangle
r = Workspace String (l Atom) Atom
-> Rectangle -> X ([(Atom, Rectangle)], Maybe (l Atom))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Atom) Atom
ws Rectangle
r
    modifyLayout LayoutHintsToCenter Atom
_ ws :: Workspace String (l Atom) Atom
ws@(W.Workspace String
_ l Atom
_ (Just Stack Atom
st)) Rectangle
r = do
        ([(Atom, Rectangle)]
arrs,Maybe (l Atom)
ol) <- Workspace String (l Atom) Atom
-> Rectangle -> X ([(Atom, Rectangle)], Maybe (l Atom))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Atom) Atom
ws Rectangle
r
        (, Maybe (l Atom)
ol) ([(Atom, Rectangle)] -> ([(Atom, Rectangle)], Maybe (l Atom)))
-> ([((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]
    -> [(Atom, Rectangle)])
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> ([(Atom, Rectangle)], Maybe (l Atom))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Atom] -> [(Atom, Rectangle)] -> [(Atom, Rectangle)]
changeOrder (Stack Atom -> Atom
forall a. Stack a -> a
W.focus Stack Atom
st Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
/= Stack Atom -> Atom
forall a. Stack a -> a
W.focus Stack Atom
st) (((Atom, Rectangle) -> Atom) -> [(Atom, Rectangle)] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map (Atom, Rectangle) -> Atom
forall a b. (a, b) -> a
fst [(Atom, Rectangle)]
arrs))
               ([(Atom, Rectangle)] -> [(Atom, Rectangle)])
-> ([((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]
    -> [(Atom, Rectangle)])
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Atom, Rectangle)] -> [(Atom, Rectangle)] -> Ordering)
-> [[(Atom, Rectangle)]] -> [(Atom, Rectangle)]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ([(Atom, Rectangle)] -> Int)
-> [(Atom, Rectangle)]
-> [(Atom, Rectangle)]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Rectangle] -> Int
fitting ([Rectangle] -> Int)
-> ([(Atom, Rectangle)] -> [Rectangle])
-> [(Atom, Rectangle)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Atom, Rectangle) -> Rectangle)
-> [(Atom, Rectangle)] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map (Atom, Rectangle) -> Rectangle
forall a b. (a, b) -> b
snd))
               ([[(Atom, Rectangle)]] -> [(Atom, Rectangle)])
-> ([((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]
    -> [[(Atom, Rectangle)]])
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([((Atom, Rectangle),
   (Dimension, Dimension) -> (Dimension, Dimension))]
 -> [(Atom, Rectangle)])
-> [[((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]]
-> [[(Atom, Rectangle)]]
forall a b. (a -> b) -> [a] -> [b]
map (Stack Atom
-> Rectangle
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
applyHints Stack Atom
st Rectangle
r) ([[((Atom, Rectangle),
    (Dimension, Dimension) -> (Dimension, Dimension))]]
 -> [[(Atom, Rectangle)]])
-> ([((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]
    -> [[((Atom, Rectangle),
          (Dimension, Dimension) -> (Dimension, Dimension))]])
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [[(Atom, Rectangle)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [[((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))]]
forall t.
Rectangle -> [((Atom, Rectangle), t)] -> [[((Atom, Rectangle), t)]]
applyOrder Rectangle
r
             ([((Atom, Rectangle),
   (Dimension, Dimension) -> (Dimension, Dimension))]
 -> ([(Atom, Rectangle)], Maybe (l Atom)))
-> X [((Atom, Rectangle),
       (Dimension, Dimension) -> (Dimension, Dimension))]
-> X ([(Atom, Rectangle)], Maybe (l Atom))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Atom, Rectangle)
 -> X ((Atom, Rectangle),
       (Dimension, Dimension) -> (Dimension, Dimension)))
-> [(Atom, Rectangle)]
-> X [((Atom, Rectangle),
       (Dimension, Dimension) -> (Dimension, Dimension))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(Atom, Rectangle)
x -> ((Atom, Rectangle)
x,) (((Dimension, Dimension) -> (Dimension, Dimension))
 -> ((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension)))
-> X ((Dimension, Dimension) -> (Dimension, Dimension))
-> X ((Atom, Rectangle),
      (Dimension, Dimension) -> (Dimension, Dimension))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust ((Atom, Rectangle) -> Atom
forall a b. (a, b) -> a
fst (Atom, Rectangle)
x)) [(Atom, Rectangle)]
arrs

changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder :: [Atom] -> [(Atom, Rectangle)] -> [(Atom, Rectangle)]
changeOrder [Atom]
w [(Atom, Rectangle)]
wr = [Atom] -> [Rectangle] -> [(Atom, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Atom]
w' ([Rectangle] -> [(Atom, Rectangle)])
-> [Rectangle] -> [(Atom, Rectangle)]
forall a b. (a -> b) -> a -> b
$ (Atom -> Rectangle) -> [Atom] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Rectangle -> Rectangle
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Rectangle -> Rectangle)
-> (Atom -> Maybe Rectangle) -> Atom -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Atom -> [(Atom, Rectangle)] -> Maybe Rectangle)
-> [(Atom, Rectangle)] -> Atom -> Maybe Rectangle
forall a b c. (a -> b -> c) -> b -> a -> c
flip Atom -> [(Atom, Rectangle)] -> Maybe Rectangle
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Atom, Rectangle)]
wr) [Atom]
w'
    where w' :: [Atom]
w' = (Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (Atom -> [Atom] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Atom, Rectangle) -> Atom) -> [(Atom, Rectangle)] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map (Atom, Rectangle) -> Atom
forall a b. (a, b) -> a
fst [(Atom, Rectangle)]
wr) [Atom]
w

-- apply hints to first, grow adjacent windows
applyHints :: W.Stack Window -> Rectangle -> [((Window, Rectangle),D -> D)] -> [(Window, Rectangle)]
applyHints :: Stack Atom
-> Rectangle
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
applyHints Stack Atom
_ Rectangle
_ [] = []
applyHints Stack Atom
s Rectangle
root (((Atom
w,lrect :: Rectangle
lrect@(Rectangle Position
a Position
b Dimension
c Dimension
d)),(Dimension, Dimension) -> (Dimension, Dimension)
adj):[((Atom, Rectangle),
  (Dimension, Dimension) -> (Dimension, Dimension))]
xs) =
        let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
            redr :: Rectangle
redr = (Double, Double) -> Rectangle -> Rectangle -> Rectangle
forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (Rectangle -> Rectangle -> (Double, Double)
forall r. RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement Rectangle
root Rectangle
lrect :: (Double,Double)) Rectangle
lrect
                    (Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall a b. (a -> b) -> a -> b
$ if Stack Atom -> Atom -> Bool
forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Atom
s Atom
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
lrect

            ds :: (Position, Position)
ds = (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c Position -> Position -> Position
forall a. Num a => a -> a -> a
- Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c',Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
d Position -> Position -> Position
forall a. Num a => a -> a -> a
- Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
d')
            growOther' :: Rectangle -> Rectangle
growOther' = (Position, Position)
-> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther (Position, Position)
ds Rectangle
lrect (Rectangle -> Rectangle -> Set Direction2D
freeDirs Rectangle
root Rectangle
lrect)
            mapSnd :: (b -> c) -> [((d, b), d)] -> [((d, c), d)]
mapSnd b -> c
f = (((d, b), d) -> ((d, c), d)) -> [((d, b), d)] -> [((d, c), d)]
forall a b. (a -> b) -> [a] -> [b]
map (((d, b) -> (d, c)) -> ((d, b), d) -> ((d, c), d)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((d, b) -> (d, c)) -> ((d, b), d) -> ((d, c), d))
-> ((d, b) -> (d, c)) -> ((d, b), d) -> ((d, c), d)
forall a b. (a -> b) -> a -> b
$ (b -> c) -> (d, b) -> (d, c)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> c
f)
            next :: [(Atom, Rectangle)]
next = Stack Atom
-> Rectangle
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
applyHints Stack Atom
s Rectangle
root ([((Atom, Rectangle),
   (Dimension, Dimension) -> (Dimension, Dimension))]
 -> [(Atom, Rectangle)])
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Atom, Rectangle)]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Rectangle)
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
-> [((Atom, Rectangle),
     (Dimension, Dimension) -> (Dimension, Dimension))]
forall {b} {c} {d} {d}. (b -> c) -> [((d, b), d)] -> [((d, c), d)]
mapSnd Rectangle -> Rectangle
growOther' [((Atom, Rectangle),
  (Dimension, Dimension) -> (Dimension, Dimension))]
xs
        in (Atom
w,Rectangle
redr)(Atom, Rectangle) -> [(Atom, Rectangle)] -> [(Atom, Rectangle)]
forall a. a -> [a] -> [a]
:[(Atom, Rectangle)]
next

growOther :: (Position, Position) -> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther :: (Position, Position)
-> Rectangle -> Set Direction2D -> Rectangle -> Rectangle
growOther (Position, Position)
ds Rectangle
lrect Set Direction2D
fds Rectangle
r
    | [Direction2D]
dirs <- Direction2D -> Direction2D
flipDir (Direction2D -> Direction2D) -> [Direction2D] -> [Direction2D]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Direction2D -> [Direction2D]
forall a. Set a -> [a]
Set.toList (Set Direction2D -> Set Direction2D -> Set Direction2D
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Direction2D
adj Set Direction2D
fds)
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Direction2D, Direction2D) -> Bool)
-> [(Direction2D, Direction2D)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Direction2D -> Direction2D -> Bool)
-> (Direction2D, Direction2D) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Direction2D -> Direction2D -> Bool
opposite) ([(Direction2D, Direction2D)] -> Bool)
-> [(Direction2D, Direction2D)] -> Bool
forall a b. (a -> b) -> a -> b
$ [Direction2D] -> [(Direction2D, Direction2D)]
forall {b}. [b] -> [(b, b)]
cross [Direction2D]
dirs =
        (Direction2D -> Rectangle -> Rectangle)
-> Rectangle -> [Direction2D] -> Rectangle
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Direction2D -> (Position, Position) -> Rectangle -> Rectangle
`grow` (Position, Position)
ds) Rectangle
r [Direction2D]
dirs
    | Bool
otherwise = Rectangle
r
    where
        adj :: Set Direction2D
adj = Rectangle -> Rectangle -> Set Direction2D
adjacent Rectangle
lrect  Rectangle
r
        cross :: [b] -> [(b, b)]
cross [b]
xs = [ (b
a,b
b) | b
a <- [b]
xs, b
b <- [b]
xs ]

        flipDir :: Direction2D -> Direction2D
        flipDir :: Direction2D -> Direction2D
flipDir Direction2D
d = case Direction2D
d of { Direction2D
L -> Direction2D
R; Direction2D
U -> Direction2D
D; Direction2D
R -> Direction2D
L; Direction2D
D -> Direction2D
U }

        opposite :: Direction2D -> Direction2D -> Bool
        opposite :: Direction2D -> Direction2D -> Bool
opposite Direction2D
x Direction2D
y = Direction2D -> Direction2D
flipDir Direction2D
x Direction2D -> Direction2D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction2D
y

-- | Leave the opposite edges where they were
grow :: Direction2D -> (Position,Position) -> Rectangle -> Rectangle
grow :: Direction2D -> (Position, Position) -> Rectangle -> Rectangle
grow Direction2D
L (Position
px,Position
_ ) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
xPosition -> Position -> Position
forall a. Num a => a -> a -> a
-Position
px) Position
y (Dimension
wDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
px) Dimension
h
grow Direction2D
U (Position
_ ,Position
py) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x (Position
yPosition -> Position -> Position
forall a. Num a => a -> a -> a
-Position
py) Dimension
w (Dimension
hDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
py)
grow Direction2D
R (Position
px,Position
_ ) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y (Dimension
wDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
px) Dimension
h
grow Direction2D
D (Position
_ ,Position
py) (Rectangle Position
x Position
y Dimension
w Dimension
h) = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y Dimension
w (Dimension
hDimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
py)

comparingEdges :: ([Position] -> [Position] -> Bool) -> Rectangle -> Rectangle -> Set Direction2D
comparingEdges :: ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges [Position] -> [Position] -> Bool
surrounds Rectangle
r1 Rectangle
r2 = [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
Set.fromList ([Direction2D] -> Set Direction2D)
-> [Direction2D] -> Set Direction2D
forall a b. (a -> b) -> a -> b
$ ((Direction2D, Bool) -> Direction2D)
-> [(Direction2D, Bool)] -> [Direction2D]
forall a b. (a -> b) -> [a] -> [b]
map (Direction2D, Bool) -> Direction2D
forall a b. (a, b) -> a
fst ([(Direction2D, Bool)] -> [Direction2D])
-> [(Direction2D, Bool)] -> [Direction2D]
forall a b. (a -> b) -> a -> b
$ ((Direction2D, Bool) -> Bool)
-> [(Direction2D, Bool)] -> [(Direction2D, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Direction2D, Bool) -> Bool
forall a b. (a, b) -> b
snd [ (Direction2D
dir,) (Bool -> (Direction2D, Bool)) -> Bool -> (Direction2D, Bool)
forall a b. (a -> b) -> a -> b
$
            ([Bool] -> Bool) -> [[Bool]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[Direction2D
dir Direction2D -> [Direction2D] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Direction2D
R,Direction2D
L], [Position] -> Bool
allEq [Position
a,Position
c,Position
w,Position
y], [Position
b,Position
d] [Position] -> [Position] -> Bool
`surrounds` [Position
x,Position
z]]
                    ,[Direction2D
dir Direction2D -> [Direction2D] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Direction2D
U,Direction2D
D], [Position] -> Bool
allEq [Position
b,Position
d,Position
x,Position
z], [Position
a,Position
c] [Position] -> [Position] -> Bool
`surrounds` [Position
w,Position
y]]]
    | ((Position
a,Position
b),(Position
c,Position
d)) <- [(Position, Position)]
-> [((Position, Position), (Position, Position))]
forall {b}. [b] -> [(b, b)]
edge ([(Position, Position)]
 -> [((Position, Position), (Position, Position))])
-> [(Position, Position)]
-> [((Position, Position), (Position, Position))]
forall a b. (a -> b) -> a -> b
$ Rectangle -> [(Position, Position)]
corners Rectangle
r1
    | ((Position
w,Position
x),(Position
y,Position
z)) <- [(Position, Position)]
-> [((Position, Position), (Position, Position))]
forall {b}. [b] -> [(b, b)]
edge ([(Position, Position)]
 -> [((Position, Position), (Position, Position))])
-> [(Position, Position)]
-> [((Position, Position), (Position, Position))]
forall a b. (a -> b) -> a -> b
$ Int -> [(Position, Position)] -> [(Position, Position)]
forall {a}. Int -> [a] -> [a]
delay Int
2 ([(Position, Position)] -> [(Position, Position)])
-> [(Position, Position)] -> [(Position, Position)]
forall a b. (a -> b) -> a -> b
$ Rectangle -> [(Position, Position)]
corners Rectangle
r2
    | Direction2D
dir <- [Direction2D
U,Direction2D
R,Direction2D
D,Direction2D
L]]
        where edge :: [b] -> [(b, b)]
edge (b
x:[b]
xs) = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (b
xb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
xs) ([b]
xs [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b
x])
              edge [] = []
              delay :: Int -> [a] -> [a]
delay Int
n [a]
xs = Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
drop Int
n [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall {a}. Int -> [a] -> [a]
take Int
n [a]
xs
              allEq :: [Position] -> Bool
allEq = ((Position, Position) -> Bool) -> [(Position, Position)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Position -> Position -> Bool) -> (Position, Position) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
(==)) ([(Position, Position)] -> Bool)
-> ([Position] -> [(Position, Position)]) -> [Position] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Position] -> [(Position, Position)]
forall {b}. [b] -> [(b, b)]
edge

-- | in what direction is the second window from the first that can expand if the
-- first is shrunk, assuming that the root window is fully covered:
--  one direction for a common edge
--  two directions for a common corner
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent = ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges ((Position -> Bool) -> [Position] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Position -> Bool) -> [Position] -> Bool)
-> ([Position] -> Position -> Bool)
-> [Position]
-> [Position]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Position] -> Position -> Bool
forall a. Ord a => [a] -> a -> Bool
onClosedInterval)

-- | True whenever two edges touch. not (Set.null $ adjacent x y) ==> touching x y
touching :: Rectangle -> Rectangle -> Bool
touching :: Rectangle -> Rectangle -> Bool
touching Rectangle
a Rectangle
b = Bool -> Bool
not (Bool -> Bool)
-> (Set Direction2D -> Bool) -> Set Direction2D -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Direction2D -> Bool
forall a. Set a -> Bool
Set.null (Set Direction2D -> Bool) -> Set Direction2D -> Bool
forall a b. (a -> b) -> a -> b
$ ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges [Position] -> [Position] -> Bool
forall {a}. Ord a => [a] -> [a] -> Bool
c Rectangle
a Rectangle
b
    where c :: [a] -> [a] -> Bool
c [a]
x [a]
y = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a] -> a -> Bool
forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
x) [a]
y Bool -> Bool -> Bool
|| (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([a] -> a -> Bool
forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
y) [a]
x

onClosedInterval :: Ord a => [a] -> a -> Bool
onClosedInterval :: forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
bds a
x = [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
bds a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
bds a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x

-- | starting top left going clockwise
corners :: Rectangle -> [(Position, Position)]
corners :: Rectangle -> [(Position, Position)]
corners (Rectangle Position
x Position
y Dimension
w Dimension
h) = [(Position
x,Position
y)
                              ,(Position
xPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
y)
                              ,(Position
xPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
yPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h)
                              ,(Position
x, Position
yPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h)]

center :: Rectangle -> (Position, Position)
center :: Rectangle -> (Position, Position)
center (Rectangle Position
x Position
y Dimension
w Dimension
h) = (Position -> Dimension -> Position
forall {a} {a}. (Integral a, Integral a) => a -> a -> a
avg Position
x Dimension
w, Position -> Dimension -> Position
forall {a} {a}. (Integral a, Integral a) => a -> a -> a
avg Position
y Dimension
h)
    where avg :: a -> a -> a
avg a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2

centerPlacement :: RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement :: forall r. RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement = (Position -> r) -> Rectangle -> Rectangle -> (r, r)
forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' Position -> r
forall {a} {a}. (Eq a, Fractional a, Num a) => a -> a
clamp
    where clamp :: a -> a
clamp a
n = case a -> a
forall a. Num a => a -> a
signum a
n of
                            a
0 -> a
0.5
                            a
1 -> a
1
                            a
_ -> a
0

freeDirs :: Rectangle -> Rectangle -> Set Direction2D
freeDirs :: Rectangle -> Rectangle -> Set Direction2D
freeDirs Rectangle
root = [Direction2D] -> Set Direction2D
forall a. Ord a => [a] -> Set a
Set.fromList ([Direction2D] -> Set Direction2D)
-> (Rectangle -> [Direction2D]) -> Rectangle -> Set Direction2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Direction2D] -> [Direction2D] -> [Direction2D])
-> ([Direction2D], [Direction2D]) -> [Direction2D]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Direction2D] -> [Direction2D] -> [Direction2D]
forall a. [a] -> [a] -> [a]
(++) (([Direction2D], [Direction2D]) -> [Direction2D])
-> (Rectangle -> ([Direction2D], [Direction2D]))
-> Rectangle
-> [Direction2D]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> [Direction2D]
forall {a}. (Eq a, Num a) => a -> [Direction2D]
lr (Position -> [Direction2D])
-> (Position -> [Direction2D])
-> (Position, Position)
-> ([Direction2D], [Direction2D])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Position -> [Direction2D]
forall {a}. (Eq a, Num a) => a -> [Direction2D]
ud)
              ((Position, Position) -> ([Direction2D], [Direction2D]))
-> (Rectangle -> (Position, Position))
-> Rectangle
-> ([Direction2D], [Direction2D])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Position)
-> Rectangle -> Rectangle -> (Position, Position)
forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' Position -> Position
forall a. Num a => a -> a
signum Rectangle
root
    where
        lr :: a -> [Direction2D]
lr a
1 = [Direction2D
L]
        lr (-1) = [Direction2D
R]
        lr a
_ = [Direction2D
L,Direction2D
R]
        ud :: a -> [Direction2D]
ud a
1 = [Direction2D
U]
        ud (-1) = [Direction2D
D]
        ud a
_ = [Direction2D
U,Direction2D
D]

centerPlacement' :: (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' :: forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' Position -> r
cf Rectangle
root Rectangle
assigned
    = (Position -> r
cf (Position -> r) -> Position -> r
forall a b. (a -> b) -> a -> b
$ Position
cx Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
cwx, Position -> r
cf (Position -> r) -> Position -> r
forall a b. (a -> b) -> a -> b
$ Position
cy Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
cwy)
    where (Position
cx,Position
cy) = Rectangle -> (Position, Position)
center Rectangle
root
          (Position
cwx,Position
cwy) = Rectangle -> (Position, Position)
center Rectangle
assigned

-- | Event hook that refreshes the layout whenever a window changes its hints.
hintsEventHook :: Event -> X All
hintsEventHook :: Event -> X All
hintsEventHook PropertyEvent{ ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_atom :: Event -> Atom
ev_atom = Atom
a, ev_window :: Event -> Atom
ev_window = Atom
w }
    | Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
propertyNotify Bool -> Bool -> Bool
&& Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_NORMAL_HINTS = do
        X Bool -> X () -> X ()
whenX (Atom -> X Bool
isClient Atom
w X Bool -> X Bool -> X Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> Atom -> X Bool
hintsMismatch Atom
w) X ()
refresh
        All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
hintsEventHook Event
_ = All -> X All
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | True if the window's current size does not satisfy its size hints.
hintsMismatch :: Window -> X Bool
hintsMismatch :: Atom -> X Bool
hintsMismatch Atom
w = Atom -> X (Maybe WindowAttributes)
safeGetWindowAttributes Atom
w X (Maybe WindowAttributes)
-> (Maybe WindowAttributes -> X Bool) -> X Bool
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe WindowAttributes
Nothing -> Bool -> X Bool
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just WindowAttributes
wa -> do
        SizeHints
sh <- (Display -> X SizeHints) -> X SizeHints
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X SizeHints) -> X SizeHints)
-> (Display -> X SizeHints) -> X SizeHints
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO SizeHints -> X SizeHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Atom -> IO SizeHints
getWMNormalHints Display
d Atom
w)
        let dim :: (Dimension, Dimension)
dim = (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa, CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa)
        Bool -> X Bool
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> X Bool) -> Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ (Dimension, Dimension)
dim (Dimension, Dimension) -> (Dimension, Dimension) -> Bool
forall a. Eq a => a -> a -> Bool
/= Dimension
-> SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension)
forall a.
Integral a =>
Dimension -> SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHints Dimension
0 SizeHints
sh (Dimension, Dimension)
dim