From ae03454010d00345f77565b4f3d76e65045c16b5 Mon Sep 17 00:00:00 2001 From: David Roundy Date: Sun, 27 May 2007 21:11:53 +0200 Subject: new layout algorithm for Mosaic. darcs-hash:20070527191153-72aca-0ac95cbf4b53e4f307499f74e1ab73ef04ef1370.gz --- Anneal.hs | 19 ++++ Mosaic.hs | 308 ++++++++++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 229 insertions(+), 98 deletions(-) create mode 100644 Anneal.hs diff --git a/Anneal.hs b/Anneal.hs new file mode 100644 index 0000000..5083030 --- /dev/null +++ b/Anneal.hs @@ -0,0 +1,19 @@ +module XMonadContrib.Anneal ( Rated(Rated), the_value, the_rating, anneal ) where + +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 = undefined diff --git a/Mosaic.hs b/Mosaic.hs index 8b8411c..b07b331 100644 --- a/Mosaic.hs +++ b/Mosaic.hs @@ -1,4 +1,5 @@ module XMonadContrib.Mosaic ( mosaic, expandWindow, shrinkWindow, squareWindow, myclearWindow, + tallWindow, wideWindow, getName, withNamedWindow ) where -- This module defines a "mosaic" layout, which tries to give all windows @@ -21,14 +22,19 @@ module XMonadContrib.Mosaic ( mosaic, expandWindow, shrinkWindow, squareWindow, -- In the key-bindings, do something like: +-- , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow)) +-- , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow)) -- , ((modMask .|. shiftMask, xK_h ), withNamedWindow (sendMessage . shrinkWindow)) -- , ((modMask .|. shiftMask, xK_l ), withNamedWindow (sendMessage . expandWindow)) -- , ((modMask .|. shiftMask, xK_s ), withNamedWindow (sendMessage . squareWindow)) --- , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . clearWindow)) +-- , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . myclearWindow)) + +import Control.Monad.State ( State, runState, put, get ) +import System.Random ( StdGen, Random, mkStdGen, randomR ) import Data.Ratio import Graphics.X11.Xlib -import XMonad +import XMonad hiding ( trace ) import Operations ( Resize(Shrink, Expand) ) import qualified Data.Map as M import Data.List ( sort ) @@ -36,127 +42,227 @@ import Data.Typeable ( Typeable ) import Control.Monad ( mplus ) import XMonadContrib.NamedWindows +import XMonadContrib.Anneal -import System.IO.Unsafe +import Debug.Trace data HandleWindow = ExpandWindow NamedWindow | ShrinkWindow NamedWindow | SquareWindow NamedWindow | ClearWindow NamedWindow + | TallWindow NamedWindow | WideWindow NamedWindow deriving ( Typeable, Eq ) instance Message HandleWindow -expandWindow, shrinkWindow, squareWindow, myclearWindow :: NamedWindow -> HandleWindow +expandWindow, shrinkWindow, squareWindow, myclearWindow,tallWindow, wideWindow :: NamedWindow -> HandleWindow expandWindow = ExpandWindow shrinkWindow = ShrinkWindow squareWindow = SquareWindow myclearWindow = ClearWindow +tallWindow = TallWindow +wideWindow = WideWindow + +largeNumber, mediumNumber, resolutionNumber :: Int +largeNumber = 200 +mediumNumber = 10 +resolutionNumber = 100 -largeNumber :: Int -largeNumber = 100 +defaultArea :: Double +defaultArea = 1 -mosaic :: Rational -> Rational -> M.Map NamedWindow WindowRater -> M.Map NamedWindow Area -> Layout -mosaic delta tileFrac raters areas = Layout { doLayout = mosaicL tileFrac raters areas - , modifyLayout = mlayout } +flexibility :: Double +flexibility = 0.1 + +mosaic :: Double -> Double -> M.Map NamedWindow [WindowHint] -> Layout +mosaic delta tileFrac hints = Layout { doLayout = mosaicL tileFrac hints, modifyLayout = mlayout } where mlayout x = (m1 `fmap` fromMessage x) `mplus` (m2 `fmap` fromMessage x) - m1 Shrink = mosaic delta (tileFrac/(1+delta)) raters areas - m1 Expand = mosaic delta (tileFrac*(1+delta)) raters areas - m2 (ExpandWindow w) = mosaic delta tileFrac raters - -- (add_rater (\_ (Rectangle _ _ wid h) -> delta*(1-wid///h)) w raters) - (multiply_area (1+delta) w areas) - m2 (ShrinkWindow w) = mosaic delta tileFrac raters - -- (add_rater (\_ (Rectangle _ _ wid h) -> delta*(wid///h-1)) w raters) - (multiply_area (1/(1+ delta)) w areas) - m2 (SquareWindow w) = mosaic delta tileFrac (M.insert w force_square raters) areas - m2 (ClearWindow w) = mosaic delta tileFrac (M.delete w raters) (M.delete w areas) - force_square _ (Rectangle _ _ a b) = 100*(sqr(a///b) + sqr(b///a)) - sqr a = a * a - -mytrace :: String -> a -> a -mytrace s a = seq foo a - where foo = unsafePerformIO $ appendFile "/tmp/xmonad.trace" (s++"\n") - -myerror :: String -> a -myerror s = seq foo $ error s - where foo = unsafePerformIO $ appendFile "/tmp/xmonad.trace" (s++"\n") - -multiply_area :: Area -> NamedWindow -> M.Map NamedWindow Area -> M.Map NamedWindow Area -multiply_area a w = M.alter (Just . f) w where f Nothing = a - f (Just a') = a'*a - -add_rater :: WindowRater -> NamedWindow -> M.Map NamedWindow WindowRater -> M.Map NamedWindow WindowRater -add_rater r w = M.alter f w where f Nothing= Just r - f (Just r') = Just $ \foo bar -> r foo bar + r' foo bar - -type WindowRater = NamedWindow -> Rectangle -> Rational - -mosaicL :: Rational -> M.Map NamedWindow WindowRater -> M.Map NamedWindow Area + m1 Shrink = mosaic delta (tileFrac/(1+delta)) hints + m1 Expand = mosaic delta (tileFrac*(1+delta)) hints + m2 (ExpandWindow w) = mosaic delta tileFrac (multiply_area (1+delta) w hints) + m2 (ShrinkWindow w) = mosaic delta tileFrac (multiply_area (1/(1+ delta)) w hints) + m2 (SquareWindow w) = mosaic delta tileFrac (set_aspect_ratio 1 w hints) + m2 (TallWindow w) = mosaic delta tileFrac (multiply_aspect (1/(1+delta)) w hints) + m2 (WideWindow w) = mosaic delta tileFrac (multiply_aspect (1+delta) w hints) + m2 (ClearWindow w) = mosaic delta tileFrac (M.delete w hints) + +multiply_area :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [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 -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [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 + +multiply_aspect :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [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 + +findlist :: Ord k => k -> M.Map k [a] -> [a] +findlist = M.findWithDefault [] + +alterlist :: (Ord k, Ord a) => ([a] -> [a]) -> k -> M.Map k [a] -> M.Map k [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 NamedWindow [WindowHint] -> Rectangle -> [Window] -> X [(Window, Rectangle)] -mosaicL _ _ _ _ [] = return [] -mosaicL f raters areas origRect origws +mosaicL _ _ _ [] = return [] +mosaicL f hints origRect origws = do namedws <- mapM getName origws let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) namedws - myv = my_mosaic origRect Vertical sortedws - myh = my_mosaic origRect Horizontal sortedws - return $ map (\(nw,r)->(unName nw,r)) $ flattenMosaic $ the_value $ if myv < myh then myv else myh - where mean_area = area origRect / fromIntegral (length origws) - - my_mosaic :: Rectangle -> CutDirection -> [NamedWindow] - -> Rated Rational (Mosaic (NamedWindow, Rectangle)) - my_mosaic _ _ [] = Rated 0 $ M [] - my_mosaic r _ [w] = Rated (rating w r) $ OM (w,r) - my_mosaic r d ws = minL $ - map (fmap M . catRated . - map (\(ws',r') -> my_mosaic r' (otherDirection d) ws')) $ - map (\ws' -> zip ws' $ partitionR d r $ map sumareas ws') $ - take largeNumber $ init $ allsplits ws - where minL [] = myerror "minL on empty list" - minL [a] = a - minL (a:b:c) = minL (min a b:c) - - partitionR :: CutDirection -> Rectangle -> [Area] -> [Rectangle] + myv = runCountDown largeNumber $ mosaic_splits even_split origRect Vertical sortedws + 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 (\(nw,r)->(trace ("rate1:"++ unlines [show nw, + show $ rate f meanarea (findlist nw hints) r, + show r, + show $ area r/meanarea, + show $ findlist nw hints]) $ + unName nw,crop' (findlist nw hints) r)) $ + flattenMosaic $ the_value $ + trace ("ratings: "++ show (map the_rating [myv,myh,myv2,myh2])) $ + maxL [myv,myh,myv2,myh2] + 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 -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) + even_split r d [ws] = even_split r d $ map (:[]) ws + even_split r d wss = + do let areas = map sumareas wss + let wsr_s :: [([NamedWindow], Rectangle)] + wsr_s = zip wss (partitionR d r areas) + submosaics <- mapM (\(ws',r') -> + mosaic_splits even_split r' (otherDirection d) ws') wsr_s + return $ fmap M $ catRated submosaics + one_split :: Rectangle -> CutDirection -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, 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 :: [([NamedWindow], 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 -> [Double] -> [Rectangle] partitionR _ _ [] = [] partitionR _ r [_] = [r] partitionR d r (a:ars) = r1 : partitionR d r2 ars where totarea = sum (a:ars) (r1,r2) = split d (a/totarea) r - - rating :: WindowRater - rating w r = (M.findWithDefault default_preferences w raters) w r - default_preferences :: WindowRater - default_preferences _ r@(Rectangle _ _ w h) - | fr <- w /// h = sqr(fr/f)+sqr(f/fr)-2+ toRational (mean_area/area r) - sqr a = a * a - sumareas ws = sum $ map (\w -> M.findWithDefault 1 w areas) ws - - - -catRated :: Num v => [Rated v a] -> Rated v [a] -catRated xs = Rated (sum $ map the_rating xs) (map the_value xs) - -data Rated a b = Rated !a !b -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' - -type Area = Rational - -area :: Rectangle -> Area + theareas = hints2area `fmap` hints + sumareas ws = sum $ map (\w -> M.findWithDefault 1 w theareas) ws + meanarea = area origRect / fromIntegral (length origws) + +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) + +data CountDown = CD !StdGen !Int + +runCountDown :: Int -> State CountDown a -> a +runCountDown n x = fst $ runState x (CD (mkStdGen n) n) + +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 + +getOne :: (Random a) => (a,a) -> State CountDown a +getOne bounds = do CD g n <- get + (x,g') <- return $ randomR bounds g + put $ CD g' n + return x + +fractional :: Int -> State CountDown Double +fractional n = ((/ fromIntegral n).fromIntegral) `fmap` getOne (1,n) + +data WindowHint = RelArea Double + | 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 + +crop :: [WindowHint] -> Rectangle -> Rectangle +crop (AspectRatio f:_) = cropit f +crop (FlexibleAspectRatio f:_) = cropit f +crop (_:hs) = crop hs +crop [] = id + +crop' :: [WindowHint] -> Rectangle -> Rectangle +crop' (AspectRatio f:_) = cropit f +crop' (_:hs) = crop' hs +crop' [] = id + +cropit :: Double -> Rectangle -> Rectangle +cropit f (Rectangle a b w h) | w -/- h > f = Rectangle a b (floor $ h -* f) h + | otherwise = Rectangle a b w (floor $ w -/ f) + +hints2area :: [WindowHint] -> Double +hints2area [] = defaultArea +hints2area (RelArea r:x) = r +hints2area (_:x) = hints2area x + +area :: Rectangle -> Double area (Rectangle _ _ w h) = fromIntegral w * fromIntegral h -(///) :: (Integral a, Integral b) => a -> b -> Rational -a /// b = fromIntegral a / fromIntegral b +(-/-) :: (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 -> Rational -> Rectangle -> (Rectangle, Rectangle) +split :: CutDirection -> Double -> Rectangle -> (Rectangle, Rectangle) 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 @@ -172,6 +278,7 @@ otherDirection Horizontal = Vertical data Mosaic a where M :: [Mosaic a] -> Mosaic a OM :: a -> Mosaic a + deriving ( Show ) flattenMosaic :: Mosaic a -> [a] flattenMosaic (OM a) = [a] @@ -180,8 +287,13 @@ flattenMosaic (M xs) = concatMap flattenMosaic xs allsplits :: [a] -> [[[a]]] allsplits [] = [[[]]] allsplits [a] = [[[a]]] -allsplits (x:xs) = (map ([x]:) splitsrest) ++ - (map (maphead (x:)) splitsrest) +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] -- cgit v1.2.3