{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TupleSections #-}
module XMonad.Layout.AvoidFloats (
avoidFloats,
avoidFloats',
AvoidFloatMsg(..),
AvoidFloatItemMsg(..),
) where
import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Prelude (fi, mapMaybe, maximumBy, sortOn)
import qualified XMonad.StackSet as W
import Data.Ord
import qualified Data.Map as M
import qualified Data.Set as S
avoidFloats
:: l a
-> ModifiedLayout AvoidFloats l a
avoidFloats :: forall (l :: * -> *) a. l a -> ModifiedLayout AvoidFloats l a
avoidFloats = Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
forall (l :: * -> *) a.
Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
avoidFloats' Int
100 Int
100 Bool
False
avoidFloats'
:: Int
-> Int
-> Bool
-> l a
-> ModifiedLayout AvoidFloats l a
avoidFloats' :: forall (l :: * -> *) a.
Int -> Int -> Bool -> l a -> ModifiedLayout AvoidFloats l a
avoidFloats' Int
w Int
h Bool
act = AvoidFloats a -> l a -> ModifiedLayout AvoidFloats l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Maybe ((Map a RationalRect, Rectangle), Rectangle)
-> Set a -> Int -> Int -> Bool -> AvoidFloats a
forall a.
Maybe ((Map a RationalRect, Rectangle), Rectangle)
-> Set a -> Int -> Int -> Bool -> AvoidFloats a
AvoidFloats Maybe ((Map a RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing Set a
forall a. Set a
S.empty Int
w Int
h Bool
act)
data AvoidFloats a = AvoidFloats
{ forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache :: Maybe ((M.Map a W.RationalRect, Rectangle), Rectangle)
, forall a. AvoidFloats a -> Set a
chosen :: S.Set a
, forall a. AvoidFloats a -> Int
minw :: Int
, forall a. AvoidFloats a -> Int
minh :: Int
, forall a. AvoidFloats a -> Bool
avoidAll :: Bool
} deriving (ReadPrec [AvoidFloats a]
ReadPrec (AvoidFloats a)
Int -> ReadS (AvoidFloats a)
ReadS [AvoidFloats a]
(Int -> ReadS (AvoidFloats a))
-> ReadS [AvoidFloats a]
-> ReadPrec (AvoidFloats a)
-> ReadPrec [AvoidFloats a]
-> Read (AvoidFloats a)
forall a. (Ord a, Read a) => ReadPrec [AvoidFloats a]
forall a. (Ord a, Read a) => ReadPrec (AvoidFloats a)
forall a. (Ord a, Read a) => Int -> ReadS (AvoidFloats a)
forall a. (Ord a, Read a) => ReadS [AvoidFloats a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AvoidFloats a]
$creadListPrec :: forall a. (Ord a, Read a) => ReadPrec [AvoidFloats a]
readPrec :: ReadPrec (AvoidFloats a)
$creadPrec :: forall a. (Ord a, Read a) => ReadPrec (AvoidFloats a)
readList :: ReadS [AvoidFloats a]
$creadList :: forall a. (Ord a, Read a) => ReadS [AvoidFloats a]
readsPrec :: Int -> ReadS (AvoidFloats a)
$creadsPrec :: forall a. (Ord a, Read a) => Int -> ReadS (AvoidFloats a)
Read, Int -> AvoidFloats a -> ShowS
[AvoidFloats a] -> ShowS
AvoidFloats a -> String
(Int -> AvoidFloats a -> ShowS)
-> (AvoidFloats a -> String)
-> ([AvoidFloats a] -> ShowS)
-> Show (AvoidFloats a)
forall a. Show a => Int -> AvoidFloats a -> ShowS
forall a. Show a => [AvoidFloats a] -> ShowS
forall a. Show a => AvoidFloats a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AvoidFloats a] -> ShowS
$cshowList :: forall a. Show a => [AvoidFloats a] -> ShowS
show :: AvoidFloats a -> String
$cshow :: forall a. Show a => AvoidFloats a -> String
showsPrec :: Int -> AvoidFloats a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AvoidFloats a -> ShowS
Show)
data AvoidFloatMsg
= AvoidFloatToggle
| AvoidFloatSet Bool
| AvoidFloatClearItems
data AvoidFloatItemMsg a
= AvoidFloatAddItem a
| AvoidFloatRemoveItem a
| AvoidFloatToggleItem a
instance Message AvoidFloatMsg
instance Typeable a => Message (AvoidFloatItemMsg a)
instance LayoutModifier AvoidFloats Window where
modifyLayoutWithUpdate :: forall (l :: * -> *).
LayoutClass l Window =>
AvoidFloats Window
-> Workspace String (l Window) Window
-> Rectangle
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window))
modifyLayoutWithUpdate AvoidFloats Window
lm Workspace String (l Window) Window
w Rectangle
r = (Display
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window))
forall a. (Display -> X a) -> X a
withDisplay ((Display
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> (Display
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window))
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
Map Window RationalRect
floating <- (XState -> Map Window RationalRect) -> X (Map Window RationalRect)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Map Window RationalRect)
-> X (Map Window RationalRect))
-> (XState -> Map Window RationalRect)
-> X (Map Window RationalRect)
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating (StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Map Window RationalRect)
-> (XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Map Window RationalRect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
case AvoidFloats Window
-> Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache AvoidFloats Window
lm of
Just ((Map Window RationalRect, Rectangle)
key, Rectangle
mer) | (Map Window RationalRect, Rectangle)
key (Map Window RationalRect, Rectangle)
-> (Map Window RationalRect, Rectangle) -> Bool
forall a. Eq a => a -> a -> Bool
== (Map Window RationalRect
floating,Rectangle
r) -> (, Maybe (AvoidFloats Window)
forall a. Maybe a
Nothing) (([(Window, Rectangle)], Maybe (l Window))
-> (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
w Rectangle
mer
Maybe ((Map Window RationalRect, Rectangle), Rectangle)
_ -> do [Rectangle]
rs <- IO [Rectangle] -> X [Rectangle]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [Rectangle] -> X [Rectangle])
-> IO [Rectangle] -> X [Rectangle]
forall a b. (a -> b) -> a -> b
$ (WindowAttributes -> Rectangle)
-> [WindowAttributes] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map WindowAttributes -> Rectangle
toRect ([WindowAttributes] -> [Rectangle])
-> IO [WindowAttributes] -> IO [Rectangle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Window -> IO WindowAttributes)
-> [Window] -> IO [WindowAttributes]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d) ((Window -> Bool) -> [Window] -> [Window]
forall a. (a -> Bool) -> [a] -> [a]
filter Window -> Bool
shouldAvoid ([Window] -> [Window]) -> [Window] -> [Window]
forall a b. (a -> b) -> a -> b
$ Map Window RationalRect -> [Window]
forall k a. Map k a -> [k]
M.keys Map Window RationalRect
floating)
let mer :: Rectangle
mer = (Rectangle -> Rectangle -> Ordering) -> [Rectangle] -> Rectangle
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Rectangle -> Int) -> Rectangle -> Rectangle -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Rectangle -> Int
area) ([Rectangle] -> Rectangle) -> [Rectangle] -> Rectangle
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter Rectangle -> Bool
bigEnough ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
r [Rectangle]
rs
(, AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window -> AvoidFloats Window
pruneWindows (AvoidFloats Window -> AvoidFloats Window)
-> AvoidFloats Window -> AvoidFloats Window
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = ((Map Window RationalRect, Rectangle), Rectangle)
-> Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. a -> Maybe a
Just ((Map Window RationalRect
floating,Rectangle
r),Rectangle
mer) }) (([(Window, Rectangle)], Maybe (l Window))
-> (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window)))
-> X ([(Window, Rectangle)], Maybe (l Window))
-> X (([(Window, Rectangle)], Maybe (l Window)),
Maybe (AvoidFloats Window))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
w Rectangle
mer
where
toRect :: WindowAttributes -> Rectangle
toRect :: WindowAttributes -> Rectangle
toRect WindowAttributes
wa = let b :: CInt
b = CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> CInt) -> CInt -> CInt
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_border_width WindowAttributes
wa
in Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_width WindowAttributes
wa CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
2CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
b) (CInt -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Dimension) -> CInt -> Dimension
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_height WindowAttributes
wa CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
2CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*CInt
b)
bigEnough :: Rectangle -> Bool
bigEnough :: Rectangle -> Bool
bigEnough Rectangle
rect = Rectangle -> Dimension
rect_width Rectangle
rect Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (AvoidFloats Window -> Int
forall a. AvoidFloats a -> Int
minw AvoidFloats Window
lm) Bool -> Bool -> Bool
&& Rectangle -> Dimension
rect_height Rectangle
rect Dimension -> Dimension -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (AvoidFloats Window -> Int
forall a. AvoidFloats a -> Int
minh AvoidFloats Window
lm)
shouldAvoid :: Window -> Bool
shouldAvoid Window
a = AvoidFloats Window -> Bool
forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm Bool -> Bool -> Bool
|| Window
a Window -> Set Window -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm
pureMess :: AvoidFloats Window -> SomeMessage -> Maybe (AvoidFloats Window)
pureMess AvoidFloats Window
lm SomeMessage
m
| Just AvoidFloatMsg
AvoidFloatToggle <- SomeMessage -> Maybe AvoidFloatMsg
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { avoidAll :: Bool
avoidAll = Bool -> Bool
not (AvoidFloats Window -> Bool
forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Just (AvoidFloatSet Bool
s) <- SomeMessage -> Maybe AvoidFloatMsg
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Bool
s Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= AvoidFloats Window -> Bool
forall a. AvoidFloats a -> Bool
avoidAll AvoidFloats Window
lm = AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { avoidAll :: Bool
avoidAll = Bool
s, cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Just AvoidFloatMsg
AvoidFloatClearItems <- SomeMessage -> Maybe AvoidFloatMsg
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = Set Window
forall a. Set a
S.empty, cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Just (AvoidFloatAddItem Window
a) <- SomeMessage -> Maybe (AvoidFloatItemMsg Window)
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Window
a Window -> Set Window -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm = AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.insert Window
a (AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Just (AvoidFloatRemoveItem Window
a) <- SomeMessage -> Maybe (AvoidFloatItemMsg Window)
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m, Window
a Window -> Set Window -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm = AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.delete Window
a (AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Just (AvoidFloatToggleItem Window
a) <- SomeMessage -> Maybe (AvoidFloatItemMsg Window)
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = let op :: Window -> Set Window -> Set Window
op = if Window
a Window -> Set Window -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm then Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.delete else Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.insert
in AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a. a -> Maybe a
Just (AvoidFloats Window -> Maybe (AvoidFloats Window))
-> AvoidFloats Window -> Maybe (AvoidFloats Window)
forall a b. (a -> b) -> a -> b
$ AvoidFloats Window
lm { chosen :: Set Window
chosen = Window -> Set Window -> Set Window
op Window
a (AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm), cache :: Maybe ((Map Window RationalRect, Rectangle), Rectangle)
cache = Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a. Maybe a
Nothing }
| Bool
otherwise = Maybe (AvoidFloats Window)
forall a. Maybe a
Nothing
pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows :: AvoidFloats Window -> AvoidFloats Window
pruneWindows AvoidFloats Window
lm = case AvoidFloats Window
-> Maybe ((Map Window RationalRect, Rectangle), Rectangle)
forall a.
AvoidFloats a -> Maybe ((Map a RationalRect, Rectangle), Rectangle)
cache AvoidFloats Window
lm of
Maybe ((Map Window RationalRect, Rectangle), Rectangle)
Nothing -> AvoidFloats Window
lm
Just ((Map Window RationalRect
floating,Rectangle
_),Rectangle
_) -> AvoidFloats Window
lm { chosen :: Set Window
chosen = (Window -> Bool) -> Set Window -> Set Window
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Window -> Map Window RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Window RationalRect
floating) (AvoidFloats Window -> Set Window
forall a. AvoidFloats a -> Set a
chosen AvoidFloats Window
lm) }
maxEmptyRectangles :: Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles :: Rectangle -> [Rectangle] -> [Rectangle]
maxEmptyRectangles Rectangle
br [Rectangle]
rectangles = (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
area Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ [Rectangle]
upAndDownEdge [Rectangle] -> [Rectangle] -> [Rectangle]
forall a. [a] -> [a] -> [a]
++ [Rectangle]
noneOrUpEdge [Rectangle] -> [Rectangle] -> [Rectangle]
forall a. [a] -> [a] -> [a]
++ [Rectangle]
downEdge
where
upAndDownEdge :: [Rectangle]
upAndDownEdge = Rectangle -> [Rectangle] -> [Rectangle]
findGaps Rectangle
br [Rectangle]
rectangles
noneOrUpEdge :: [Rectangle]
noneOrUpEdge = (Rectangle -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower Rectangle
br [Rectangle]
bottoms) [Rectangle]
bottoms
downEdge :: [Rectangle]
downEdge = (Rectangle -> Maybe Rectangle) -> [Rectangle] -> [Rectangle]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge Rectangle
br [Rectangle]
bottoms) [Rectangle]
bottoms
bottoms :: [Rectangle]
bottoms = (Rectangle -> Int) -> [Rectangle] -> [Rectangle]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Rectangle -> Int
bottom ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ [Rectangle] -> [Rectangle]
splitContainers [Rectangle]
rectangles
everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]
everyLower Rectangle
br [Rectangle]
bottoms Rectangle
r = let ([Rectangle]
rs, Int
boundLeft, Int
boundRight, [Rectangle]
boundRects) = (Rectangle
-> ([Rectangle], Int, Int, [Rectangle])
-> ([Rectangle], Int, Int, [Rectangle]))
-> ([Rectangle], Int, Int, [Rectangle])
-> [Rectangle]
-> ([Rectangle], Int, Int, [Rectangle])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Rectangle
-> Rectangle
-> ([Rectangle], Int, Int, [Rectangle])
-> ([Rectangle], Int, Int, [Rectangle])
everyUpper Rectangle
r) ([], Rectangle -> Int
left Rectangle
br, Rectangle -> Int
right Rectangle
br, [Rectangle] -> [Rectangle]
forall a. [a] -> [a]
reverse [Rectangle]
bottoms) [Rectangle]
bottoms
(Int
boundLeft', Int
boundRight', [Rectangle]
_) = Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
r (Rectangle -> Int
top Rectangle
br)
in Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft' Int
boundRight' (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
top Rectangle
r) Maybe Rectangle -> [Rectangle] -> [Rectangle]
forall a. Maybe a -> [a] -> [a]
?: [Rectangle]
rs
everyUpper
:: Rectangle
-> Rectangle
-> ([Rectangle],Int,Int,[Rectangle])
-> ([Rectangle],Int,Int,[Rectangle])
everyUpper :: Rectangle
-> Rectangle
-> ([Rectangle], Int, Int, [Rectangle])
-> ([Rectangle], Int, Int, [Rectangle])
everyUpper Rectangle
lower Rectangle
upper ([Rectangle]
rs, Int
boundLeft, Int
boundRight, [Rectangle]
boundRects) = (Maybe Rectangle
rMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall a. Maybe a -> [a] -> [a]
?:[Rectangle]
rs, Int
boundLeft', Int
boundRight', [Rectangle]
boundRects')
where
r :: Maybe Rectangle
r = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft' Int
boundRight' (Rectangle -> Int
bottom Rectangle
upper) (Rectangle -> Int
top Rectangle
lower)
(Int
boundLeft', Int
boundRight', [Rectangle]
boundRects') = Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
lower (Rectangle -> Int
bottom Rectangle
upper)
shrinkBounds :: Int -> Int -> [Rectangle] -> Rectangle -> Int -> (Int, Int, [Rectangle])
shrinkBounds :: Int
-> Int
-> [Rectangle]
-> Rectangle
-> Int
-> (Int, Int, [Rectangle])
shrinkBounds Int
boundLeft Int
boundRight [Rectangle]
boundRects Rectangle
lower Int
upperLimit = (Int
boundLeft', Int
boundRight', [Rectangle]
boundRects')
where
([Rectangle]
shrinkers, [Rectangle]
boundRects') = (Rectangle -> Bool) -> [Rectangle] -> ([Rectangle], [Rectangle])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upperLimit) [Rectangle]
boundRects
(Int
boundLeft', Int
boundRight') = (Rectangle -> (Int, Int) -> (Int, Int))
-> (Int, Int) -> [Rectangle] -> (Int, Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' Rectangle
lower) (Int
boundLeft, Int
boundRight) ([Rectangle] -> (Int, Int)) -> [Rectangle] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
top Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
top Rectangle
lower) [Rectangle]
shrinkers
shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)
shrinkBounds' Rectangle
mr Rectangle
r (Int
boundLeft, Int
boundRight)
| Rectangle -> Int
right Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
mr = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
boundLeft (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
r, Int
boundRight)
| Rectangle -> Int
left Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
mr = (Int
boundLeft, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
boundRight (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
left Rectangle
r)
| Bool
otherwise = (Rectangle -> Int
right Rectangle
r, Rectangle -> Int
left Rectangle
r)
bottomEdge :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle
bottomEdge Rectangle
br [Rectangle]
bottoms Rectangle
r = let rs :: [Rectangle]
rs = (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Rectangle
a -> Rectangle -> Int
bottom Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
a Bool -> Bool -> Bool
&& Rectangle -> Int
top Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
bottom Rectangle
br) [Rectangle]
bottoms
boundLeft :: Int
boundLeft = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
left Rectangle
br Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
r) ((Rectangle -> Int) -> [Rectangle] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
right [Rectangle]
rs)
boundRight :: Int
boundRight = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Rectangle -> Int
right Rectangle
br Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Rectangle -> Int
left Rectangle
r) ((Rectangle -> Int) -> [Rectangle] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> Int
left [Rectangle]
rs)
in if (Rectangle -> Bool) -> [Rectangle] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Rectangle
a -> Rectangle -> Int
left Rectangle
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
&& Rectangle -> Int
right Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
a) [Rectangle]
rs
then Maybe Rectangle
forall a. Maybe a
Nothing
else Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
boundLeft Int
boundRight (Rectangle -> Int
bottom Rectangle
r) (Rectangle -> Int
bottom Rectangle
br)
splitContainers :: [Rectangle] -> [Rectangle]
splitContainers :: [Rectangle] -> [Rectangle]
splitContainers [Rectangle]
rects = [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' [] ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Dimension) -> [Rectangle] -> [Rectangle]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Rectangle -> Dimension
rect_width [Rectangle]
rects
where
splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' [Rectangle]
res [] = [Rectangle]
res
splitContainers' [Rectangle]
res (Rectangle
r:[Rectangle]
rs) = [Rectangle] -> [Rectangle] -> [Rectangle]
splitContainers' (Rectangle
rRectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
:[Rectangle]
res) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rectangle -> Rectangle -> [Rectangle]
doSplit Rectangle
r) [Rectangle]
rs
doSplit :: Rectangle -> Rectangle -> [Rectangle]
doSplit :: Rectangle -> Rectangle -> [Rectangle]
doSplit Rectangle
guide Rectangle
r
| Rectangle -> Int
left Rectangle
guide Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
left Rectangle
r Bool -> Bool -> Bool
|| Rectangle -> Int
right Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Rectangle -> Int
right Rectangle
guide = [Rectangle
r]
| Bool
otherwise = let w0 :: Dimension
w0 = Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
guide Position -> Position -> Position
forall a. Num a => a -> a -> a
- Rectangle -> Position
rect_x Rectangle
r) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ (Rectangle -> Dimension
rect_width Rectangle
guide Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
2)
w1 :: Dimension
w1 = Rectangle -> Dimension
rect_width Rectangle
r Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
w0
in [ Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Rectangle -> Position
rect_x Rectangle
r) (Rectangle -> Position
rect_y Rectangle
r) Dimension
w0 (Rectangle -> Dimension
rect_height Rectangle
r)
, Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Rectangle -> Position
rect_x Rectangle
r Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
w0) (Rectangle -> Position
rect_y Rectangle
r) Dimension
w1 (Rectangle -> Dimension
rect_height Rectangle
r)
]
findGaps
:: Rectangle
-> [Rectangle]
-> [Rectangle]
findGaps :: Rectangle -> [Rectangle] -> [Rectangle]
findGaps Rectangle
br [Rectangle]
rs = let ([Rectangle]
gaps,Int
end) = (Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int))
-> ([Rectangle], Int) -> [Rectangle] -> ([Rectangle], Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
findGaps' ([], Rectangle -> Int
left Rectangle
br) ([Rectangle] -> ([Rectangle], Int))
-> [Rectangle] -> ([Rectangle], Int)
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Down Int) -> [Rectangle] -> [Rectangle]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> (Rectangle -> Int) -> Rectangle -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> Int
left) ([Rectangle] -> [Rectangle]) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Rectangle -> Bool) -> [Rectangle] -> [Rectangle]
forall a. (a -> Bool) -> [a] -> [a]
filter Rectangle -> Bool
inBounds [Rectangle]
rs
lastgap :: Maybe Rectangle
lastgap = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
end (Rectangle -> Int
right Rectangle
br) (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
bottom Rectangle
br)
in Maybe Rectangle
lastgapMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall a. Maybe a -> [a] -> [a]
?:[Rectangle]
gaps
where
findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)
findGaps' Rectangle
r ([Rectangle]
gaps, Int
end) = let gap :: Maybe Rectangle
gap = Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
end (Rectangle -> Int
left Rectangle
r) (Rectangle -> Int
top Rectangle
br) (Rectangle -> Int
bottom Rectangle
br)
in (Maybe Rectangle
gapMaybe Rectangle -> [Rectangle] -> [Rectangle]
forall a. Maybe a -> [a] -> [a]
?:[Rectangle]
gaps, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
end (Rectangle -> Int
right Rectangle
r))
inBounds :: Rectangle -> Bool
inBounds :: Rectangle -> Bool
inBounds Rectangle
r = Rectangle -> Int
left Rectangle
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
br Bool -> Bool -> Bool
&& Rectangle -> Int
left Rectangle
br Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rectangle -> Int
right Rectangle
r
(?:) :: Maybe a -> [a] -> [a]
Just a
x ?: :: forall a. Maybe a -> [a] -> [a]
?: [a]
xs = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs
Maybe a
_ ?: [a]
xs = [a]
xs
left, right, top, bottom, area :: Rectangle -> Int
left :: Rectangle -> Int
left Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r)
right :: Rectangle -> Int
right Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_x Rectangle
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r)
top :: Rectangle -> Int
top Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r)
bottom :: Rectangle -> Int
bottom Rectangle
r = Position -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Position
rect_y Rectangle
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
r)
area :: Rectangle -> Int
area Rectangle
r = Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
r Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Rectangle -> Dimension
rect_height Rectangle
r)
mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle
mkRect Int
l Int
r Int
t Int
b = let rect :: Rectangle
rect = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
l) (Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi Int
t) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Dimension) -> Int -> Dimension
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
l) (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Dimension) -> Int -> Dimension
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t)
in if Rectangle -> Int
area Rectangle
rect Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
rect
else Maybe Rectangle
forall a. Maybe a
Nothing