diff options
author | David Roundy <droundy@darcs.net> | 2007-06-01 19:05:05 +0200 |
---|---|---|
committer | David Roundy <droundy@darcs.net> | 2007-06-01 19:05:05 +0200 |
commit | 207f145752592e69a856d6c8e5bd7e8c95f365cc (patch) | |
tree | 77d14a8a22a4bbc1c44ade1d4c4992cb61e64e77 /Anneal.hs | |
parent | ae03454010d00345f77565b4f3d76e65045c16b5 (diff) | |
download | XMonadContrib-207f145752592e69a856d6c8e5bd7e8c95f365cc.tar.gz XMonadContrib-207f145752592e69a856d6c8e5bd7e8c95f365cc.tar.xz XMonadContrib-207f145752592e69a856d6c8e5bd7e8c95f365cc.zip |
start switching over to a Monte Carlo algorithm for Mosaic
darcs-hash:20070601170505-72aca-85ecaae664eb2f1895e3ababbe18514add559c29.gz
Diffstat (limited to '')
-rw-r--r-- | Anneal.hs | 53 |
1 files changed, 52 insertions, 1 deletions
@@ -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 |