    {-# 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))