start switching over to a Monte Carlo algorithm for Mosaic

darcs-hash:20070601170505-72aca-85ecaae664eb2f1895e3ababbe18514add559c29.gz

1 files changed, 52 insertions, 1 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