{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.Mosaic
-- Description :  Give each window a specified amount of screen space relative to the others.
-- 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(LayoutClass(doLayout, handleMessage, pureMessage, description),
              Message, X, fromMessage, withWindowSet, Resize(..),
              splitHorizontallyBy, splitVerticallyBy, sendMessage, Rectangle)
import XMonad.Prelude (mplus, on, sortBy, sum)
import qualified XMonad.StackSet as W
import Control.Arrow(second, first)

-- $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])

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 :: Rational -> [Rational] -> Mosaic a
mosaic = Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic Maybe (Bool, Rational, Int)
forall a. Maybe a
Nothing

data Mosaic a = -- | True to override the aspect, current index, maximum index
                Mosaic (Maybe(Bool,Rational,Int)) Rational [Rational] deriving (ReadPrec [Mosaic a]
ReadPrec (Mosaic a)
Int -> ReadS (Mosaic a)
ReadS [Mosaic a]
(Int -> ReadS (Mosaic a))
-> ReadS [Mosaic a]
-> ReadPrec (Mosaic a)
-> ReadPrec [Mosaic a]
-> Read (Mosaic a)
forall a. ReadPrec [Mosaic a]
forall a. ReadPrec (Mosaic a)
forall a. Int -> ReadS (Mosaic a)
forall a. ReadS [Mosaic a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Mosaic a]
$creadListPrec :: forall a. ReadPrec [Mosaic a]
readPrec :: ReadPrec (Mosaic a)
$creadPrec :: forall a. ReadPrec (Mosaic a)
readList :: ReadS [Mosaic a]
$creadList :: forall a. ReadS [Mosaic a]
readsPrec :: Int -> ReadS (Mosaic a)
$creadsPrec :: forall a. Int -> ReadS (Mosaic a)
Read,Int -> Mosaic a -> ShowS
[Mosaic a] -> ShowS
Mosaic a -> String
(Int -> Mosaic a -> ShowS)
-> (Mosaic a -> String) -> ([Mosaic a] -> ShowS) -> Show (Mosaic a)
forall a. Int -> Mosaic a -> ShowS
forall a. [Mosaic a] -> ShowS
forall a. Mosaic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mosaic a] -> ShowS
$cshowList :: forall a. [Mosaic a] -> ShowS
show :: Mosaic a -> String
$cshow :: forall a. Mosaic a -> String
showsPrec :: Int -> Mosaic a -> ShowS
$cshowsPrec :: forall a. Int -> Mosaic a -> ShowS
Show)

instance LayoutClass Mosaic a where
    description :: Mosaic a -> String
description = String -> Mosaic a -> String
forall a b. a -> b -> a
const String
"Mosaic"

    pureMessage :: Mosaic a -> SomeMessage -> Maybe (Mosaic a)
pureMessage (Mosaic Maybe (Bool, Rational, Int)
Nothing Rational
_ [Rational]
_) SomeMessage
_ = Maybe (Mosaic a)
forall a. Maybe a
Nothing
    pureMessage (Mosaic (Just(Bool
_,Rational
ix,Int
mix)) Rational
delta [Rational]
ss) SomeMessage
ms = SomeMessage -> Maybe Aspect
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
ms Maybe Aspect -> (Aspect -> Maybe (Mosaic a)) -> Maybe (Mosaic a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Aspect -> Maybe (Mosaic a)
forall a. Aspect -> Maybe (Mosaic a)
ixMod
        where ixMod :: Aspect -> Maybe (Mosaic a)
ixMod Aspect
Taller | Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
ix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
mix = Maybe (Mosaic a)
forall a. Maybe a
Nothing
                           | Bool
otherwise = Mosaic a -> Maybe (Mosaic a)
forall a. a -> Maybe a
Just (Mosaic a -> Maybe (Mosaic a)) -> Mosaic a -> Maybe (Mosaic a)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic ((Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall a. a -> Maybe a
Just(Bool
False,Rational -> Rational
forall a. Enum a => a -> a
succ Rational
ix,Int
mix)) Rational
delta [Rational]
ss
              ixMod Aspect
Wider  | Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round Rational
ix Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= (Integer
0::Integer) = Maybe (Mosaic a)
forall a. Maybe a
Nothing
                           | Bool
otherwise = Mosaic a -> Maybe (Mosaic a)
forall a. a -> Maybe a
Just (Mosaic a -> Maybe (Mosaic a)) -> Mosaic a -> Maybe (Mosaic a)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic ((Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall a. a -> Maybe a
Just(Bool
False,Rational -> Rational
forall a. Enum a => a -> a
pred Rational
ix,Int
mix)) Rational
delta [Rational]
ss
              ixMod Aspect
Reset              = Mosaic a -> Maybe (Mosaic a)
forall a. a -> Maybe a
Just (Mosaic a -> Maybe (Mosaic a)) -> Mosaic a -> Maybe (Mosaic a)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic Maybe (Bool, Rational, Int)
forall a. Maybe a
Nothing Rational
delta [Rational]
ss
              ixMod (SlopeMod [Rational] -> [Rational]
f)       = Mosaic a -> Maybe (Mosaic a)
forall a. a -> Maybe a
Just (Mosaic a -> Maybe (Mosaic a)) -> Mosaic a -> Maybe (Mosaic a)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic ((Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall a. a -> Maybe a
Just(Bool
False,Rational
ix,Int
mix)) Rational
delta ([Rational] -> [Rational]
f [Rational]
ss)

    handleMessage :: Mosaic a -> SomeMessage -> X (Maybe (Mosaic a))
handleMessage l :: Mosaic a
l@(Mosaic Maybe (Bool, Rational, Int)
_ Rational
delta [Rational]
_) SomeMessage
ms
        | Just Resize
Expand <- SomeMessage -> Maybe Resize
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
ms = (Rational -> Rational) -> X ()
changeFocused (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
delta) X () -> X (Maybe (Mosaic a)) -> X (Maybe (Mosaic a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Mosaic a) -> X (Maybe (Mosaic a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Mosaic a)
forall a. Maybe a
Nothing
        | Just Resize
Shrink <- SomeMessage -> Maybe Resize
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
ms = (Rational -> Rational) -> X ()
changeFocused (Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
delta) X () -> X (Maybe (Mosaic a)) -> X (Maybe (Mosaic a))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Mosaic a) -> X (Maybe (Mosaic a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Mosaic a)
forall a. Maybe a
Nothing
        | Bool
otherwise = Maybe (Mosaic a) -> X (Maybe (Mosaic a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Mosaic a) -> X (Maybe (Mosaic a)))
-> Maybe (Mosaic a) -> X (Maybe (Mosaic a))
forall a b. (a -> b) -> a -> b
$ Mosaic a -> SomeMessage -> Maybe (Mosaic a)
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> Maybe (layout a)
pureMessage Mosaic a
l SomeMessage
ms

    doLayout :: Mosaic a
-> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Mosaic a))
doLayout (Mosaic Maybe (Bool, Rational, Int)
state Rational
delta [Rational]
ss) Rectangle
r Stack a
st = let
        ssExt :: [Rational]
ssExt = (Rational -> a -> Rational) -> [Rational] -> [a] -> [Rational]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Rational -> a -> Rational
forall a b. a -> b -> a
const ([Rational]
ss [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
++ Rational -> [Rational]
forall a. a -> [a]
repeat Rational
1) ([a] -> [Rational]) -> [a] -> [Rational]
forall a b. (a -> b) -> a -> b
$ Stack a -> [a]
forall a. Stack a -> [a]
W.integrate Stack a
st
        rects :: [[Rectangle]]
rects = Rectangle -> [Rational] -> [[Rectangle]]
splits Rectangle
r [Rational]
ssExt
        nls :: Int
nls = [[Rectangle]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Rectangle]]
rects
        fi :: Int -> Rational
fi = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        nextIx :: (Bool, Rational, Int) -> Rational
nextIx (Bool
ov,Rational
ix,Int
mix)
                | Int
mix Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Bool
ov = Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Rational) -> Int -> Rational
forall a b. (a -> b) -> a -> b
$ Int
nls Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                | Bool
otherwise = Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max Rational
0 (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Int -> Rational
fi (Int -> Int
forall a. Enum a => a -> a
pred Int
nls)) (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
1 (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Rational
ix Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Int -> Rational
fi Int
mix
        rect :: [Rectangle]
rect = [[Rectangle]]
rects [[Rectangle]] -> Int -> [Rectangle]
forall a. [a] -> Int -> a
!! Int -> (Rational -> Int) -> Maybe Rational -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int
nls Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round ((Bool, Rational, Int) -> Rational
nextIx ((Bool, Rational, Int) -> Rational)
-> Maybe (Bool, Rational, Int) -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, Rational, Int)
state)
        state' :: Maybe (Bool, Rational, Int)
state' = ((Bool, Rational, Int) -> (Bool, Rational, Int))
-> Maybe (Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: (Bool, Rational, Int)
x@(Bool
ov,Rational
_,Int
_) -> (Bool
ov,(Bool, Rational, Int) -> Rational
nextIx (Bool, Rational, Int)
x,Int -> Int
forall a. Enum a => a -> a
pred Int
nls)) Maybe (Bool, Rational, Int)
state
                    Maybe (Bool, Rational, Int)
-> Maybe (Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Bool, Rational, Int) -> Maybe (Bool, Rational, Int)
forall a. a -> Maybe a
Just (Bool
True,Int -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nls Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2,Int -> Int
forall a. Enum a => a -> a
pred Int
nls)
        ss' :: [Rational]
ss' = [Rational]
-> (Either [Rational] [Rational] -> [Rational])
-> Maybe (Either [Rational] [Rational])
-> [Rational]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Rational]
ss ([Rational] -> [Rational] -> [Rational]
forall a b. a -> b -> a
const [Rational]
ss ([Rational] -> [Rational])
-> ([Rational] -> [Rational])
-> Either [Rational] [Rational]
-> [Rational]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
`either` [Rational] -> [Rational] -> [Rational]
forall a b. a -> b -> a
const [Rational]
ssExt) (Maybe (Either [Rational] [Rational]) -> [Rational])
-> Maybe (Either [Rational] [Rational]) -> [Rational]
forall a b. (a -> b) -> a -> b
$ [Rational] -> [Rational] -> Maybe (Either [Rational] [Rational])
forall a b. [a] -> [b] -> Maybe (Either [a] [b])
zipRemain [Rational]
ss [Rational]
ssExt
        in ([(a, Rectangle)], Maybe (Mosaic a))
-> X ([(a, Rectangle)], Maybe (Mosaic a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [Rectangle] -> [(a, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Stack a -> [a]
forall a. Stack a -> [a]
W.integrate Stack a
st) [Rectangle]
rect, Mosaic a -> Maybe (Mosaic a)
forall a. a -> Maybe a
Just (Mosaic a -> Maybe (Mosaic a)) -> Mosaic a -> Maybe (Mosaic a)
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
forall a.
Maybe (Bool, Rational, Int) -> Rational -> [Rational] -> Mosaic a
Mosaic Maybe (Bool, Rational, Int)
state' Rational
delta [Rational]
ss')

zipRemain :: [a] -> [b] -> Maybe (Either [a] [b])
zipRemain :: [a] -> [b] -> Maybe (Either [a] [b])
zipRemain (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Maybe (Either [a] [b])
forall a b. [a] -> [b] -> Maybe (Either [a] [b])
zipRemain [a]
xs [b]
ys
zipRemain [] [] = Maybe (Either [a] [b])
forall a. Maybe a
Nothing
zipRemain [] [b]
y = Either [a] [b] -> Maybe (Either [a] [b])
forall a. a -> Maybe a
Just ([b] -> Either [a] [b]
forall a b. b -> Either a b
Right [b]
y)
zipRemain [a]
x [] = Either [a] [b] -> Maybe (Either [a] [b])
forall a. a -> Maybe a
Just ([a] -> Either [a] [b]
forall a b. a -> Either a b
Left [a]
x)

-- | These sample functions are meant to be applied to the list of window sizes
-- through the 'SlopeMod' message.
changeMaster :: (Rational -> Rational) -> X ()
changeMaster :: (Rational -> Rational) -> X ()
changeMaster = Aspect -> X ()
forall a. Message a => a -> X ()
sendMessage (Aspect -> X ())
-> ((Rational -> Rational) -> Aspect)
-> (Rational -> Rational)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Rational] -> [Rational]) -> Aspect
SlopeMod (([Rational] -> [Rational]) -> Aspect)
-> ((Rational -> Rational) -> [Rational] -> [Rational])
-> (Rational -> Rational)
-> Aspect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational) -> [Rational] -> [Rational]
forall a. (a -> a) -> [a] -> [a]
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 :: (Rational -> Rational) -> X ()
changeFocused Rational -> Rational
f = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ Aspect -> X ()
forall a. Message a => a -> X ()
sendMessage (Aspect -> X ()) -> (WindowSet -> Aspect) -> WindowSet -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Rational] -> [Rational]) -> Aspect
SlopeMod
                    (([Rational] -> [Rational]) -> Aspect)
-> (WindowSet -> [Rational] -> [Rational]) -> WindowSet -> Aspect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Rational] -> [Rational])
-> (Stack Window -> [Rational] -> [Rational])
-> Maybe (Stack Window)
-> [Rational]
-> [Rational]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Rational] -> [Rational]
forall a. a -> a
id (Int -> [Rational] -> [Rational]
mulIx (Int -> [Rational] -> [Rational])
-> (Stack Window -> Int)
-> Stack Window
-> [Rational]
-> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Window] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Window] -> Int)
-> (Stack Window -> [Window]) -> Stack Window -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack Window -> [Window]
forall a. Stack a -> [a]
W.up)
                    (Maybe (Stack Window) -> [Rational] -> [Rational])
-> (WindowSet -> Maybe (Stack Window))
-> WindowSet
-> [Rational]
-> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace String (Layout Window) Window -> Maybe (Stack Window))
-> (WindowSet -> Workspace String (Layout Window) Window)
-> WindowSet
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Workspace String (Layout Window) Window)
-> (WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> Workspace String (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current
    where mulIx :: Int -> [Rational] -> [Rational]
mulIx Int
i = ([Rational] -> [Rational] -> [Rational])
-> ([Rational], [Rational]) -> [Rational]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
(++) (([Rational], [Rational]) -> [Rational])
-> ([Rational] -> ([Rational], [Rational]))
-> [Rational]
-> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Rational] -> [Rational])
-> ([Rational], [Rational]) -> ([Rational], [Rational])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Rational -> Rational) -> [Rational] -> [Rational]
forall a. (a -> a) -> [a] -> [a]
onHead Rational -> Rational
f) (([Rational], [Rational]) -> ([Rational], [Rational]))
-> ([Rational] -> ([Rational], [Rational]))
-> [Rational]
-> ([Rational], [Rational])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Rational] -> ([Rational], [Rational])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i

onHead :: (a -> a) -> [a] -> [a]
onHead :: (a -> a) -> [a] -> [a]
onHead a -> a
f = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (([a], [a]) -> [a]) -> ([a] -> ([a], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((a -> a) -> [a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
f) (([a], [a]) -> ([a], [a]))
-> ([a] -> ([a], [a])) -> [a] -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1

splits :: Rectangle -> [Rational] -> [[Rectangle]]
splits :: Rectangle -> [Rational] -> [[Rectangle]]
splits Rectangle
rect = ([(Int, Rectangle)] -> [Rectangle])
-> [[(Int, Rectangle)]] -> [[Rectangle]]
forall a b. (a -> b) -> [a] -> [b]
map ([Rectangle] -> [Rectangle]
forall a. [a] -> [a]
reverse ([Rectangle] -> [Rectangle])
-> ([(Int, Rectangle)] -> [Rectangle])
-> [(Int, Rectangle)]
-> [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Rectangle) -> Rectangle)
-> [(Int, Rectangle)] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Rectangle) -> Rectangle
forall a b. (a, b) -> b
snd ([(Int, Rectangle)] -> [Rectangle])
-> ([(Int, Rectangle)] -> [(Int, Rectangle)])
-> [(Int, Rectangle)]
-> [Rectangle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Rectangle) -> (Int, Rectangle) -> Ordering)
-> [(Int, Rectangle)] -> [(Int, Rectangle)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Rectangle) -> Int)
-> (Int, Rectangle)
-> (Int, Rectangle)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Rectangle) -> Int
forall a b. (a, b) -> a
fst))
                ([[(Int, Rectangle)]] -> [[Rectangle]])
-> ([Rational] -> [[(Int, Rectangle)]])
-> [Rational]
-> [[Rectangle]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> Tree (Int, Rational) -> [[(Int, Rectangle)]]
splitsL Rectangle
rect (Tree (Int, Rational) -> [[(Int, Rectangle)]])
-> ([Rational] -> Tree (Int, Rational))
-> [Rational]
-> [[(Int, Rectangle)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Rational) -> Rational)
-> [(Int, Rational)] -> Tree (Int, Rational)
forall a1 a. (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree (Int, Rational) -> Rational
forall a b. (a, b) -> b
snd ([(Int, Rational)] -> Tree (Int, Rational))
-> ([Rational] -> [(Int, Rational)])
-> [Rational]
-> Tree (Int, Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Rational] -> [(Int, Rational)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
                ([Rational] -> [(Int, Rational)])
-> ([Rational] -> [Rational]) -> [Rational] -> [(Int, Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rational] -> [Rational]
forall a. Fractional a => [a] -> [a]
normalize ([Rational] -> [Rational])
-> ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rational] -> [Rational]
forall a. [a] -> [a]
reverse ([Rational] -> [Rational])
-> ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational) -> [Rational] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> Rational
forall a. Num a => a -> a
abs

splitsL :: Rectangle -> Tree (Int,Rational) -> [[(Int,Rectangle)]]
splitsL :: Rectangle -> Tree (Int, Rational) -> [[(Int, Rectangle)]]
splitsL Rectangle
_rect Tree (Int, Rational)
Empty = []
splitsL Rectangle
rect (Leaf (Int
x,Rational
_)) = [[(Int
x,Rectangle
rect)]]
splitsL Rectangle
rect (Branch Tree (Int, Rational)
l Tree (Int, Rational)
r) = do
    let mkSplit :: (Rational -> Rectangle -> t) -> t
mkSplit Rational -> Rectangle -> t
f = Rational -> Rectangle -> t
f ((Tree (Int, Rational) -> Rational
forall a. Tree (a, Rational) -> Rational
sumSnd Tree (Int, Rational)
l Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/) (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Tree (Int, Rational) -> Rational
forall a. Tree (a, Rational) -> Rational
sumSnd Tree (Int, Rational)
l Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Tree (Int, Rational) -> Rational
forall a. Tree (a, Rational) -> Rational
sumSnd Tree (Int, Rational)
r) Rectangle
rect
        sumSnd :: Tree (a, Rational) -> Rational
sumSnd = Tree Rational -> Rational
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Tree Rational -> Rational)
-> (Tree (a, Rational) -> Tree Rational)
-> Tree (a, Rational)
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Rational) -> Rational) -> Tree (a, Rational) -> Tree Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Rational) -> Rational
forall a b. (a, b) -> b
snd
    (Rectangle
rl,Rectangle
rr) <- ((Rational -> Rectangle -> (Rectangle, Rectangle))
 -> (Rectangle, Rectangle))
-> [Rational -> Rectangle -> (Rectangle, Rectangle)]
-> [(Rectangle, Rectangle)]
forall a b. (a -> b) -> [a] -> [b]
map (Rational -> Rectangle -> (Rectangle, Rectangle))
-> (Rectangle, Rectangle)
forall t. (Rational -> Rectangle -> t) -> t
mkSplit [Rational -> Rectangle -> (Rectangle, Rectangle)
forall r. RealFrac r => r -> Rectangle -> (Rectangle, Rectangle)
splitVerticallyBy,Rational -> Rectangle -> (Rectangle, Rectangle)
forall r. RealFrac r => r -> Rectangle -> (Rectangle, Rectangle)
splitHorizontallyBy]
    Rectangle -> Tree (Int, Rational) -> [[(Int, Rectangle)]]
splitsL Rectangle
rl Tree (Int, Rational)
l [[(Int, Rectangle)]]
-> [[(Int, Rectangle)]] -> [[(Int, Rectangle)]]
forall a. [[a]] -> [[a]] -> [[a]]
`interleave` Rectangle -> Tree (Int, Rational) -> [[(Int, Rectangle)]]
splitsL Rectangle
rr Tree (Int, Rational)
r

-- like zipWith (++), but when one list is shorter, its elements are duplicated
-- so that they match
interleave :: [[a]] -> [[a]] -> [[a]]
interleave :: [[a]] -> [[a]] -> [[a]]
interleave [[a]]
xs [[a]]
ys | Int
lx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ly = [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
zc [[a]]
xs (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
extend Int
lx [[a]]
ys)
                 | Bool
otherwise = [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
zc (Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
extend Int
ly [[a]]
xs) [[a]]
ys
  where lx :: Int
lx = [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
xs
        ly :: Int
ly = [[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
ys
        zc :: [[a]] -> [[a]] -> [[a]]
zc = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

        extend :: Int -> [a] -> [a]
        extend :: Int -> [a] -> [a]
extend Int
n [a]
pat = do
            (a
p,Bool
e) <- [a] -> [Bool] -> [(a, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
pat ([Bool] -> [(a, Bool)]) -> [Bool] -> [(a, Bool)]
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate Int
m Bool
True [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
            [a
p | Bool
e] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
d a
p
            where (Int
d,Int
m) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
pat

normalize :: Fractional a => [a] -> [a]
normalize :: [a] -> [a]
normalize [a]
x = let s :: a
s = [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
x in (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
forall a. Fractional a => a -> a -> a
/a
s) [a]
x

data Tree a = Branch (Tree a) (Tree a) | Leaf a | Empty

instance Foldable Tree where
   foldMap :: (a -> m) -> Tree a -> m
foldMap a -> m
_f Tree a
Empty = m
forall a. Monoid a => a
mempty
   foldMap a -> m
f (Leaf a
x) = a -> m
f a
x
   foldMap a -> m
f (Branch Tree a
l Tree a
r) = (a -> m) -> Tree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Tree a
l m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> Tree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Tree a
r

instance Functor Tree where
   fmap :: (a -> b) -> Tree a -> Tree b
fmap a -> b
f (Leaf a
x) = b -> Tree b
forall a. a -> Tree a
Leaf (b -> Tree b) -> b -> Tree b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
   fmap a -> b
f (Branch Tree a
l Tree a
r) = Tree b -> Tree b -> Tree b
forall a. Tree a -> Tree a -> Tree a
Branch ((a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Tree a
l) ((a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Tree a
r)
   fmap a -> b
_ Tree a
Empty = Tree b
forall a. Tree a
Empty

instance Monoid (Tree a) where
    mempty :: Tree a
mempty = Tree a
forall a. Tree a
Empty
    mappend :: Tree a -> Tree a -> Tree a
mappend Tree a
Empty Tree a
x = Tree a
x
    mappend Tree a
x Tree a
Empty = Tree a
x
    mappend Tree a
x Tree a
y = Tree a -> Tree a -> Tree a
forall a. Tree a -> Tree a -> Tree a
Branch Tree a
x Tree a
y

instance Semigroup (Tree a) where
    <> :: Tree a -> Tree a -> Tree a
(<>) = Tree a -> Tree a -> Tree a
forall a. Monoid a => a -> a -> a
mappend

makeTree ::  (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree :: (a -> a1) -> [a] -> Tree a
makeTree a -> a1
_ [] = Tree a
forall a. Tree a
Empty
makeTree a -> a1
_ [a
x] = a -> Tree a
forall a. a -> Tree a
Leaf a
x
makeTree a -> a1
f [a]
xs = Tree a -> Tree a -> Tree a
forall a. Tree a -> Tree a -> Tree a
Branch ((a -> a1) -> [a] -> Tree a
forall a1 a. (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree a -> a1
f [a]
a) ((a -> a1) -> [a] -> Tree a
forall a1 a. (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree a -> a1
f [a]
b)
    where (([a]
a,[a]
b),(a1, a1)
_) = (a -> (([a], [a]), (a1, a1)) -> (([a], [a]), (a1, a1)))
-> (([a], [a]), (a1, a1)) -> [a] -> (([a], [a]), (a1, a1))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (([a], [a]), (a1, a1)) -> (([a], [a]), (a1, a1))
go (([],[]),(a1
0,a1
0)) [a]
xs
          go :: a -> (([a], [a]), (a1, a1)) -> (([a], [a]), (a1, a1))
go a
n (([a]
ls,[a]
rs),(a1
l,a1
r))
            | a1
l a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
> a1
r     = (([a]
ls,a
na -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs),(a1
l,a -> a1
f a
na1 -> a1 -> a1
forall a. Num a => a -> a -> a
+a1
r))
            | Bool
otherwise = ((a
na -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ls,[a]
rs),(a -> a1
f a
na1 -> a1 -> a1
forall a. Num a => a -> a -> a
+a1
l,a1
r))