module XMonad.Layout.Mosaic (
Mosaic(Mosaic)
,Aspect(..)
,shallower
,steeper
,growMaster
,shrinkMaster
,changeMaster
)
where
import Prelude hiding (sum)
import XMonad(Typeable,
LayoutClass(doLayout , pureMessage, description), Message,
fromMessage, splitHorizontallyBy, splitVerticallyBy, Rectangle)
import XMonad.StackSet(integrate)
import Data.Foldable(Foldable(foldMap), sum)
import Data.Monoid(Monoid(mappend, mempty))
data Aspect
= Taller
| Wider
| Reset
| SlopeMod ([Rational] -> [Rational])
deriving (Typeable)
instance Message Aspect
data Mosaic a
= Mosaic [Rational]
| MosaicSt Bool Rational Int [Rational]
deriving (Read, Show)
instance LayoutClass Mosaic a where
description = const "Mosaic"
pureMessage (Mosaic _ss) _ms = Nothing
pureMessage (MosaicSt _ ix mix ss) ms = fromMessage ms >>= ixMod
where ixMod Taller | rix >= mix = Nothing
| otherwise = Just $ MosaicSt False (succ ix) mix ss
ixMod Wider | rix <= 0 = Nothing
| otherwise = Just $ MosaicSt False (pred ix) mix ss
ixMod Reset = Just $ Mosaic ss
ixMod (SlopeMod f) = Just $ MosaicSt False ix mix (f ss)
rix = round ix
doLayout (Mosaic ss) r st = return (zip (integrate st) rect, newLayout)
where rects = splits (length $ integrate st) r ss
lrects = length rects
rect = rects !! (lrects `div` 2)
newLayout = Just $ MosaicSt True (fromIntegral lrects / 2) (pred lrects) ss
doLayout (MosaicSt override ix mix ss) r st
= return (zip (integrate st) rect, newLayout)
where rects = splits (length $ integrate st) r ss
lrects = length rects
nix = if mix == 0 || override then fromIntegral $ lrects `div` 2
else max 0 $ min (fromIntegral $ pred lrects)
$ fromIntegral (pred lrects) * ix / fromIntegral mix
rect = rects !! round nix
newLayout = Just $ MosaicSt override nix (pred lrects) ss
steeper :: [Rational] -> [Rational]
steeper [] = []
steeper xs = map (subtract (minimum xs*0.8)) xs
shallower :: [Rational] -> [Rational]
shallower [] = []
shallower xs = map (+(minimum xs*2)) xs
growMaster :: [Rational] -> [Rational]
growMaster = changeMaster 2
shrinkMaster :: [Rational] -> [Rational]
shrinkMaster = changeMaster 0.5
changeMaster :: Rational -> [Rational] -> [Rational]
changeMaster _ [] = []
changeMaster f (x:xs) = f*x:xs
splits :: Int -> Rectangle -> [Rational] -> [[Rectangle]]
splits num rect = splitsL rect . makeTree . normalize
. map abs . reverse . take num
splitsL :: Rectangle -> Tree Rational -> [[Rectangle]]
splitsL _rect Empty = []
splitsL rect (Leaf _) = [[rect]]
splitsL rect (Branch l r) = do
let mkSplit f = f (sum l / (sum l + sum r)) rect
(rl,rr) <- map mkSplit [splitVerticallyBy,splitHorizontallyBy]
splitsL rl l `interleave` splitsL rr r
interleave :: [[a]] -> [[a]] -> [[a]]
interleave xs ys | lx > ly = zc xs (extend lx ys)
| otherwise = zc (extend ly xs) ys
where lx = length xs
ly = length ys
zc = zipWith (++)
extend :: Int -> [a] -> [a]
extend n pat = do
(p,e) <- zip pat $ replicate m True ++ repeat False
[p | e] ++ replicate d p
where (d,m) = n `divMod` length pat
normalize :: Fractional a => [a] -> [a]
normalize x = let s = sum x
in map (/s) x
data Tree a = Branch (Tree a) (Tree a) | Leaf a | Empty
deriving (Show)
instance Foldable Tree where
foldMap _f Empty = mempty
foldMap f (Leaf x) = f x
foldMap f (Branch l r) = foldMap f l `mappend` foldMap f r
instance Monoid (Tree a) where
mempty = Empty
mappend Empty x = x
mappend x Empty = x
mappend x y = Branch x y
makeTree :: [Rational] -> Tree Rational
makeTree [] = Empty
makeTree [x] = Leaf x
makeTree xs = Branch (makeTree a) (makeTree b)
where ((a,b),_) = foldr w (([],[]),(0,0)) xs
w n ((ls,rs),(l,r)) = if l > r then ((ls,n:rs),(l,n+r))
else ((n:ls,rs),(n+l,r))