diff options
| -rw-r--r-- | XMonad/Config/Droundy.hs | 10 | ||||
| -rw-r--r-- | XMonad/Layout/Mosaic.hs | 487 | ||||
| -rw-r--r-- | XMonad/Util/Anneal.hs | 93 | ||||
| -rw-r--r-- | xmonad-contrib.cabal | 2 |
4 files changed, 0 insertions, 592 deletions
diff --git a/XMonad/Config/Droundy.hs b/XMonad/Config/Droundy.hs index 693306e..3429243 100644 --- a/XMonad/Config/Droundy.hs +++ b/XMonad/Config/Droundy.hs @@ -23,7 +23,6 @@ import System.Exit import XMonad.Layout.Tabbed import XMonad.Layout.Combo -import XMonad.Layout.Mosaic import XMonad.Layout.Named import XMonad.Layout.LayoutCombinators import XMonad.Layout.Simplest @@ -116,15 +115,6 @@ keys x = M.fromList $ , ((modMask x .|. controlMask .|. shiftMask, xK_space), 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)) - ] ++ diff --git a/XMonad/Layout/Mosaic.hs b/XMonad/Layout/Mosaic.hs deleted file mode 100644 index 25ea8be..0000000 --- a/XMonad/Layout/Mosaic.hs +++ /dev/null @@ -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) diff --git a/XMonad/Util/Anneal.hs b/XMonad/Util/Anneal.hs deleted file mode 100644 index 0d63ba3..0000000 --- a/XMonad/Util/Anneal.hs +++ /dev/null @@ -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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 9e4693c..285349f 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -127,7 +127,6 @@ library XMonad.Layout.MagicFocus XMonad.Layout.Magnifier XMonad.Layout.Maximize - -- XMonad.Layout.Mosaic XMonad.Layout.MosaicAlt XMonad.Layout.MultiToggle XMonad.Layout.Named @@ -166,7 +165,6 @@ library XMonad.Prompt.Window XMonad.Prompt.Workspace XMonad.Prompt.XMonad - XMonad.Util.Anneal XMonad.Util.CustomKeys XMonad.Util.Dmenu XMonad.Util.Dzen |