Commit 320dba89dedbc42e530a5f3653364d46938bcc1a

MWC based DE
MWCDE.hs
(79 / 0)
  
1{-# LANGUAGE ScopedTypeVariables,NoMonomorphismRestriction #-}
2module MWCDE where
3
4import Control.Parallel.Strategies
5import MWCMonad
6import Utils.Vector
7
8import Data.Maybe
9import Data.List
10import Control.Monad
11import Utils.Stream
12
13
14deTest = do
15 print "foo"
16 let ip = runRand [435,23,12,134,1]
17 (initPop 60 rastrigin (take 100 rastriginBounds))
18 return $ iterateS (de
19 (Just rastriginBounds)
20 rastrigin
21 0.3 0.7)
22 (DEState (0,ip))
23
24
25type CR = Double
26type F = Double
27type Fitness = Double
28type FitnessFunction = Vector -> Double
29
30initPop :: Int -> FitnessFunction -> [(Double,Double)] -> Rand [(Double,Vector)]
31initPop n f b = (replicateM n $ uniformRandomVectorRS b )
32 >>= return.map (\x -> (f x,x))
33
34newtype DEState a = DEState (Int,[(Double,a)])
35
36deCrossover1 f cr a x y z = ensuredRatioCrossover cr a v
37 where
38 v = z <+> (f *| (x <-> y))
39
40uniformRatioCrossover :: Double -> [a] -> [a] -> Rand [a]
41uniformRatioCrossover cr x v = do
42 randoms <- replicateM (length x) (getRandomR (0,1))
43 return $ map (\(x,e1,e2) -> if x<cr then e2 else e1)
44 $ zip3 randoms x v
45
46oneGeneCrossover a b = do
47 index :: Double <- getRandomR (0,fromIntegral (min (genericLength a-1) (genericLength b-1)))
48 return (take (floor index) a ++ [b !! floor index] ++ drop (floor index+1) a)
49
50ensuredRatioCrossover cr a b = do
51 ensured <- oneGeneCrossover a b
52 uniformRatioCrossover cr ensured b
53
54saturateReals bounds x = zipWith saturate bounds x
55saturateRealsM bounds x = return $ saturateReals bounds x
56
57saturate (lb,ub) x = min (max x lb) ub
58
59rastrigin x = 10*(fromIntegral (length x))+sum [x_i^2-10*cos(2*pi*x_i) | x_i <- x]
60rastriginBounds = repeat (-5.12,5.12)
61
62de bounds fitness cr f (DEState (ec,pop)) = do
63 x <- mapM candidate pop
64 let newPop = parMap rnf select x -- TODO: Consider parListChunk
65 return (DEState (ec+length pop,newPop))
66 where
67 candidate orig@(ft,a) = do
68 (_,x) <- fromNonWeightedList pop
69 (_,y) <- fromNonWeightedList pop
70 (_,z) <- fromNonWeightedList pop
71 w <- deCrossover1 cr f a x y z >>= postProcess
72 return (orig, w)
73 postProcess x | isJust bounds = saturateRealsM (fromJust bounds) x
74 | otherwise = return x
75 select ((fa,a),b) = if fitness a < fitness b then (fa,a) else (fitness b,b)
76
77
78-- Utils
79parMapChunk s n f l = map f l `using` parListChunk n s
MWCMonad.hs
(38 / 0)
  
1{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
2module MWCMonad where
3
4import System.Random.MWC
5-- import Data.Vector.Unboxed
6import Data.Vector.Generic (Vector)
7import qualified Data.Vector.Unboxed as I
8import qualified Data.Vector.Unboxed.Mutable as M
9import Control.Monad.ST
10import Control.Monad.Reader
11import Data.STRef
12import Data.List
13import Data.Word
14-- | Marks a computation that requires random values
15newtype Rand a = Rand {unR :: (forall s. Gen s -> ST s a) }
16
17-- | For allowing the Monadic syntax when using @Rand@
18instance Monad Rand where
19 return k = Rand (\ _ -> return k)
20 Rand c1 >>= fc2 = Rand (\ g -> c1 g >>= \a -> unR (fc2 a) g)
21
22
23getRandom :: Variate a => Rand a
24getRandom = Rand (\gen -> uniform gen)
25
26runRand seed op = runST (initialize (I.fromList seed) >>= unR op)
27
28getRandomR :: (Variate a,Num a, Floating a) => (a,a) -> Rand a
29getRandomR (a,b) = getRandom >>= \r -> return (a+(a-b)*r)
30
31
32uniformRandomVectorRS :: (Variate a,Num a, Floating a) => [(a,a)] -> Rand [a]
33uniformRandomVectorRS = mapM getRandomR
34
35fromNonWeightedList l = do
36 index :: Double <- getRandomR (0,genericLength l -1)
37 -- TODO: Increase speed by removing from/to double
38 return $ l !! floor index
test1.hs
(2 / 1)
  
1515import Control.Monad
1616import Utils.Stream
1717import qualified OldDE
18import qualified MWCDE
1819
1920import Criterion.Config
2021import Criterion.Main
2424myConfig = defaultConfig { cfgPerformGC = ljust True }
2525
2626main = do
27 (OldDE.DEState (ec,pop)) <- OldDE.deTest >>= evalRandomIO . runIt 100
27 (MWCDE.DEState (ec,pop)) <- OldDE.deTest >>= evalRandomIO . runIt 100
2828 print ec
2929
3030runIt :: (Monad m) => Int -> Stream m a -> m a