concurrent-sa (empty) → 1.0.0

raw patch · 5 files changed

+169/−0 lines, 5 filesdep +MonadRandomdep +basesetup-changed

Dependencies added: MonadRandom, base

Files

• Control/Concurrent/Annealer.hs +62/−0
• Control/Concurrent/Annealer/Population.hs +82/−0
• LICENSE +2/−0
• Setup.lhs +4/−0
• concurrent-sa.cabal +19/−0

@@ -0,0 +1,62 @@+{-# LANGUAGE RecordWildCards #-}++-- | The traditional simulated annealing is to maintain a current state,+-- and repeatedly perturb it, keeping or discarding the perturbed state+-- depending on the difference in an energy function and a "temperature,"+-- which changes as a function of time.  This concurrent+-- SA implementation maintains a population of current states which are+-- perturbed, and lower-ranked states are deleted according to a temperature+-- function.  It is intended as a lightweight approach to parallelizing+-- optimization problems.+module Control.Concurrent.Annealer  (Annealer, initAnnealer, offerState, getBestState, annealForTime) where++import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Monad (replicateM)++import Control.Concurrent.Annealer.Population hiding (offerState)+import qualified Control.Concurrent.Annealer.Population as Pop++data Annealer s e = PopAnn {+	solPop :: {-# UNPACK #-} !(Population s e),+	perturb :: s -> IO s}++-- | Returns the current best state in the annealer.+getBestState :: Ord e => Annealer s e -> IO s+getBestState = getBest . solPop++-- | Initializes an annealer.+initAnnealer :: Ord e => (s -> e) -- ^ The energy function for a state.+			-> [s]	-- ^ A collection of initial states.+			-> Int	-- ^ The size at which to maintain the population.+			-> (s -> IO s) +				-- ^ The perturbation function.+			-> IO (Annealer s e)+				-- ^ The annealer.+initAnnealer solScore sols popSize perturb = +	do	solPop <- initPop solScore sols popSize+		return PopAnn{..}++-- | A thread in which states in the annealer's current population are perturbed+-- and offered back into the population.+perturber :: Annealer s e -> IO ()+perturber pop@PopAnn{..} = do+	sol' <- perturb =<< pickState solPop+	Pop.offerState sol' solPop+	perturber pop++-- | Offer a state to the annealer.  Depending on the current+-- population, the state may or may not be kept.+offerState :: s -> Annealer s e -> IO ()+offerState s = Pop.offerState s . solPop++-- | Runs several annealing threads for the specified length of time.+annealForTime :: Ord e => +		Int	-- The number of annealing threads to run.+		-> Int	-- The number of milliseconds until this program will try to stop.+		-> Annealer s e	-- The annealer to run.+		-> IO s	-- The best state in the annealer's population at the time of ending.+annealForTime nThreads t pop = do+	threads <- replicateM nThreads (forkIO (perturber pop))+	threadDelay t+	mapM_ killThread threads+	getBestState pop

@@ -0,0 +1,82 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}++module Control.Concurrent.Annealer.Population (Population, offerState, initPop, pickState, getBest) where++import Control.Concurrent+import Control.Monad.Random (MonadRandom (..))++import Data.List+import Data.Ord+import Data.Functor++data Population s e = Pop {+	popSize :: {-# UNPACK #-} !Int,+	solScore :: (s -> e),+	solsVar :: MVar [(s, e)],+	solsChan :: Chan s}++offerState :: s -> Population s e -> IO ()+offerState s Pop{solsChan} = writeChan solsChan s++processChan :: Ord e => Int -> Population s e -> IO ()+processChan t pop@Pop{..} = t `seq` do+	sol <- readChan solsChan+	sols <- takeMVar solsVar+	if length sols < popSize then+		do	putMVar solsVar ((sol, solScore sol):sols)+			processChan t pop+		else do	let r = sqrt (log (fromIntegral t) + 1.0) :: Double+			sols' <- sortBy (flip $ comparing snd) <$> shuffle (popSize + 1) ((sol, solScore sol):sols)+			putMVar solsVar =<< elimListTo (length sols') popSize r sols'+			processChan (t+1) pop++-- | Eliminates elements of the list until it reaches a certain size.  +-- The probability that the ith element will be deleted is a geometric +-- function of i.+elimListTo :: MonadRandom m => Int -> Int -> Double -> [a] -> m [a]+elimListTo n m r xs+	| n == m	= return xs+	| otherwise	= elimListTo (n-1) m r =<< elimList n r xs++pickState :: Population s e -> IO s+pickState Pop{..} = do+	sols <- readMVar solsVar+	i <- getRandomR (0, popSize - 1)+	return (fst (sols !! i))++getBest :: Ord e => Population s e -> IO s+getBest Pop{solsVar} = do+	sols <- readMVar solsVar+	return (fst (minimumBy (comparing snd) sols))++initPop :: Ord e => (s -> e) -> [s] -> Int -> IO (Population s e)+initPop solScore sols popSize = do+	solsVar <- newMVar [(sol, solScore sol) | sol <- sols]+	solsChan <- newChan+	let pop = Pop{..}+	forkIO (processChan 0 pop)+	return pop++{-# SPECIALIZE elimList :: Int -> Double -> [a] -> IO [a] #-}+elimList :: MonadRandom m => Int -> Double -> [a] -> m [a]+elimList _ _ [] = return []+elimList n r as = n `seq` do+	x <- getRandom+	let i = min (n-1) $ floor $ logBase r (1 - (x * (1 - r ^ (n + 1))))+	let (xs1, _:xs2) = splitAt i as+	return (xs1 ++ xs2)+	where	q = r ^ (n + 1)++{-# SPECIALIZE shuffle :: Int -> [a] -> IO [a] #-}+shuffle :: MonadRandom m => Int -> [a] -> m [a]+shuffle n xs = n `seq` case xs of+	[] -> return []+	xs -> do+		i <- getRandomR (0, n-1)+		let (xs1, x:xs2) = splitAt i xs+		xs' <- shuffle (n-1) (xs1 ++ xs2)+		return (x:xs')++{-# RULES+	"[] ++" forall xs . [] ++ xs = xs;+	#-}

@@ -0,0 +1,2 @@+Copyright Louis Wasserman 2010+BSD license

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,19 @@+Name:		concurrent-sa+Version:	1.0.0+Category:	Algorithms+Author:		Louis Wasserman+License:	BSD3+License-file:	LICENSE+Stability:	experimental+Synopsis:	Concurrent simulated annealing system.+Description:	An extremely lightweight system for concurrent simulated annealing.+Maintainer:	Louis Wasserman <wasserman.louis@gmail.com>+Build-type:	Simple+cabal-version:  >= 1.6+Library{+  build-depends: base >= 4 && < 5, MonadRandom+  exposed-modules:+    Control.Concurrent.Annealer+  other-modules:+    Control.Concurrent.Annealer.Population+}