{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ParallelListComp, PatternGuards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module XMonad.Layout.LayoutHints
(
layoutHints
, layoutHintsWithPlacement
, layoutHintsToCenter
, LayoutHints
, LayoutHintsToCenter
, hintsEventHook
, 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
layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a
layoutHints :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHints l a
layoutHints = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double
0, Double
0))
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 = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. (Double, Double) -> LayoutHints a
LayoutHints (Double, Double)
rs)
layoutHintsToCenter :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter :: forall (l :: * -> *) a.
LayoutClass l a =>
l a -> ModifiedLayout LayoutHintsToCenter l a
layoutHintsToCenter = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout forall a. LayoutHintsToCenter a
LayoutHintsToCenter
newtype LayoutHints a = LayoutHints (Double, Double)
deriving (ReadPrec [LayoutHints a]
ReadPrec (LayoutHints a)
ReadS [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
readListPrec :: ReadPrec [LayoutHints a]
$creadListPrec :: forall a. ReadPrec [LayoutHints a]
readPrec :: ReadPrec (LayoutHints a)
$creadPrec :: forall a. ReadPrec (LayoutHints a)
readList :: ReadS [LayoutHints a]
$creadList :: forall a. ReadS [LayoutHints a]
readsPrec :: Int -> ReadS (LayoutHints a)
$creadsPrec :: forall a. Int -> ReadS (LayoutHints a)
Read, Int -> LayoutHints a -> ShowS
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
showList :: [LayoutHints a] -> ShowS
$cshowList :: forall a. [LayoutHints a] -> ShowS
show :: LayoutHints a -> String
$cshow :: forall a. LayoutHints a -> String
showsPrec :: Int -> LayoutHints a -> ShowS
$cshowsPrec :: forall a. Int -> LayoutHints a -> ShowS
Show)
instance LayoutModifier LayoutHints Window where
modifierDescription :: LayoutHints Window -> String
modifierDescription LayoutHints Window
_ = String
"Hinted"
redoLayout :: LayoutHints Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)], Maybe (LayoutHints Window))
redoLayout LayoutHints Window
_ Rectangle
_ Maybe (Stack Window)
Nothing [(Window, Rectangle)]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
xs, forall a. Maybe a
Nothing)
redoLayout (LayoutHints (Double, Double)
al) Rectangle
_ (Just Stack Window
s) [(Window, Rectangle)]
xs
= do [(Window, Rectangle)]
xs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\x :: (Window, Rectangle)
x@(Window
_, Rectangle
r) -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (Double, Double)
al Rectangle
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Window, Rectangle) -> X (Window, Rectangle)
applyHint (Window, Rectangle)
x) [(Window, Rectangle)]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
xs', forall a. Maybe a
Nothing)
where
applyHint :: (Window, Rectangle) -> X (Window, Rectangle)
applyHint (Window
w,r :: Rectangle
r@(Rectangle Position
a Position
b Dimension
c Dimension
d)) = do
(Dimension, Dimension) -> (Dimension, Dimension)
adj <- Window -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust Window
w
let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
forall (m :: * -> *) a. Monad m => a -> m a
return (Window
w, if forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s Window
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
r)
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 (forall r.
RealFrac r =>
Position -> Dimension -> Dimension -> r -> Position
align Position
x0 Dimension
dx Dimension
w r
rx) (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 forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
truncate (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension
d forall a. Num a => a -> a -> a
- Dimension
dz) forall a. Num a => a -> a -> a
* r
r)
fitting :: [Rectangle] -> Int
fitting :: [Rectangle] -> Int
fitting [Rectangle]
rects = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ do
Rectangle
r <- [Rectangle]
rects
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ 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
-> [((Window, Rectangle), t)] -> [[((Window, Rectangle), t)]]
applyOrder Rectangle
root [((Window, Rectangle), t)]
wrs = do
[Position] -> Position
f <- [forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Position -> Position
sq]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Position] -> Position
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. ((a, Rectangle), b) -> [Position]
distance)) [((Window, Rectangle), t)]
wrs
where distFC :: (Position, Position) -> Position
distFC = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Position -> Position
sq) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b. (a -> b) -> [a] -> [b]
map (Position, Position) -> Position
distFC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> [(Position, Position)]
corners forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a. Num a => a -> a -> a
(*)
data LayoutHintsToCenter a = LayoutHintsToCenter deriving (ReadPrec [LayoutHintsToCenter a]
ReadPrec (LayoutHintsToCenter a)
ReadS [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
readListPrec :: ReadPrec [LayoutHintsToCenter a]
$creadListPrec :: forall a. ReadPrec [LayoutHintsToCenter a]
readPrec :: ReadPrec (LayoutHintsToCenter a)
$creadPrec :: forall a. ReadPrec (LayoutHintsToCenter a)
readList :: ReadS [LayoutHintsToCenter a]
$creadList :: forall a. ReadS [LayoutHintsToCenter a]
readsPrec :: Int -> ReadS (LayoutHintsToCenter a)
$creadsPrec :: forall a. Int -> ReadS (LayoutHintsToCenter a)
Read, Int -> LayoutHintsToCenter a -> ShowS
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
showList :: [LayoutHintsToCenter a] -> ShowS
$cshowList :: forall a. [LayoutHintsToCenter a] -> ShowS
show :: LayoutHintsToCenter a -> String
$cshow :: forall a. LayoutHintsToCenter a -> String
showsPrec :: Int -> LayoutHintsToCenter a -> ShowS
$cshowsPrec :: forall a. Int -> LayoutHintsToCenter a -> ShowS
Show)
instance LayoutModifier LayoutHintsToCenter Window where
modifyLayout :: forall (l :: * -> *).
LayoutClass l Window =>
LayoutHintsToCenter Window
-> Workspace String (l Window) Window
-> Rectangle
-> X ([(Window, Rectangle)], Maybe (l Window))
modifyLayout LayoutHintsToCenter Window
_ ws :: Workspace String (l Window) Window
ws@(W.Workspace String
_ l Window
_ Maybe (Stack Window)
Nothing) Rectangle
r = forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
ws Rectangle
r
modifyLayout LayoutHintsToCenter Window
_ ws :: Workspace String (l Window) Window
ws@(W.Workspace String
_ l Window
_ (Just Stack Window
st)) Rectangle
r = do
([(Window, Rectangle)]
arrs,Maybe (l Window)
ol) <- forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
ws Rectangle
r
(, Maybe (l Window)
ol) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder (forall a. Stack a -> a
W.focus Stack Window
st forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= forall a. Stack a -> a
W.focus Stack Window
st) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
arrs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Rectangle] -> Int
fitting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Stack Window
-> Rectangle
-> [((Window, Rectangle),
(Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
st Rectangle
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t.
Rectangle
-> [((Window, Rectangle), t)] -> [[((Window, Rectangle), t)]]
applyOrder Rectangle
r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Window, Rectangle)
x -> ((Window, Rectangle)
x,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Window -> X ((Dimension, Dimension) -> (Dimension, Dimension))
mkAdjust (forall a b. (a, b) -> a
fst (Window, Rectangle)
x)) [(Window, Rectangle)]
arrs
changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder [Window]
w [(Window, Rectangle)]
wr = forall a b. [a] -> [b] -> [(a, b)]
zip [Window]
w' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Window, Rectangle)]
wr) [Window]
w'
where w' :: [Window]
w' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
wr) [Window]
w
applyHints :: W.Stack Window -> Rectangle -> [((Window, Rectangle),D -> D)] -> [(Window, Rectangle)]
applyHints :: Stack Window
-> Rectangle
-> [((Window, Rectangle),
(Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
_ Rectangle
_ [] = []
applyHints Stack Window
s Rectangle
root (((Window
w,lrect :: Rectangle
lrect@(Rectangle Position
a Position
b Dimension
c Dimension
d)),(Dimension, Dimension) -> (Dimension, Dimension)
adj):[((Window, Rectangle),
(Dimension, Dimension) -> (Dimension, Dimension))]
xs) =
let (Dimension
c',Dimension
d') = (Dimension, Dimension) -> (Dimension, Dimension)
adj (Dimension
c,Dimension
d)
redr :: Rectangle
redr = forall r.
RealFrac r =>
(r, r) -> Rectangle -> Rectangle -> Rectangle
placeRectangle (forall r. RealFrac r => Rectangle -> Rectangle -> (r, r)
centerPlacement Rectangle
root Rectangle
lrect :: (Double,Double)) Rectangle
lrect
forall a b. (a -> b) -> a -> b
$ if forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s Window
w then Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
a Position
b Dimension
c' Dimension
d' else Rectangle
lrect
ds :: (Position, Position)
ds = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
c',forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
d forall a. Num a => a -> a -> a
- 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> c
f)
next :: [(Window, Rectangle)]
next = Stack Window
-> Rectangle
-> [((Window, Rectangle),
(Dimension, Dimension) -> (Dimension, Dimension))]
-> [(Window, Rectangle)]
applyHints Stack Window
s Rectangle
root forall a b. (a -> b) -> a -> b
$ forall {b} {c} {d} {d}. (b -> c) -> [((d, b), d)] -> [((d, c), d)]
mapSnd Rectangle -> Rectangle
growOther' [((Window, Rectangle),
(Dimension, Dimension) -> (Dimension, Dimension))]
xs
in (Window
w,Rectangle
redr)forall a. a -> [a] -> [a]
:[(Window, 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Direction2D
adj Set Direction2D
fds)
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Direction2D -> Direction2D -> Bool
opposite) forall a b. (a -> b) -> a -> b
$ forall {b}. [b] -> [(b, b)]
cross [Direction2D]
dirs =
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 forall a. Eq a => a -> a -> Bool
== Direction2D
y
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
xforall a. Num a => a -> a -> a
-Position
px) Position
y (Dimension
wforall a. Num a => a -> a -> a
+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
yforall a. Num a => a -> a -> a
-Position
py) Dimension
w (Dimension
hforall a. Num a => a -> a -> a
+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
wforall a. Num a => a -> a -> a
+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
hforall a. Num a => a -> a -> a
+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 = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd [ (Direction2D
dir,) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[Direction2D
dir 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 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)) <- forall {b}. [b] -> [(b, b)]
edge forall a b. (a -> b) -> a -> b
$ Rectangle -> [(Position, Position)]
corners Rectangle
r1
| ((Position
w,Position
x),(Position
y,Position
z)) <- forall {b}. [b] -> [(b, b)]
edge forall a b. (a -> b) -> a -> b
$ forall {a}. Int -> [a] -> [a]
delay Int
2 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) = forall a b. [a] -> [b] -> [(a, b)]
zip (b
xforall a. a -> [a] -> [a]
:[b]
xs) ([b]
xs forall a. [a] -> [a] -> [a]
++ [b
x])
edge [] = []
delay :: Int -> [a] -> [a]
delay Int
n [a]
xs = forall {a}. Int -> [a] -> [a]
drop Int
n [a]
xs forall a. [a] -> [a] -> [a]
++ forall {a}. Int -> [a] -> [a]
take Int
n [a]
xs
allEq :: [Position] -> Bool
allEq = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. [b] -> [(b, b)]
edge
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent :: Rectangle -> Rectangle -> Set Direction2D
adjacent = ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> a -> Bool
onClosedInterval)
touching :: Rectangle -> Rectangle -> Bool
touching :: Rectangle -> Rectangle -> Bool
touching Rectangle
a Rectangle
b = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ ([Position] -> [Position] -> Bool)
-> Rectangle -> Rectangle -> Set Direction2D
comparingEdges forall {a}. Ord a => [a] -> [a] -> Bool
c Rectangle
a Rectangle
b
where c :: [a] -> [a] -> Bool
c [a]
x [a]
y = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => [a] -> a -> Bool
onClosedInterval [a]
x) [a]
y Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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 = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
bds forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
bds forall a. Ord a => a -> a -> Bool
>= a
x
corners :: Rectangle -> [(Position, Position)]
corners :: Rectangle -> [(Position, Position)]
corners (Rectangle Position
x Position
y Dimension
w Dimension
h) = [(Position
x,Position
y)
,(Position
xforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
y)
,(Position
xforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
w, Position
yforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Dimension
h)
,(Position
x, Position
yforall a. Num a => a -> a -> a
+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) = (forall {a} {a}. (Integral a, Integral a) => a -> a -> a
avg Position
x Dimension
w, 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 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b 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 = forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' forall {a} {a}. (Eq a, Fractional a, Num a) => a -> a
clamp
where clamp :: a -> a
clamp a
n = case 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 = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {a}. (Eq a, Num a) => a -> [Direction2D]
lr forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall {a}. (Eq a, Num a) => a -> [Direction2D]
ud)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. (Position -> r) -> Rectangle -> Rectangle -> (r, r)
centerPlacement' 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 forall a b. (a -> b) -> a -> b
$ Position
cx forall a. Num a => a -> a -> a
- Position
cwx, Position -> r
cf forall a b. (a -> b) -> a -> b
$ Position
cy 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
hintsEventHook :: Event -> X All
hintsEventHook :: Event -> X All
hintsEventHook PropertyEvent{ ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_atom :: Event -> Window
ev_atom = Window
a, ev_window :: Event -> Window
ev_window = Window
w }
| Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
propertyNotify Bool -> Bool -> Bool
&& Window
a forall a. Eq a => a -> a -> Bool
== Window
wM_NORMAL_HINTS = do
X Bool -> X () -> X ()
whenX (Window -> X Bool
isClient Window
w forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> Window -> X Bool
hintsMismatch Window
w) X ()
refresh
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
hintsEventHook Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
hintsMismatch :: Window -> X Bool
hintsMismatch :: Window -> X Bool
hintsMismatch Window
w = Window -> X (Maybe WindowAttributes)
safeGetWindowAttributes Window
w forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe WindowAttributes
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Just WindowAttributes
wa -> do
SizeHints
sh <- forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Window -> IO SizeHints
getWMNormalHints Display
d Window
w)
let dim :: (Dimension, Dimension)
dim = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa, forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Dimension, Dimension)
dim forall a. Eq a => a -> a -> Bool
/= forall a.
Integral a =>
Dimension -> SizeHints -> (a, a) -> (Dimension, Dimension)
applySizeHints Dimension
0 SizeHints
sh (Dimension, Dimension)
dim