1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.Mosaic
-- Copyright : (c) 2009 Adam Vogt, 2007 James Webb
-- License : BSD-style (see xmonad/LICENSE)
--
-- Maintainer : vogt.adam<at>gmail.com
-- Stability : unstable
-- Portability : unportable
--
-- Based on MosaicAlt, but aspect ratio messages always change the aspect
-- ratios, and rearranging the window stack changes the window sizes.
--
-----------------------------------------------------------------------------
module XMonad.Layout.Mosaic (
-- * Usage
-- $usage
Aspect(..)
,mosaic
,changeMaster
,changeFocused
)
where
import Prelude hiding (sum)
import XMonad(Typeable,
LayoutClass(doLayout, handleMessage, pureMessage, description),
Message, X, fromMessage, withWindowSet, Resize(..),
splitHorizontallyBy, splitVerticallyBy, sendMessage, Rectangle)
import qualified XMonad.StackSet as W
import Control.Arrow(Control.Arrow.Arrow(second, first))
import Control.Monad(mplus)
import Data.Foldable(Foldable(foldMap), sum)
import Data.Function(on)
import Data.List(sortBy)
import Data.Monoid(Monoid(mempty, mappend))
-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Layout.Mosaic
--
-- Then edit your @layoutHook@ by adding the Mosaic layout:
--
-- > myLayouts = mosaic 2 [3,2] ||| Full ||| etc..
-- > main = xmonad $ defaultConfig { layoutHook = myLayouts }
--
-- Unfortunately, infinite lists break serialization, so don't use them. And if
-- the list is too short, it is extended with @++ repeat 1@, which covers the
-- main use case.
--
-- To change the choice in aspect ratio and the relative sizes of windows, add
-- to your keybindings:
--
-- > , ((modMask, xK_a), sendMessage Taller)
-- > , ((modMask, xK_z), sendMessage Wider)
--
-- > , ((modMask, xK_r), sendMessage Reset)
--
-- For more detailed instructions on editing the layoutHook see:
--
-- "XMonad.Doc.Extending#Editing_the_layout_hook"
data Aspect
= Taller
| Wider
| Reset
| SlopeMod ([Rational] -> [Rational])
deriving (Typeable)
instance Message Aspect
-- | The relative magnitudes (the sign is ignored) of the rational numbers in
-- the second argument determine the relative areas that the windows receive.
-- The first number represents the size of the master window, the second is for
-- the next window in the stack, and so on.
--
-- The list is extended with @++ repeat 1@, so @mosaic 1.5 []@ is like a
-- resizable grid.
--
-- The first parameter is the multiplicative factor to use when responding to
-- the 'Expand' message.
mosaic :: Rational -> [Rational] -> Mosaic a
mosaic = Mosaic Nothing
data Mosaic a = -- | True to override the aspect, current index, maximum index
Mosaic (Maybe(Bool,Rational,Int)) Rational [Rational] deriving (Read,Show)
instance LayoutClass Mosaic a where
description = const "Mosaic"
pureMessage (Mosaic Nothing _ _) _ = Nothing
pureMessage (Mosaic (Just(_,ix,mix)) delta ss) ms = fromMessage ms >>= ixMod
where ixMod Taller | round ix >= mix = Nothing
| otherwise = Just $ Mosaic (Just(False,succ ix,mix)) delta ss
ixMod Wider | round ix <= (0::Integer) = Nothing
| otherwise = Just $ Mosaic (Just(False,pred ix,mix)) delta ss
ixMod Reset = Just $ Mosaic Nothing delta ss
ixMod (SlopeMod f) = Just $ Mosaic (Just(False,ix,mix)) delta (f ss)
handleMessage l@(Mosaic _ delta _) ms
| Just Expand <- fromMessage ms = changeFocused (*delta) >> return Nothing
| Just Shrink <- fromMessage ms = changeFocused (/delta) >> return Nothing
| otherwise = return $ pureMessage l ms
doLayout (Mosaic state delta ss) r st = let
ssExt = zipWith const (ss ++ repeat 1) $ W.integrate st
rects = splits r ssExt
nls = length rects
fi = fromIntegral
nextIx (ov,ix,mix)
| mix <= 0 || ov = fromIntegral $ nls `div` 2
| otherwise = max 0 $ (*fi (pred nls)) $ min 1 $ ix / fi mix
rect = rects !! maybe (nls `div` 2) round (nextIx `fmap` state)
state' = fmap (\x@(ov,_,_) -> (ov,nextIx x,pred nls)) state
`mplus` Just (True,fromIntegral nls / 2,pred nls)
ss' | and $ zipWith (==) ss ssExt = ss
| otherwise = ssExt
in return (zip (W.integrate st) rect, Just $ Mosaic state' delta ss')
-- | These sample functions are meant to be applied to the list of window sizes
-- through the 'SlopeMod' message.
changeMaster :: (Rational -> Rational) -> X ()
changeMaster = sendMessage . SlopeMod . onHead
-- | Apply a function to the Rational that represents the currently focused
-- window.
--
-- 'Expand' and 'Shrink' messages are responded to with @changeFocused
-- (*delta)@ or @changeFocused (delta/)@ where @delta@ is the first argument to
-- 'mosaic'.
--
-- This is exported because other functions (ex. @const 1@, @(+1)@) may be
-- useful to apply to the current area.
changeFocused :: (Rational -> Rational) -> X ()
changeFocused f = withWindowSet $ sendMessage . SlopeMod
. maybe id (mulIx . length . W.up)
. W.stack . W.workspace . W.current
where mulIx i = uncurry (++) . second (onHead f) . splitAt i
onHead :: (a -> a) -> [a] -> [a]
onHead f = uncurry (++) . first (fmap f) . splitAt 1
splits :: Rectangle -> [Rational] -> [[Rectangle]]
splits rect = map (reverse . map snd . sortBy (compare `on` fst))
. splitsL rect . makeTree snd . zip [1..]
. normalize . reverse . map abs
splitsL :: Rectangle -> Tree (Int,Rational) -> [[(Int,Rectangle)]]
splitsL _rect Empty = []
splitsL rect (Leaf (x,_)) = [[(x,rect)]]
splitsL rect (Branch l r) = do
let mkSplit f = f ((sumSnd l /) $ sumSnd l + sumSnd r) rect
sumSnd = sum . fmap snd
(rl,rr) <- map mkSplit [splitVerticallyBy,splitHorizontallyBy]
splitsL rl l `interleave` splitsL rr r
-- like zipWith (++), but when one list is shorter, its elements are duplicated
-- so that they match
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
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 Functor Tree where
fmap f (Leaf x) = Leaf $ f x
fmap f (Branch l r) = Branch (fmap f l) (fmap f r)
fmap _ Empty = Empty
instance Monoid (Tree a) where
mempty = Empty
mappend Empty x = x
mappend x Empty = x
mappend x y = Branch x y
makeTree :: (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree _ [] = Empty
makeTree _ [x] = Leaf x
makeTree f xs = Branch (makeTree f a) (makeTree f b)
where ((a,b),_) = foldr go (([],[]),(0,0)) xs
go n ((ls,rs),(l,r))
| l > r = ((ls,n:rs),(l,f n+r))
| otherwise = ((n:ls,rs),(f n+l,r))
|
