Commit 8d7e6cd2cf8f4f0da6215038566396e065fe6960

Performance increases
 * Unboxed vectors (No help)
 * Smarter saturate
 * Direct versions of some test functions

With this and move to ghc 7 things get 4 times
faster. (Compilation with -fexcessprecision might
have also helped)
MTS.hs
(47 / 32)
  
11{-#LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeOperators, TemplateHaskell, ParallelListComp, TupleSections, RecordWildCards#-}
22module MTS where
33import System.Random.MWC
4import qualified Data.Vector.Mutable as M
5import qualified Data.Vector as V
6import Data.Vector ((!))
4import qualified Data.Vector.Unboxed.Mutable as M
5import qualified Data.Vector.Mutable as MB
6import qualified Data.Vector.Unboxed as V
7import qualified Data.Vector as VB
8import Data.Vector.Unboxed ((!))
79import Control.Applicative
810import Control.Arrow(second)
911import Utils.ShuffleMWC
2626newtype Fitness = F Double deriving (Num,Eq,Ord,Show)
2727data Indevidual s = Ind {fit :: STRef s Fitness
2828 ,imp :: STRef s Bool
29 ,sri :: M.MVector s SR
29 ,sri :: MB.MVector s SR
3030 ,vec :: Vect s}
3131type Grade = Double
3232newtype SR = SR Double deriving (Num,Eq,Ord,Fractional,Show)
3737data MTSParams s = MTSParams {
3838 _fitness :: FitnessFunction s
3939 , _gen :: PRNG s
40 , _srp :: M.MVector s SR
40 , _srp :: MB.MVector s SR
4141 , _currentBest :: Indevidual s
4242 , _trace :: [(Int,Fitness,String)]
4343 , _bonus1 :: Double
6262writeRef a b = lift $ writeSTRef a b
6363modifyRef a b = lift $ modifySTRef a b
6464
65multipleTrajectorySearch :: Seed -> Int -> Bounds -> Int -> FitnessFunction s -> MTSMonad s (V.Vector (Indevidual s))
65multipleTrajectorySearch :: Seed -> Int -> Bounds -> Int -> FitnessFunction s -> MTSMonad s (VB.Vector (Indevidual s))
6666multipleTrajectorySearch seed popSize bds budget ff = do
6767 lift (restore seed) >>= setM gen
68 srs <- lift (M.new (V.length bds))
69 lift $ forM_ [0..(V.length bds)-1] $ \j -> M.write srs j (let (a,b) = bds ! j in SR $ (b-a)*0.4)
68 srs <- lift (MB.new (V.length bds))
69 lift $ forM_ [0..(V.length bds)-1] $ \j -> MB.write srs j (let (a,b) = bds ! j in SR $ (b-a)*0.4)
7070 fitness =: ff
7171 srp =: srs
7272 bounds =: bds
7373 g <- getM gen
7474 initial <- lift (buildSOAPopulation g popSize bds) >>=
75 V.mapM (lift.V.thaw >=> createInd)
76 updateBest (initial ! 0)
75 VB.mapM (lift.V.thaw >=> createInd)
76 updateBest (initial VB.! 0)
7777 logPoint "SOA"
7878
7979 let ofLocalSearchTest = 3
8080 let ofForeground = 3
8181 let ofLocalSearchBest = 150
8282 let ofLocalSearch = 100
83 enabled <- lift $ M.replicate (V.length initial) True
84 grades <- lift $ M.replicate (V.length initial) 0
83 enabled <- lift $ M.replicate (VB.length initial) True
84 grades <- lift $ M.replicate (VB.length initial) 0
8585 whileBudgetRemaining budget $ do
86 forM [0..V.length initial - 1] $ \i -> do
86 forM [0..VB.length initial - 1] $ \i -> do
8787 isEnabled <- lift $ M.read enabled i
8888 when (isEnabled) $ do
8989 lift $ M.write grades i 0
9191 ls2 <- lift $ newSTRef 0
9292 ls3 <- lift $ newSTRef 0
9393 forM_ [0..ofLocalSearchTest] $ \j -> do
94 localSearch1 (initial ! i) >>= \x -> modifyRef ls1 (+x)
95 localSearch2 (initial ! i) >>= \x -> modifyRef ls2 (+x)
96 localSearch3 (initial ! i) >>= \x -> modifyRef ls3 (+x)
94 localSearch1 (initial VB.! i) >>= \x -> modifyRef ls1 (+x)
95 localSearch2 (initial VB.! i) >>= \x -> modifyRef ls2 (+x)
96 localSearch3 (initial VB.! i) >>= \x -> modifyRef ls3 (+x)
9797 g1<-readRef ls1 >>= return.(,localSearch1)
9898 g2<-readRef ls2 >>= return.(,localSearch2)
9999 g3<-readRef ls3 >>= return.(,localSearch3)
100100 let (_,best) = maximumBy(compare`on`fst) [g1,g2,g3]
101 forM_ [0..ofLocalSearch] $ \_ -> best (initial ! i)
101 forM_ [0..ofLocalSearch] $ \_ -> best (initial VB.! i)
102102 lift $ M.write grades i (sum.map fst $ [g1,g2,g3])
103103
104104 forM_ [0..ofLocalSearchBest] $ \_ -> do
109109 . V.toList)
110110 lift $ M.set enabled False
111111 forM_ gs $ \(i,g) -> lift $ M.write enabled i True
112 V.mapM_ (validateHard "End of Seq") initial -- Just to cull out most terrible of bugs. Can be commented out for more speed
112 VB.mapM_ (validateHard "End of Seq") initial -- Just to cull out most terrible of bugs. Can be commented out for more speed
113113
114114 return initial
115115
141141 x1 <- cloneIndevidual x >>= \a -> change3 [(i, 0.1)] a >> return a
142142 x2 <- cloneIndevidual x >>= \a -> change3 [(i,-0.1)] a >> return a
143143 x3 <- cloneIndevidual x >>= \a -> change3 [(i, 0.2)] a >> return a
144 mapM_ (saturateP [i]) [x1,x2,x3]
144145 [f1,f2,f3] <- mapM (evaluate) [x1,x2,x3]
145146 whenNewBest x1 $ logPoint "L3Best" >>addBonus1 >> updateBest x1
146147 whenNewBest x2 $ logPoint "L3Best" >>addBonus1 >> updateBest x2
158158 old <- lift (M.read vec i)
159159 saved <- saveInd [i] x
160160 lift $ modify i (\old -> old + a*(d1-d2) + b*(d3-2*d1) + c) vec -- TODO: Get rid of modify
161
161 saturateP [i] x
162162 fFinal <- evaluate x
163163 if fFinal > cfit
164 then restoreInd saved x >> validateHard "ls3-rest" x >> return ()
164 then restoreInd saved x >> return ()
165165 else logPoint "LS3-succ-final" >> addBonus2
166166 g <- readRef grade
167167 logPoint $ "LS3-end"
168168 logPoint $ "Grade-LS3 " ++ show g
169169 return g
170170
171saturate :: Indevidual s -> MTSMonad s ()
172saturate ind = do
171--saturate :: Indevidual s -> MTSMonad s ()
172--saturate ind = do
173-- bds <- getM bounds
174-- forM_ [0..dim ind-1] $ \i ->
175-- lift $ (M.read (vec ind) i >>= M.write (vec ind) i . (scale (bds ! i)))
176-- badFitness ind
177-- where scale (a,b) x = min b (max a x)
178
179saturateP :: [Int] -> Indevidual s -> MTSMonad s ()
180saturateP is ind = do
173181 bds <- getM bounds
174 forM [0..dim ind-1] $ \i ->
182 forM_ is $ \i ->
175183 lift $ (M.read (vec ind) i >>= M.write (vec ind) i . (scale (bds ! i)))
176184 badFitness ind
177185 where scale (a,b) x = min b (max a x)
192192cloneIndevidual (Ind{..}) = lift $ do
193193 a <- readSTRef fit >>= newSTRef
194194 b <- readSTRef imp >>= newSTRef
195 s <- M.clone sri
195 s <- MB.clone sri
196196 c <- M.clone vec
197197 return (Ind{fit=a,imp=b,vec=c,sri=s})
198198
223223 r <- trial0 ind (test [(d,sr)]) (test [(d,-0.5*sr)])
224224 return r
225225
226getSR ind i = lift $ M.read (sri ind) i
226getSR ind i = lift $ MB.read (sri ind) i
227227
228228trial2 :: Indevidual s -> MTSMonad s (Double)
229229trial2 ind = do
237237test srs ind = do
238238 s <- saveInd (map fst srs) ind
239239 let change = change3 srs
240 -- restore = (change3 (map (second negate) srs))
241240 cb <- getM currentBest >>= readFitness
242241 fit <- readFitness ind
243242 change ind
243 saturateP (map fst srs) ind
244244 fit' <- evaluate ind
245245 case compare fit' fit of
246246 LT | fit' < cb -> return . Best $ fit'
296296
297297evaluate :: Indevidual s -> MTSMonad s (Fitness)
298298evaluate x@(Ind{..}) = do
299 saturate x
300299 ff <- getM fitness
301300 fit' <- ff vec
302301 writeRef fit fit'
307307
308308validateHard :: String -> Indevidual s -> MTSMonad s ()
309309validateHard at x@(Ind{..}) = do
310 bds <- getM bounds
311 forM_ [0..M.length vec-1] $ \i -> lift $ do
312 xi <- M.read vec i
313 when (xi>snd (bds ! i) || xi<fst (bds ! i)) $ error "Indevidual out of bounds!"
314
310315 old <- readFitness x
311316 ff <- getM fitness
312317 fit' <- ff vec
327327updateSRM ind = do
328328 i<-improves ind
329329 when (not i) $ do
330 vals <- lift $ V.freeze (sri ind) -- tracing
331 logPoint $ "SR update:"++show vals --tracing
330 --vals <- lift $ V.freeze (sri ind) -- tracing
331 --logPoint $ "SR update:"++show vals --tracing
332332 bds <- getM bounds
333333 lift $ forM_ [0..M.length (vec ind) -1] $ \i ->
334 modify i (updateSR (bds ! i)) (sri ind)
334 modifyB i (updateSR (bds ! i)) (sri ind)
335335
336336updateSR (a,b) sr | sr < 1e-15 = SR $ 0.4*(b-a)
337337 | otherwise = sr/2
347347createInd vec = do
348348 let dim = M.length vec
349349 bds <- getM bounds
350 srs <- lift $ M.new dim
350 srs <- lift $ MB.new dim
351351 --srs <- getM srp
352 lift $ forM_ [0..dim-1] $ \i -> M.write srs i (let (a,b) = bds ! i in SR $ (b-a)*0.4)
352 lift $ forM_ [0..dim-1] $ \i -> MB.write srs i (let (a,b) = bds ! i in SR $ (b-a)*0.4)
353353 fit <- getM fitness
354354 f <- fit vec >>= lift . newSTRef
355355 improve <- lift $ newSTRef True
SOA.hs
(3 / 2)
  
11module SOA where
22import System.Random.MWC
3import qualified Data.Vector as V
3import qualified Data.Vector.Unboxed as V
4import qualified Data.Vector as VB
45import Control.Applicative
56import Utils.ShuffleMWC
67
78buildSimulatedOrthogonalArray gen dim = V.fromList <$> doShuffle gen (map fromIntegral [0..dim-1])
89
910buildSOAPopulation gen populationSize ranges
10 = V.replicateM populationSize
11 = VB.replicateM populationSize
1112 (V.zipWith scale ranges <$> buildSimulatedOrthogonalArray gen dim)
1213 where
1314 scale (a,b) x = a + (x/fromIntegral populationSize) * (b-a)
Test.hs
(53 / 30)
  
1{-#LANGUAGE TemplateHaskell, RecordWildCards,RankNTypes, ViewPatterns,ScopedTypeVariables,ImpredicativeTypes#-}
1{-#LANGUAGE CPP, TemplateHaskell, RecordWildCards,RankNTypes, ViewPatterns,ScopedTypeVariables,ImpredicativeTypes#-}
22{-# OPTIONS -fforce-recomp #-}
33module Main where
44import MTS
5import qualified Data.Vector as V
6import Data.Vector ((!))
5import qualified Data.Vector as Vb
6import Data.Vector.Unboxed ((!))
77import qualified Data.ByteString.Lazy.Char8 as B
8import qualified Data.Vector.Unboxed as VU
8import qualified Data.Vector.Unboxed as V
99import qualified Data.Vector.Generic.Mutable as M
1010import Data.Record.Label
1111import Data.STRef
2121import Data.Word
2222import Control.Concurrent.ParallelIO.Local
2323import System.Directory
24#ifndef GHC_7
2425import qualified TestFunctions as TF
26#endif
2527import Utils.File
2628import Control.Monad
2729import Control.Arrow(second)
5454f1 = mrt V.sum (V.map (**2))
5555f2 = mrt V.maximum (V.map abs)
5656f3 = mrt V.sum (\xs -> V.zipWith (\xi xj -> 100*(xi**2-xj)+(xi-1)**2) xs (V.tail xs))
57f4 = mrt V.sum (V.map (\xi -> xi**2-10*cos(2*pi*xi)+10))
58f4_1 = mrt V.sum (srot (\xs -> V.map (\xi -> xi**2-10*cos(2*pi*xi)+10)))
57f4 (fromIntegral -> dim) = mrt V.sum (V.map (\xi -> xi**2-10*dim*cos(2*pi*xi)+10))
5958f5 = mrt0 (\xs -> V.sum (V.map (\xi -> (xi**2)/4000) xs)
6059 -V.product (V.zipWith (\xi i ->cos (xi/sqrt i) )
6160 xs
6262 +1)
6363srot f x = V.zipWith (\a b->0.5*(a+b)) (V.reverse x) x
6464
65f3_mut :: Int -> Double -> FitnessFunction s
66f3_mut dim bias x = work 0 (dim-2)
67 where
68 fdim = fromIntegral dim
69 work n (-1) = return . F $ n+bias
70 work n i = do
71 xi <- lift $ M.read x i
72 xj <- lift $ M.read x (i+1)
73 work (n+(xi**2-xj)+(xi-1)**2) (i-1)
74
75f4_mut :: Int -> Double -> (Vect s -> MTSMonad s Fitness)
76f4_mut dim bias x = work 0 (dim-1)
77 where
78 fdim = fromIntegral dim
79 work n (-1) = return . F $ n+bias
80 work n i = do
81 xi <- lift $ M.read x i
82 work (n+((xi)**2-10*fdim*cos(2*pi*(xi))+10)) (i-1)
83#ifndef GHC_7
6584listAdapter :: TF.TestFunction -> (String,MTS.Bounds,(forall s. FitnessFunction s))
6685listAdapter tf = (TF.identifier tf
6786 ,V.fromList . TF.bounds $ tf
6887 ,\mvec -> do
6988 lst <- lift $ V.freeze mvec >>= return . V.toList
7089 return $ F $ TF.fitness tf lst)
90#endif
7191
7292
7393
9595shift1 o = V.map (+1) . V.zipWith (flip (-)) o
9696bias b = (+b)
9797
98createSeed fls = initialize (VU.fromList fls) >>= save
98createSeed fls = initialize (V.fromList fls) >>= save
9999
100100data RunInfo = RI {optimizer_name :: String
101101 ,test_function :: String
133133
134134showTrace = unlines . map (\(ec,F f,note) -> show ec ++"\t"++show f++"\t"++note )
135135
136failTest = putStrLn $ runMTS $ do
137 fitness =: f4 (-390)
138 let bds = V.replicate 10 (-5,5)
136--failTest = putStrLn $ runMTS $ do
137-- fitness =: f4 10 (-390)
138-- let bds = V.replicate 10 (-5,5)
139139
140 srs <- lift (M.new (V.length bds))
141 lift $ forM_ [0..(V.length bds)-1] $ \j -> M.write srs j (let (a,b) = bds ! j in SR $ (b-a)*0.4)
142 srp =: srs
143 MTS.bounds =: bds
144 srp =: srs
145 ind <- testInd
146 currentBest =: ind
140-- srs <- lift (M.new (V.length bds))
141-- lift $ forM_ [0..(V.length bds)-1] $ \j -> M.write srs j (let (a,b) = bds ! j in SR $ (b-a)*0.4)
142-- srp =: srs
143-- MTS.bounds =: bds
144-- srp =: srs
145-- ind <- testInd
146-- currentBest =: ind
147147
148 istart <-lift $ V.freeze (vec ind)
149 fstart <- readFitness ind
150 clone <- cloneIndevidual ind >>= \a -> change3 [(1, 100.2)] a >> return a
151 cb <-lift $ V.freeze (vec clone)
152 fc <- evaluate clone
153 ce <-lift $ V.freeze (vec clone)
154 iend <-lift $ V.freeze (vec ind)
155 fend <- readFitness ind
156 return (unlines ["fail", show istart,show iend,show fstart,show fend,"--"
157 ,show fc,show cb, show ce])
148-- istart <-lift $ V.freeze (vec ind)
149-- fstart <- readFitness ind
150-- clone <- cloneIndevidual ind >>= \a -> change3 [(1, 100.2)] a >> return a
151-- cb <-lift $ V.freeze (vec clone)
152-- fc <- evaluate clone
153-- ce <-lift $ V.freeze (vec clone)
154-- iend <-lift $ V.freeze (vec ind)
155-- fend <- readFitness ind
156-- return (unlines ["fail", show istart,show iend,show fstart,show fend,"--"
157-- ,show fc,show cb, show ce])
158158
159159
160160 --i1 <-lift $ V.freeze (vec t)
168168
169169main = do
170170 as <- getArgs
171 let dimensionality = read (as!!0)
171 let dimensionality :: Int = read (as!!0)
172172 testCases = tail as
173173 let x :: [Word32] -> (String,MTS.Bounds,FitnessFunction s) -> MTSMonad s RunInfo
174174 x s (tfname,bounds,tf) = do
185185 ex ("f1",V.replicate dimensionality (-100,100),f1 (-450))
186186 ,ex ("f2",V.replicate dimensionality (-100,100) ,f2 (-450))
187187 ,ex ("f3",V.replicate dimensionality (-100,100),f3 390)
188 ,ex ("f4",V.replicate dimensionality (-5,5),f4 (-330))
189 ,ex ("f4_1",V.replicate dimensionality (-5,5),f4_1 (-330))
188 ,ex ("f4",V.replicate dimensionality (-5,5),f4 dimensionality (-330))
189 ,ex ("f4_mut",V.replicate dimensionality (-5,5),f4_mut dimensionality (-330))
190190 ,ex ("f5" ,V.replicate dimensionality (-600,600),f5 (-180))
191#ifndef GHC_7
191192 ,ex (listAdapter $ TF.rastrigin6 dimensionality)
192193 ,ex (listAdapter $ TF.rotateTF 12 $ TF.rastrigin6 dimensionality)
194#endif
193195 ]
194196 inDirectory "results/" $
195197 withPool 4 $ \p -> parallel_ p . concat . map snd . filter (\(n,_) -> n`elem`testCases) $ ops
Utils.hs
(3 / 8)
  
33-- yet belong anywhere
44--
55module Utils where
6import qualified Data.Vector.Mutable as M
6import qualified Data.Vector.Unboxed.Mutable as M
7import qualified Data.Vector.Mutable as MB
78import qualified Data.Vector as V
89import Control.Monad.ST
910
1011modify i op x = M.read x i >>= M.write x i . op
11
12testVec :: (Num a) => (forall s. V.MVector s a -> ST s ()) -> V.Vector a
13testVec op = V.create $ do
14 v <- M.new 10
15 M.set v 0
16 op v
17 return v
12modifyB i op x = MB.read x i >>= MB.write x i . op
1813
1914type Range a = (a,a)