From 207f145752592e69a856d6c8e5bd7e8c95f365cc Mon Sep 17 00:00:00 2001 From: David Roundy Date: Fri, 1 Jun 2007 19:05:05 +0200 Subject: start switching over to a Monte Carlo algorithm for Mosaic darcs-hash:20070601170505-72aca-85ecaae664eb2f1895e3ababbe18514add559c29.gz --- Anneal.hs | 53 ++++++++++++++++++++++++++- Mosaic.hs | 121 ++++++++++++++++++++++++++++++++++++++++++++++++-------------- 2 files changed, 147 insertions(+), 27 deletions(-) diff --git a/Anneal.hs b/Anneal.hs index 5083030..093a570 100644 --- a/Anneal.hs +++ b/Anneal.hs @@ -1,5 +1,8 @@ module XMonadContrib.Anneal ( Rated(Rated), the_value, the_rating, anneal ) where +import System.Random ( StdGen, Random, mkStdGen, randomR ) +import Control.Monad.State ( State, runState, put, get, gets, modify ) + data Rated a b = Rated !a !b deriving ( Show ) instance Functor (Rated a) where @@ -16,4 +19,52 @@ 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 +anneal st r sel = runAnneal st 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 x) a +select [] = error "empty list in select" +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/Mosaic.hs b/Mosaic.hs index b07b331..bfe1b10 100644 --- a/Mosaic.hs +++ b/Mosaic.hs @@ -62,7 +62,7 @@ tallWindow = TallWindow wideWindow = WideWindow largeNumber, mediumNumber, resolutionNumber :: Int -largeNumber = 200 +largeNumber = 50 mediumNumber = 10 resolutionNumber = 100 @@ -121,22 +121,22 @@ 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 = runCountDown largeNumber $ mosaic_splits even_split origRect Vertical sortedws - myv2 = maxL $ runCountDown largeNumber $ - sequence $ replicate mediumNumber $ - mosaic_splits one_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 (\(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]) $ +-- 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] + flattenMosaic $ the_value $ maxL [myh2,myv2] 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) @@ -150,6 +150,32 @@ mosaicL f hints origRect origws submosaics <- mapM (\(ws',r') -> mosaic_splits even_split r' (otherDirection d) ws') wsr_s return $ fmap M $ catRated submosaics + another_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + another_mosaic ws d = rate_mosaic ratew $ + rect_mosaic origRect d $ + zipML (example_mosaic ws) (map findarea ws) + mc_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + mc_mosaic ws d = fmap (rect_mosaic origRect d) $ + anneal (zipML (example_mosaic ws) (map findarea ws)) + (the_rating . rate_mosaic ratew . rect_mosaic origRect d ) + changeMosaic + + ratew :: (NamedWindow,Rectangle) -> Double + ratew (w,r) = rate f meanarea (findlist w hints) r + example_mosaic :: [NamedWindow] -> Mosaic NamedWindow + 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 + rs = partitionR d r areas + d' = otherDirection d + rate_mosaic :: ((NamedWindow,Rectangle) -> Double) + -> Mosaic (NamedWindow,Rectangle) -> Rated Double (Mosaic (NamedWindow,Rectangle)) + rate_mosaic r m = catRatedM $ fmap (\x -> Rated (r x) x) m +{- one_split :: Rectangle -> CutDirection -> [[NamedWindow]] -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) one_split r d [ws] = one_split r d $ map (:[]) ws @@ -160,7 +186,7 @@ mosaicL f hints origRect origws 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] @@ -168,7 +194,9 @@ mosaicL f hints origRect origws where totarea = sum (a:ars) (r1,r2) = split d (a/totarea) r theareas = hints2area `fmap` hints - sumareas ws = sum $ map (\w -> M.findWithDefault 1 w theareas) ws + sumareas ws = sum $ map findarea ws + findarea :: NamedWindow -> Double + findarea w = M.findWithDefault 1 w theareas meanarea = area origRect / fromIntegral (length origws) maxL :: Ord a => [a] -> a @@ -179,6 +207,10 @@ 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 runCountDown :: Int -> State CountDown a -> a @@ -204,15 +236,6 @@ run_with_only limit j = 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 @@ -280,6 +303,52 @@ data Mosaic a where OM :: a -> Mosaic 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 a) = [] +changeMosaic (M xs) = [makeM $ reverse xs] ++ + map makeM (concatenations xs) ++ + map makeM (splits xs) -- should also change the lower level + +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 -- cgit v1.2.3