mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-08-03 13:41:53 -07:00
cut Anneal and Mosaic.
This commit is contained in:
@@ -23,7 +23,6 @@ import System.Exit
|
|||||||
|
|
||||||
import XMonad.Layout.Tabbed
|
import XMonad.Layout.Tabbed
|
||||||
import XMonad.Layout.Combo
|
import XMonad.Layout.Combo
|
||||||
import XMonad.Layout.Mosaic
|
|
||||||
import XMonad.Layout.Named
|
import XMonad.Layout.Named
|
||||||
import XMonad.Layout.LayoutCombinators
|
import XMonad.Layout.LayoutCombinators
|
||||||
import XMonad.Layout.Simplest
|
import XMonad.Layout.Simplest
|
||||||
@@ -116,15 +115,6 @@ keys x = M.fromList $
|
|||||||
, ((modMask x .|. controlMask .|. shiftMask, xK_space),
|
, ((modMask x .|. controlMask .|. shiftMask, xK_space),
|
||||||
toggleScratchWorkspace (Simplest */* Simplest) )
|
toggleScratchWorkspace (Simplest */* Simplest) )
|
||||||
|
|
||||||
-- keybindings for Mosaic:
|
|
||||||
, ((controlMask .|. modMask x .|. shiftMask, xK_h), withFocused (sendMessage . tallWindow))
|
|
||||||
, ((controlMask .|. modMask x .|. shiftMask, xK_l), withFocused (sendMessage . wideWindow))
|
|
||||||
, ((modMask x .|. shiftMask, xK_h ), withFocused (sendMessage . shrinkWindow))
|
|
||||||
, ((modMask x .|. shiftMask, xK_l ), withFocused (sendMessage . expandWindow))
|
|
||||||
, ((modMask x .|. shiftMask, xK_s ), withFocused (sendMessage . squareWindow))
|
|
||||||
, ((modMask x .|. shiftMask, xK_o ), withFocused (sendMessage . myclearWindow))
|
|
||||||
, ((controlMask .|. modMask x .|. shiftMask, xK_o ), withFocused (sendMessage . flexibleWindow))
|
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
++
|
++
|
||||||
|
@@ -1,487 +0,0 @@
|
|||||||
{-# OPTIONS -fglasgow-exts #-}
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : XMonadContrib.Mosaic
|
|
||||||
-- Copyright : (c) David Roundy <droundy@darcs.net>
|
|
||||||
-- License : BSD3-style (see LICENSE)
|
|
||||||
--
|
|
||||||
-- Maintainer : David Roundy <droundy@darcs.net>
|
|
||||||
-- Stability : unstable
|
|
||||||
-- Portability : unportable
|
|
||||||
--
|
|
||||||
-- This module defines a \"mosaic\" layout, which tries to give each window a
|
|
||||||
-- user-configurable relative area, while also trying to give them aspect
|
|
||||||
-- ratios configurable at run-time by the user.
|
|
||||||
--
|
|
||||||
-- Marked as broken, Mar 2008 (memory leaks)
|
|
||||||
--
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
module XMonad.Layout.Mosaic (
|
|
||||||
-- * Usage
|
|
||||||
-- $usage
|
|
||||||
mosaic, expandWindow, shrinkWindow, squareWindow, myclearWindow,
|
|
||||||
tallWindow, wideWindow, flexibleWindow,
|
|
||||||
getName ) where
|
|
||||||
|
|
||||||
import Control.Monad.State ( State, put, get, runState )
|
|
||||||
import System.Random ( StdGen, mkStdGen )
|
|
||||||
import Data.Maybe ( isJust )
|
|
||||||
|
|
||||||
import XMonad hiding ( trace )
|
|
||||||
import qualified XMonad.StackSet as W
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.List ( sort )
|
|
||||||
import Data.Typeable ( Typeable )
|
|
||||||
import Control.Monad ( mplus )
|
|
||||||
|
|
||||||
import XMonad.Util.NamedWindows
|
|
||||||
import XMonad.Util.Anneal
|
|
||||||
|
|
||||||
-- $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 0.25 0.5 ||| Full ||| etc..
|
|
||||||
-- > main = xmonad defaultConfig { layoutHook = myLayouts }
|
|
||||||
--
|
|
||||||
-- For more detailed instructions on editing the layoutHook see:
|
|
||||||
--
|
|
||||||
-- "XMonad.Doc.Extending#Editing_the_layout_hook"
|
|
||||||
--
|
|
||||||
-- In the key-bindings, do something like:
|
|
||||||
--
|
|
||||||
-- > , ((controlMask .|. modMask x .|. shiftMask, xK_h), withFocused (sendMessage . tallWindow))
|
|
||||||
-- > , ((controlMask .|. modMask x .|. shiftMask, xK_l), withFocused (sendMessage . wideWindow))
|
|
||||||
-- > , ((modMask x .|. shiftMask, xK_h ), withFocused (sendMessage . shrinkWindow))
|
|
||||||
-- > , ((modMask x .|. shiftMask, xK_l ), withFocused (sendMessage . expandWindow))
|
|
||||||
-- > , ((modMask x .|. shiftMask, xK_s ), withFocused (sendMessage . squareWindow))
|
|
||||||
-- > , ((modMask x .|. shiftMask, xK_o ), withFocused (sendMessage . myclearWindow))
|
|
||||||
-- > , ((controlMask .|. modMask x .|. shiftMask, xK_o ), withFocused (sendMessage . flexibleWindow))
|
|
||||||
--
|
|
||||||
-- For detailed instruction on editing the key binding see:
|
|
||||||
--
|
|
||||||
-- "XMonad.Doc.Extending#Editing_key_bindings".
|
|
||||||
|
|
||||||
data HandleWindow = ExpandWindow Window | ShrinkWindow Window
|
|
||||||
| SquareWindow Window | ClearWindow Window
|
|
||||||
| TallWindow Window | WideWindow Window
|
|
||||||
| FlexibleWindow Window
|
|
||||||
deriving ( Typeable, Eq )
|
|
||||||
|
|
||||||
instance Message HandleWindow
|
|
||||||
|
|
||||||
expandWindow, shrinkWindow, squareWindow, flexibleWindow, myclearWindow,tallWindow, wideWindow :: Window -> HandleWindow
|
|
||||||
expandWindow = ExpandWindow
|
|
||||||
shrinkWindow = ShrinkWindow
|
|
||||||
squareWindow = SquareWindow
|
|
||||||
flexibleWindow = FlexibleWindow
|
|
||||||
myclearWindow = ClearWindow
|
|
||||||
tallWindow = TallWindow
|
|
||||||
wideWindow = WideWindow
|
|
||||||
|
|
||||||
largeNumber :: Int
|
|
||||||
largeNumber = 50
|
|
||||||
|
|
||||||
defaultArea :: Double
|
|
||||||
defaultArea = 1
|
|
||||||
|
|
||||||
flexibility :: Double
|
|
||||||
flexibility = 0.1
|
|
||||||
|
|
||||||
mosaic :: Double -> Double -> MosaicLayout Window
|
|
||||||
mosaic d t = Mosaic d t M.empty
|
|
||||||
|
|
||||||
data MosaicLayout a = Mosaic Double Double (M.Map Window [WindowHint])
|
|
||||||
deriving ( Show, Read )
|
|
||||||
|
|
||||||
instance LayoutClass MosaicLayout Window where
|
|
||||||
doLayout (Mosaic _ t h) r st = do all_hints <- add_hints (W.integrate st) h
|
|
||||||
mosaicL t all_hints r (W.integrate st)
|
|
||||||
where add_hints [] x = return x
|
|
||||||
add_hints (w:ws) x =
|
|
||||||
do z <- withDisplay $ \d -> io $ getWMNormalHints d w
|
|
||||||
let set_asp = case map4 `fmap` sh_aspect z of
|
|
||||||
Just ((minx,miny),(maxx,maxy))
|
|
||||||
| or [minx < 1, miny < 1, maxx < 1, maxy < 1] -> id
|
|
||||||
| minx/miny == maxx/maxy -> set_aspect_ratio (minx/miny) w
|
|
||||||
_ -> id
|
|
||||||
add_hints ws $ set_MinX z w $ set_MinY z w $ set_MaxX z w $ set_MaxY z w $ set_asp x
|
|
||||||
map4 :: Integral a => ((a,a),(a,a)) -> ((Double,Double),(Double,Double))
|
|
||||||
map4 ((a,b),(c,d)) = ((fromIntegral a,fromIntegral b),(fromIntegral c,fromIntegral d))
|
|
||||||
|
|
||||||
pureMessage (Mosaic d t h) m = (m1 `fmap` fromMessage m) `mplus` (m2 `fmap` fromMessage m)
|
|
||||||
where
|
|
||||||
m1 Shrink = Mosaic d (t/(1+d)) h
|
|
||||||
m1 Expand = Mosaic d (t*(1+d)) h
|
|
||||||
m2 (ExpandWindow w) = Mosaic d t (multiply_area (1+d) w h)
|
|
||||||
m2 (ShrinkWindow w) = Mosaic d t (multiply_area (1/(1+ d)) w h)
|
|
||||||
m2 (SquareWindow w) = Mosaic d t (set_aspect_ratio 1 w h)
|
|
||||||
m2 (FlexibleWindow w) = Mosaic d t (make_flexible w h)
|
|
||||||
m2 (TallWindow w) = Mosaic d t (multiply_aspect (1/(1+d)) w h)
|
|
||||||
m2 (WideWindow w) = Mosaic d t (multiply_aspect (1+d) w h)
|
|
||||||
m2 (ClearWindow w) = Mosaic d t (M.delete w h)
|
|
||||||
|
|
||||||
description _ = "mosaic"
|
|
||||||
|
|
||||||
multiply_area :: Double -> Window
|
|
||||||
-> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
multiply_area a = alterlist f where f [] = [RelArea (defaultArea*a)]
|
|
||||||
f (RelArea a':xs) = RelArea (a'*a) : xs
|
|
||||||
f (x:xs) = x : f xs
|
|
||||||
|
|
||||||
set_aspect_ratio :: Double -> Window
|
|
||||||
-> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
set_aspect_ratio r = alterlist f where f [] = [AspectRatio r]
|
|
||||||
f (FlexibleAspectRatio _:x) = AspectRatio r:x
|
|
||||||
f (AspectRatio _:x) = AspectRatio r:x
|
|
||||||
f (x:xs) = x:f xs
|
|
||||||
|
|
||||||
make_flexible :: Window
|
|
||||||
-> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
make_flexible = alterlist (map f) where f (AspectRatio r) = FlexibleAspectRatio r
|
|
||||||
f (FlexibleAspectRatio r) = AspectRatio r
|
|
||||||
f x = x
|
|
||||||
|
|
||||||
multiply_aspect :: Double -> Window
|
|
||||||
-> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
multiply_aspect r = alterlist f where f [] = [FlexibleAspectRatio r]
|
|
||||||
f (AspectRatio r':x) = AspectRatio (r*r'):x
|
|
||||||
f (FlexibleAspectRatio r':x) = FlexibleAspectRatio (r*r'):x
|
|
||||||
f (x:xs) = x:f xs
|
|
||||||
|
|
||||||
set_MaxX :: SizeHints -> Window -> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
set_MaxX h | Just (_,mx) <- sh_max_size h = replaceinmap (isJust . isMaxX) (MaxX $ fromIntegral mx)
|
|
||||||
| otherwise = const id
|
|
||||||
|
|
||||||
set_MaxY :: SizeHints -> Window -> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
set_MaxY h | Just (_,mx) <- sh_max_size h = replaceinmap (isJust . isMaxY) (MaxY $ fromIntegral mx)
|
|
||||||
| otherwise = const id
|
|
||||||
|
|
||||||
isMaxX,isMaxY :: WindowHint -> Maybe Dimension
|
|
||||||
isMaxX (MaxX x) = Just x
|
|
||||||
isMaxX _ = Nothing
|
|
||||||
isMaxY (MaxY x) = Just x
|
|
||||||
isMaxY _ = Nothing
|
|
||||||
|
|
||||||
set_MinX :: SizeHints -> Window -> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
set_MinX h | Just (mx,_) <- sh_min_size h = replaceinmap isMinX (MinX $ fromIntegral mx)
|
|
||||||
| otherwise = const id
|
|
||||||
where isMinX (MinX _) = True
|
|
||||||
isMinX _ = False
|
|
||||||
|
|
||||||
set_MinY :: SizeHints -> Window -> M.Map Window [WindowHint] -> M.Map Window [WindowHint]
|
|
||||||
set_MinY h | Just (_,mx) <- sh_min_size h = replaceinmap isMinY (MinY $ fromIntegral mx)
|
|
||||||
| otherwise = const id
|
|
||||||
where isMinY (MinY _) = True
|
|
||||||
isMinY _ = False
|
|
||||||
|
|
||||||
replaceinmap :: Ord a => (a -> Bool) -> a -> Window -> M.Map Window [a] -> M.Map Window [a]
|
|
||||||
replaceinmap repl v = alterlist f where f [] = [v]
|
|
||||||
f (x:xs) | repl x = v:xs
|
|
||||||
| otherwise = x:f xs
|
|
||||||
|
|
||||||
findlist :: Window -> M.Map Window [a] -> [a]
|
|
||||||
findlist = M.findWithDefault []
|
|
||||||
|
|
||||||
alterlist :: (Ord a) => ([a] -> [a]) -> Window -> M.Map Window [a] -> M.Map Window [a]
|
|
||||||
alterlist f k = M.alter f' k
|
|
||||||
where f' Nothing = f' (Just [])
|
|
||||||
f' (Just xs) = case f xs of
|
|
||||||
[] -> Nothing
|
|
||||||
xs' -> Just xs'
|
|
||||||
|
|
||||||
mosaicL :: Double -> M.Map Window [WindowHint]
|
|
||||||
-> Rectangle -> [Window] -> X ([(Window, Rectangle)],Maybe (MosaicLayout Window))
|
|
||||||
mosaicL _ _ _ [] = return ([], Nothing)
|
|
||||||
mosaicL f hints origRect origws
|
|
||||||
= do let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) origws
|
|
||||||
-- TODO: remove all this dead code
|
|
||||||
myv = runCountDown largeNumber $ mosaic_splits even_split origRect Vertical sortedws
|
|
||||||
myv2 = mc_mosaic sortedws Vertical
|
|
||||||
myh2 = mc_mosaic sortedws Horizontal
|
|
||||||
-- myv2 = maxL $ runCountDown largeNumber $
|
|
||||||
-- sequence $ replicate mediumNumber $
|
|
||||||
-- mosaic_splits one_split origRect Vertical sortedws
|
|
||||||
myh = runCountDown largeNumber $ mosaic_splits even_split origRect Horizontal sortedws
|
|
||||||
-- myh2 = maxL $ runCountDown largeNumber $
|
|
||||||
-- sequence $ replicate mediumNumber $
|
|
||||||
-- mosaic_splits one_split origRect Horizontal sortedws
|
|
||||||
return (map (\(w,r)->(--trace ("rate1:"++ unlines [show nw,
|
|
||||||
-- show $ rate f meanarea (findlist nw hints) r,
|
|
||||||
-- show r,
|
|
||||||
-- show $ area r/meanarea,
|
|
||||||
-- show $ findlist nw hints]) $
|
|
||||||
w,crop' (findlist w hints) r)) $
|
|
||||||
flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2], Nothing)
|
|
||||||
where mosaic_splits _ _ _ [] = return $ Rated 0 $ M []
|
|
||||||
mosaic_splits _ r _ [w] = return $ Rated (rate f meanarea (findlist w hints) r) $ OM (w,r)
|
|
||||||
mosaic_splits spl r d ws = maxL `fmap` mapCD (spl r d) (init $ allsplits ws)
|
|
||||||
even_split :: Rectangle -> CutDirection -> [[Window]]
|
|
||||||
-> State CountDown (Rated Double (Mosaic (Window, Rectangle)))
|
|
||||||
even_split r d [ws] = even_split r d $ map (:[]) ws
|
|
||||||
even_split r d wss =
|
|
||||||
do let areas = map sumareas wss
|
|
||||||
maxds = map (maxd d) wss
|
|
||||||
let wsr_s :: [([Window], Rectangle)]
|
|
||||||
wsr_s = zip wss (partitionR d r maxds areas)
|
|
||||||
submosaics <- mapM (\(ws',r') ->
|
|
||||||
mosaic_splits even_split r' (otherDirection d) ws') wsr_s
|
|
||||||
return $ fmap M $ catRated submosaics
|
|
||||||
{-
|
|
||||||
another_mosaic :: [Window] -> CutDirection
|
|
||||||
-> Rated Double (Mosaic (Window,Rectangle))
|
|
||||||
another_mosaic ws d = rate_mosaic ratew $
|
|
||||||
rect_mosaic origRect d $
|
|
||||||
zipML (example_mosaic ws) (map findarea ws)
|
|
||||||
-}
|
|
||||||
mc_mosaic :: [Window] -> CutDirection
|
|
||||||
-> Rated Double (Mosaic (Window,Rectangle))
|
|
||||||
mc_mosaic ws d = fmap (rect_mosaic origRect d) $
|
|
||||||
annealMax (zipML (example_mosaic ws) (map findarea ws))
|
|
||||||
(the_rating . rate_mosaic ratew . rect_mosaic origRect d )
|
|
||||||
changeMosaic
|
|
||||||
|
|
||||||
ratew :: (Window,Rectangle) -> Double
|
|
||||||
ratew (w,r) = rate f meanarea (findlist w hints) r
|
|
||||||
example_mosaic :: [Window] -> Mosaic Window
|
|
||||||
example_mosaic ws = M (map OM ws)
|
|
||||||
rect_mosaic :: Rectangle -> CutDirection -> Mosaic (a,Double) -> Mosaic (a,Rectangle)
|
|
||||||
rect_mosaic r _ (OM (w,_)) = OM (w,r)
|
|
||||||
rect_mosaic r d (M ws) = M $ zipWith (\w' r' -> rect_mosaic r' d' w') ws rs
|
|
||||||
where areas = map (sum . map snd . flattenMosaic) ws
|
|
||||||
maxds = repeat 1
|
|
||||||
rs = partitionR d r maxds areas
|
|
||||||
d' = otherDirection d
|
|
||||||
rate_mosaic :: ((Window,Rectangle) -> Double)
|
|
||||||
-> Mosaic (Window,Rectangle) -> Rated Double (Mosaic (Window,Rectangle))
|
|
||||||
rate_mosaic r m = catRatedM $ fmap (\x -> Rated (r x) x) m
|
|
||||||
{-
|
|
||||||
one_split :: Rectangle -> CutDirection -> [[Window]]
|
|
||||||
-> State CountDown (Rated Double (Mosaic (Window, Rectangle)))
|
|
||||||
one_split r d [ws] = one_split r d $ map (:[]) ws
|
|
||||||
one_split r d wss =
|
|
||||||
do rnd <- mapM (const (fractional resolutionNumber)) [1..length wss]
|
|
||||||
let wsr_s :: [([Window], Rectangle)]
|
|
||||||
wsr_s = zip wss (partitionR d r rnd)
|
|
||||||
submosaics <- mapM (\(ws',r') ->
|
|
||||||
mosaic_splits even_split r' (otherDirection d) ws') wsr_s
|
|
||||||
return $ fmap M $ catRated submosaics
|
|
||||||
-}
|
|
||||||
partitionR :: CutDirection -> Rectangle -> [Dimension] -> [Double] -> [Rectangle]
|
|
||||||
partitionR _ _ _ [] = []
|
|
||||||
partitionR _ _ [] _ = []
|
|
||||||
partitionR _ r _ [_] = [r]
|
|
||||||
partitionR d r (m:ms) (a:ars) = r1 : partitionR d r2 ms ars
|
|
||||||
where totarea = sum (a:ars)
|
|
||||||
totd = fromIntegral $ dimR d r
|
|
||||||
(r1,r2) = if a/totarea > fromIntegral m / totd
|
|
||||||
then if a/totarea > 1 - fromIntegral (sum ms) / totd
|
|
||||||
then split d (1 - fromIntegral (sum ms) / totd) r
|
|
||||||
else split d (a/totarea) r
|
|
||||||
else split d (fromIntegral m / totd) r
|
|
||||||
theareas = hints2area `fmap` hints
|
|
||||||
sumareas ws = sum $ map findarea ws
|
|
||||||
maxd Vertical ws = maximum $ map (findhinted isMaxY 3) ws
|
|
||||||
maxd Horizontal ws = maximum $ map (findhinted isMaxX 3) ws
|
|
||||||
findarea :: Window -> Double
|
|
||||||
findarea w = M.findWithDefault 1 w theareas
|
|
||||||
findhinted fh d w = fh' $ M.findWithDefault [] w hints
|
|
||||||
where fh' [] = d
|
|
||||||
fh' (h:hs) | Just x <- fh h = x
|
|
||||||
| otherwise = fh' hs
|
|
||||||
meanarea = area origRect / fromIntegral (length origws)
|
|
||||||
|
|
||||||
dimR :: CutDirection -> Rectangle -> Dimension
|
|
||||||
dimR Vertical (Rectangle _ _ _ h) = h
|
|
||||||
dimR Horizontal (Rectangle _ _ w _) = w
|
|
||||||
|
|
||||||
maxL :: Ord a => [a] -> a
|
|
||||||
maxL [] = error "maxL on empty list"
|
|
||||||
maxL [a] = a
|
|
||||||
maxL (a:b:c) = maxL (max a b:c)
|
|
||||||
|
|
||||||
catRated :: Floating v => [Rated v a] -> Rated v [a]
|
|
||||||
catRated xs = Rated (product $ map the_rating xs) (map the_value xs)
|
|
||||||
|
|
||||||
catRatedM :: Floating v => Mosaic (Rated v a) -> Rated v (Mosaic a)
|
|
||||||
catRatedM (OM (Rated v x)) = Rated v (OM x)
|
|
||||||
catRatedM (M xs) = case catRated $ map catRatedM xs of Rated v xs' -> Rated v (M xs')
|
|
||||||
|
|
||||||
data CountDown = CD !StdGen !Int
|
|
||||||
|
|
||||||
tries_left :: State CountDown Int
|
|
||||||
tries_left = do CD _ n <- get
|
|
||||||
return (max 0 n)
|
|
||||||
|
|
||||||
mapCD :: (a -> State CountDown b) -> [a] -> State CountDown [b]
|
|
||||||
mapCD f xs = do n <- tries_left
|
|
||||||
let len = length xs
|
|
||||||
mapM (run_with_only ((n `div` len)+1) . f) $ take (n+1) xs
|
|
||||||
|
|
||||||
run_with_only :: Int -> State CountDown a -> State CountDown a
|
|
||||||
run_with_only limit j =
|
|
||||||
do CD g n <- get
|
|
||||||
let leftover = n - limit
|
|
||||||
if leftover < 0 then j
|
|
||||||
else do put $ CD g limit
|
|
||||||
x <- j
|
|
||||||
CD g' n' <- get
|
|
||||||
put $ CD g' (leftover + n')
|
|
||||||
return x
|
|
||||||
|
|
||||||
data WindowHint = RelArea Double
|
|
||||||
| MaxX Dimension
|
|
||||||
| MaxY Dimension
|
|
||||||
| MinX Dimension
|
|
||||||
| MinY Dimension
|
|
||||||
| AspectRatio Double
|
|
||||||
| FlexibleAspectRatio Double
|
|
||||||
deriving ( Show, Read, Eq, Ord )
|
|
||||||
|
|
||||||
fixedAspect :: [WindowHint] -> Bool
|
|
||||||
fixedAspect [] = False
|
|
||||||
fixedAspect (AspectRatio _:_) = True
|
|
||||||
fixedAspect (_:x) = fixedAspect x
|
|
||||||
|
|
||||||
rate :: Double -> Double -> [WindowHint] -> Rectangle -> Double
|
|
||||||
rate defaulta meanarea xs rr
|
|
||||||
| fixedAspect xs = (area (crop xs rr) / meanarea) ** weight
|
|
||||||
| otherwise = (area rr / meanarea)**(weight-flexibility)
|
|
||||||
* (area (crop (xs++[FlexibleAspectRatio defaulta]) rr) / meanarea)**flexibility
|
|
||||||
where weight = hints2area xs
|
|
||||||
|
|
||||||
crop1 :: WindowHint -> Rectangle -> Rectangle
|
|
||||||
crop1 (FlexibleAspectRatio f) r = cropit f r
|
|
||||||
crop1 h r = crop1' h r
|
|
||||||
|
|
||||||
crop1' :: WindowHint -> Rectangle -> Rectangle
|
|
||||||
crop1' (AspectRatio f) r = cropit f r
|
|
||||||
crop1' (FlexibleAspectRatio f) r = cropit f r
|
|
||||||
crop1' (MaxX xm) (Rectangle x y w h) | w > xm = Rectangle x y xm h
|
|
||||||
| otherwise = Rectangle x y w h
|
|
||||||
crop1' (MaxY xm) (Rectangle x y w h) | h > xm = Rectangle x y w xm
|
|
||||||
| otherwise = Rectangle x y w h
|
|
||||||
crop1' _ r = r
|
|
||||||
|
|
||||||
crop :: [WindowHint] -> Rectangle -> Rectangle
|
|
||||||
crop (h:hs) = crop hs . crop1 h
|
|
||||||
crop [] = id
|
|
||||||
|
|
||||||
crop' :: [WindowHint] -> Rectangle -> Rectangle
|
|
||||||
crop' (h:hs) = crop' hs . crop1' h
|
|
||||||
crop' [] = id
|
|
||||||
|
|
||||||
cropit :: Double -> Rectangle -> Rectangle
|
|
||||||
cropit f (Rectangle a b w h) | w -/- h > f = Rectangle a b (ceiling $ h -* f) h
|
|
||||||
| otherwise = Rectangle a b w (ceiling $ w -/ f)
|
|
||||||
|
|
||||||
hints2area :: [WindowHint] -> Double
|
|
||||||
hints2area [] = defaultArea
|
|
||||||
hints2area (RelArea r:_) = r
|
|
||||||
hints2area (_:x) = hints2area x
|
|
||||||
|
|
||||||
area :: Rectangle -> Double
|
|
||||||
area (Rectangle _ _ w h) = fromIntegral w * fromIntegral h
|
|
||||||
|
|
||||||
(-/-) :: (Integral a, Integral b) => a -> b -> Double
|
|
||||||
a -/- b = fromIntegral a / fromIntegral b
|
|
||||||
|
|
||||||
(-/) :: (Integral a) => a -> Double -> Double
|
|
||||||
a -/ b = fromIntegral a / b
|
|
||||||
|
|
||||||
(-*) :: (Integral a) => a -> Double -> Double
|
|
||||||
a -* b = fromIntegral a * b
|
|
||||||
|
|
||||||
split :: CutDirection -> Double -> Rectangle -> (Rectangle, Rectangle)
|
|
||||||
split d frac r | frac <= 0 || frac >= 1 = split d 0.5 r
|
|
||||||
split Vertical frac (Rectangle sx sy sw sh) = (Rectangle sx sy sw h,
|
|
||||||
Rectangle sx (sy+fromIntegral h) sw (sh-h))
|
|
||||||
where h = floor $ fromIntegral sh * frac
|
|
||||||
split Horizontal frac (Rectangle sx sy sw sh) = (Rectangle sx sy w sh,
|
|
||||||
Rectangle (sx+fromIntegral w) sy (sw-w) sh)
|
|
||||||
where w = floor $ fromIntegral sw * frac
|
|
||||||
|
|
||||||
data CutDirection = Vertical | Horizontal
|
|
||||||
otherDirection :: CutDirection -> CutDirection
|
|
||||||
otherDirection Vertical = Horizontal
|
|
||||||
otherDirection Horizontal = Vertical
|
|
||||||
|
|
||||||
data Mosaic a = M [Mosaic a] | OM a
|
|
||||||
deriving ( Show )
|
|
||||||
|
|
||||||
instance Functor Mosaic where
|
|
||||||
fmap f (OM x) = OM (f x)
|
|
||||||
fmap f (M xs) = M (map (fmap f) xs)
|
|
||||||
|
|
||||||
zipMLwith :: (a -> b -> c) -> Mosaic a -> [b] -> Mosaic c
|
|
||||||
zipMLwith f (OM x) (y:_) = OM (f x y)
|
|
||||||
zipMLwith _ (OM _) [] = error "bad zipMLwith"
|
|
||||||
zipMLwith f (M xxs) yys = makeM $ foo xxs yys
|
|
||||||
where foo (x:xs) ys = zipMLwith f x (take (lengthM x) ys) :
|
|
||||||
foo xs (drop (lengthM x) ys)
|
|
||||||
foo [] _ = []
|
|
||||||
|
|
||||||
zipML :: Mosaic a -> [b] -> Mosaic (a,b)
|
|
||||||
zipML = zipMLwith (\a b -> (a,b))
|
|
||||||
|
|
||||||
lengthM :: Mosaic a -> Int
|
|
||||||
lengthM (OM _) = 1
|
|
||||||
lengthM (M x) = sum $ map lengthM x
|
|
||||||
|
|
||||||
changeMosaic :: Mosaic a -> [Mosaic a]
|
|
||||||
changeMosaic (OM _) = []
|
|
||||||
changeMosaic (M xs) = map makeM (concatenations xs) ++
|
|
||||||
map makeM (splits xs) ++
|
|
||||||
map M (tryAll changeMosaic xs)
|
|
||||||
|
|
||||||
tryAll :: (a -> [a]) -> [a] -> [[a]]
|
|
||||||
tryAll _ [] = []
|
|
||||||
tryAll f (x:xs) = map (:xs) (f x) ++ map (x:) (tryAll f xs)
|
|
||||||
|
|
||||||
splits :: [Mosaic a] -> [[Mosaic a]]
|
|
||||||
splits [] = []
|
|
||||||
splits (OM x:y) = map (OM x:) $ splits y
|
|
||||||
splits (M (x:y):z) = (x:makeM y:z) : map (makeM (x:y) :) (splits z)
|
|
||||||
splits (M []:x) = splits x
|
|
||||||
|
|
||||||
concatenations :: [Mosaic a] -> [[Mosaic a]]
|
|
||||||
concatenations (x:y:z) = (concatenateMosaic x y:z):(map (x:) $ concatenations (y:z))
|
|
||||||
concatenations _ = []
|
|
||||||
|
|
||||||
concatenateMosaic :: Mosaic a -> Mosaic a -> Mosaic a
|
|
||||||
concatenateMosaic (OM a) (OM b) = M [OM a, OM b]
|
|
||||||
concatenateMosaic (OM a) (M b) = M (OM a:b)
|
|
||||||
concatenateMosaic (M a) (OM b) = M (a++[OM b])
|
|
||||||
concatenateMosaic (M a) (M b) = M (a++b)
|
|
||||||
|
|
||||||
makeM :: [Mosaic a] -> Mosaic a
|
|
||||||
makeM [m] = m
|
|
||||||
makeM [] = error "makeM []"
|
|
||||||
makeM ms = M ms
|
|
||||||
|
|
||||||
flattenMosaic :: Mosaic a -> [a]
|
|
||||||
flattenMosaic (OM a) = [a]
|
|
||||||
flattenMosaic (M xs) = concatMap flattenMosaic xs
|
|
||||||
|
|
||||||
allsplits :: [a] -> [[[a]]]
|
|
||||||
allsplits [] = [[[]]]
|
|
||||||
allsplits [a] = [[[a]]]
|
|
||||||
allsplits (x:xs) = (map ([x]:) splitsrest) ++ (map (maphead (x:)) splitsrest)
|
|
||||||
where splitsrest = allsplits' xs
|
|
||||||
|
|
||||||
allsplits' :: [a] -> [[[a]]]
|
|
||||||
allsplits' [] = [[[]]]
|
|
||||||
allsplits' [a] = [[[a]]]
|
|
||||||
allsplits' (x:xs) = (map (maphead (x:)) splitsrest) ++ (map ([x]:) splitsrest)
|
|
||||||
where splitsrest = allsplits xs
|
|
||||||
|
|
||||||
maphead :: (a->a) -> [a] -> [a]
|
|
||||||
maphead f (x:xs) = f x : xs
|
|
||||||
maphead _ [] = []
|
|
||||||
|
|
||||||
runCountDown :: Int -> State CountDown a -> a
|
|
||||||
runCountDown n x = fst $ runState x (CD (mkStdGen n) n)
|
|
@@ -1,93 +0,0 @@
|
|||||||
-----------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : XMonad.Util.Anneal
|
|
||||||
-- Copyright : (c) David Roundy
|
|
||||||
-- License : BSD-style (see LICENSE)
|
|
||||||
--
|
|
||||||
-- Maintainer : David Roundy <droundy@darcs.org>
|
|
||||||
-- Stability : unstable
|
|
||||||
-- Portability : unportable
|
|
||||||
--
|
|
||||||
-- Requires the 'random' package
|
|
||||||
--
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
|
|
||||||
module XMonad.Util.Anneal (-- * Usage
|
|
||||||
-- $usage
|
|
||||||
Rated(Rated), the_value, the_rating
|
|
||||||
, anneal, annealMax ) where
|
|
||||||
|
|
||||||
import System.Random ( StdGen, Random, mkStdGen, randomR )
|
|
||||||
import Control.Monad.State ( State, runState, put, get, gets, modify )
|
|
||||||
|
|
||||||
-- $usage
|
|
||||||
-- See "XMonad.Layout.Mosaic" for an usage example.
|
|
||||||
|
|
||||||
data Rated a b = Rated !a !b
|
|
||||||
deriving ( Show )
|
|
||||||
instance Functor (Rated a) where
|
|
||||||
f `fmap` (Rated v a) = Rated v (f a)
|
|
||||||
|
|
||||||
the_value :: Rated a b -> b
|
|
||||||
the_value (Rated _ b) = b
|
|
||||||
the_rating :: Rated a b -> a
|
|
||||||
the_rating (Rated a _) = a
|
|
||||||
|
|
||||||
instance Eq a => Eq (Rated a b) where
|
|
||||||
(Rated a _) == (Rated a' _) = a == a'
|
|
||||||
instance Ord a => Ord (Rated a b) where
|
|
||||||
compare (Rated a _) (Rated a' _) = compare a a'
|
|
||||||
|
|
||||||
anneal :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a
|
|
||||||
anneal st r sel = runAnneal st r (do_anneal sel)
|
|
||||||
|
|
||||||
annealMax :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a
|
|
||||||
annealMax st r sel = runAnneal st (negate . r) (do_anneal sel)
|
|
||||||
|
|
||||||
do_anneal :: (a -> [a]) -> State (Anneal a) (Rated Double a)
|
|
||||||
do_anneal sel = do sequence_ $ replicate 100 da
|
|
||||||
gets best
|
|
||||||
where da = do select_metropolis sel
|
|
||||||
modify $ \s -> s { temperature = temperature s *0.99 }
|
|
||||||
|
|
||||||
data Anneal a = A { g :: StdGen
|
|
||||||
, best :: Rated Double a
|
|
||||||
, current :: Rated Double a
|
|
||||||
, rate :: a -> Rated Double a
|
|
||||||
, temperature :: Double }
|
|
||||||
|
|
||||||
runAnneal :: a -> (a -> Double) -> State (Anneal a) b -> b
|
|
||||||
runAnneal start r x = fst $ runState x (A { g = mkStdGen 137
|
|
||||||
, best = Rated (r start) start
|
|
||||||
, current = Rated (r start) start
|
|
||||||
, rate = \xx -> Rated (r xx) xx
|
|
||||||
, temperature = 1.0 })
|
|
||||||
|
|
||||||
select_metropolis :: (a -> [a]) -> State (Anneal a) ()
|
|
||||||
select_metropolis x = do c <- gets current
|
|
||||||
a <- select $ x $ the_value c
|
|
||||||
metropolis a
|
|
||||||
|
|
||||||
metropolis :: a -> State (Anneal a) ()
|
|
||||||
metropolis x = do r <- gets rate
|
|
||||||
c <- gets current
|
|
||||||
t <- gets temperature
|
|
||||||
let rx = r x
|
|
||||||
boltz = exp $ (the_rating c - the_rating rx) / t
|
|
||||||
if rx < c then do modify $ \s -> s { current = rx, best = rx }
|
|
||||||
else do p <- getOne (0,1)
|
|
||||||
if p < boltz
|
|
||||||
then modify $ \s -> s { current = rx }
|
|
||||||
else return ()
|
|
||||||
|
|
||||||
select :: [a] -> State (Anneal a) a
|
|
||||||
select [] = the_value `fmap` gets best
|
|
||||||
select [x] = return x
|
|
||||||
select xs = do n <- getOne (0,length xs - 1)
|
|
||||||
return (xs !! n)
|
|
||||||
|
|
||||||
getOne :: (Random a) => (a,a) -> State (Anneal x) a
|
|
||||||
getOne bounds = do s <- get
|
|
||||||
(x,g') <- return $ randomR bounds (g s)
|
|
||||||
put $ s { g = g' }
|
|
||||||
return x
|
|
@@ -127,7 +127,6 @@ library
|
|||||||
XMonad.Layout.MagicFocus
|
XMonad.Layout.MagicFocus
|
||||||
XMonad.Layout.Magnifier
|
XMonad.Layout.Magnifier
|
||||||
XMonad.Layout.Maximize
|
XMonad.Layout.Maximize
|
||||||
-- XMonad.Layout.Mosaic
|
|
||||||
XMonad.Layout.MosaicAlt
|
XMonad.Layout.MosaicAlt
|
||||||
XMonad.Layout.MultiToggle
|
XMonad.Layout.MultiToggle
|
||||||
XMonad.Layout.Named
|
XMonad.Layout.Named
|
||||||
@@ -166,7 +165,6 @@ library
|
|||||||
XMonad.Prompt.Window
|
XMonad.Prompt.Window
|
||||||
XMonad.Prompt.Workspace
|
XMonad.Prompt.Workspace
|
||||||
XMonad.Prompt.XMonad
|
XMonad.Prompt.XMonad
|
||||||
XMonad.Util.Anneal
|
|
||||||
XMonad.Util.CustomKeys
|
XMonad.Util.CustomKeys
|
||||||
XMonad.Util.Dmenu
|
XMonad.Util.Dmenu
|
||||||
XMonad.Util.Dzen
|
XMonad.Util.Dzen
|
||||||
|
Reference in New Issue
Block a user