mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-07-31 20:21:51 -07:00
start switching over to a Monte Carlo algorithm for Mosaic
This commit is contained in:
53
Anneal.hs
53
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
|
||||
|
121
Mosaic.hs
121
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
|
||||
|
Reference in New Issue
Block a user