start switching over to a Monte Carlo algorithm for Mosaic

This commit is contained in:
David Roundy
2007-06-01 17:05:05 +00:00
parent 30dc246bcc
commit 64a3481d86
2 changed files with 147 additions and 27 deletions

View File

@@ -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

121
Mosaic.hs
View File

@@ -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