content: {-# 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
  
      ,Mosaic
      )
      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(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:
  --
  -- > myLayout = mosaic 2 [3,2] ||| Full ||| etc..
  -- > main = xmonad $ def { layoutHook = myLayout }
  --
  -- 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:
  --
  --  > , ((modm, xK_a), sendMessage Taller)
  --  > , ((modm, xK_z), sendMessage Wider)
  --
  --  > , ((modm, 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' = maybe ss (const ss `either` const ssExt) $ zipRemain ss ssExt
          in return (zip (W.integrate st) rect, Just $ Mosaic state' delta ss')
  
  zipRemain :: [a] -> [b] -> Maybe (Either [a] [b])
  zipRemain (_:xs) (_:ys) = zipRemain xs ys
  zipRemain [] [] = Nothing
  zipRemain [] y = Just (Right y)
  zipRemain x [] = Just (Left x)
  
  -- | 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))
  