spaceprobe (empty) → 0.0.0
raw patch · 9 files changed
+971/−0 lines, 9 filesdep +QuickCheckdep +basedep +clocksetup-changed
Dependencies added: QuickCheck, base, clock, containers, criterion, erf, mtl, spaceprobe, test-framework, test-framework-quickcheck2
Files
- Control/SpaceProbe.hs +51/−0
- Control/SpaceProbe/Internal/Optimize.hs +225/−0
- Control/SpaceProbe/Internal/Probe.hs +249/−0
- LICENSE +12/−0
- README.markdown +21/−0
- Setup.hs +3/−0
- benchmarks/Benchmarks.hs +171/−0
- spaceprobe.cabal +69/−0
- tests/Tests.hs +170/−0
+ Control/SpaceProbe.hs view
@@ -0,0 +1,51 @@+-- | +-- Module : Control.SpaceProbe.Probe +-- Copyright : Sean Burton 2015 +-- License : BSD3 +-- +-- Maintainer : burton.seanr@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- An applicative combinator library for parameter optimization designed +-- to perform well over high-dimensional and/or discontinuous search spaces, +-- using Monte-Carlo Tree Search with several enhancements. + +module Control.SpaceProbe ( + P.Probe(..), + P.newPartition, + -- * Floating search spaces + P.distribution, + P.exponential, + P.normal, + P.uniform, + -- * Integral search spaces + P.intDistribution, + P.exponentialInt, + P.normalInt, + P.uniformInt, + -- * Discrete search spaces + P.constants, + P.permute, + P.sizedSublist, + P.sizedWithReplacement, + P.sublist, + P.withReplacement,+ -- * Optimization + O.maximize, + O.minimize, + -- * Monadic Optimization + O.maximizeM, + O.minimizeM, + -- * Optimization in IO + O.maximizeIO, + O.minimizeIO, + -- * Optimization output processing + O.highestYet, + O.lowestYet, + O.evaluateForusecs +) where + +import qualified Control.SpaceProbe.Internal.Optimize as O+import qualified Control.SpaceProbe.Internal.Probe as P+
+ Control/SpaceProbe/Internal/Optimize.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module : Control.SpaceProbe.Probe+-- Copyright : Sean Burton 2015+-- License : BSD3+-- +-- Maintainer : burton.seanr@gmail.com+-- Stability : experimental+-- Portability : unknown+-- +-- An applicative combinator library for parameter optimization designed +-- to perform well over high-dimensional and/or discontinuous search spaces,+-- using Monte-Carlo Tree Search with several enhancements.++module Control.SpaceProbe.Internal.Optimize where ++import Control.Monad (liftM)+import Control.Monad.Identity (runIdentity, Identity(..))+import Control.SpaceProbe.Internal.Probe+import Control.Exception (evaluate)+import Data.Int (Int16, Int64)+import Data.Tree (Tree(..))+import System.Clock (getTime, Clock(Monotonic), TimeSpec(..))+import System.IO.Unsafe (unsafeInterleaveIO)+import System.Timeout (timeout)++data SearchNode t = SearchNode {+ _value :: t,+ _mean :: !Float,+ _maximum :: !Float,+ _playouts :: !Int64,+ _numchildren :: !Int16,+ _exploredChildren :: !Int16+} deriving (Show)++data SearchTree t = SearchTree {+ _node :: !(SearchNode (Maybe t)),+ _children :: ![SearchTree t]+} deriving (Show)++searchTree :: Probe t -> SearchTree t+searchTree (Probe x f r) = go0 x+ where newNode y n = SearchNode y 0 (-inf) 0 n 0 where inf = 1 / 0+ newTree v xs = + SearchTree (newNode v (fromIntegral $ length xs)) xs+ makeTree s = newTree $ r s+ go0 s = makeTree s . map go1 $ f s + go1 t = case t of+ Node s [] -> go0 s + Node s ys -> makeTree s $ map go1 ys ++i2f :: Integral a => a -> Float+i2f = fromIntegral++update :: SearchNode t -> Float -> Bool -> (SearchNode t, Bool)+update (SearchNode x mu m n k k') e b = + (SearchNode x mu' m' n' k k'', k'' == k)+ where n' = n + 1+ m' = max m e+ mu' = mu + (e - mu) / i2f n'+ k'' = if b then k' + 1 else k'++ucb :: Int64 -> Float -> Float -> SearchNode t -> Float+ucb n_total l u (SearchNode _ mu m n k k')+ | n == 0 = -1.0 / 0+ | k' == k = 1+ | otherwise = negate $ normalize (0.8 * mu + 0.2 * m) + + sqrt (2 * log (i2f n_total) / i2f n)+ where normalize x+ | u == l = 0.5+ | otherwise = (x - l) / (u - l)++insertOn :: Ord b => (a -> b) -> a -> [a] -> [a]+insertOn f x = go+ where go [] = [x]+ go ys@(y:ys') + | f x > f y = y : go ys'+ | otherwise = x : ys++insert :: Float -> + Float -> + Int64 ->+ (SearchTree a) -> + [SearchTree a] -> + [SearchTree a]+insert l u n = insertOn (ucb (n + 1) l u . _node)++data PlayoutResult t = PlayoutResult {+ _tree :: !(SearchTree t),+ _input :: !t,+ _eval :: !Float,+ _min :: !Float,+ _max :: !Float,+ _fullyExplored :: !Bool+}++playoutM :: Monad m =>+ (t -> m Float) ->+ Float -> + Float ->+ SearchTree t ->+ m (PlayoutResult t)+playoutM eval = go+ where go !l !u (SearchTree !a !xs) = + case (_value a, xs) of+ (Nothing, []) -> error "playoutIO"+ (Just x, _) -> if null xs || _playouts a == 0+ then do e <- eval x+ let (a', b) = update a e False+ return $ PlayoutResult {+ _tree = + SearchTree a' xs,+ _input = x,+ _eval = e,+ _min = min l e,+ _max = max u e,+ _fullyExplored = b+ }+ else recur+ (Nothing, _) -> recur+ where recur = let (y:ys) = xs+ in do r <- go l u y+ let zs = insert (_min r)+ (_max r)+ (_playouts a)+ (_tree r) ys+ let (a', b) = update a (_eval r) + (_fullyExplored r)+ return $ r{_tree = SearchTree a' zs, + _fullyExplored = b}+{-# INLINE playoutM #-}++maximize_ :: Monad m => + (m [(t, Float)] -> m [(t, Float)]) ->+ (t -> m Float) ->+ Probe t ->+ m [(t, Float)]+maximize_ rest eval = go inf (-inf) . searchTree+ where inf = 1 / 0 :: Float+ go l u t = do PlayoutResult t' x e l' u' b <- playoutM eval l u t+ if b || (u' == inf)+ then return [(x, e)]+ else do xs <- rest $ go l' u' t'+ return $ (x, e) : xs+{-# INLINE maximize_ #-}++-- | Fairly self-explanatory. Maximize the objective function @eval@ over the+-- given @Probe@. Keeps lazily generating samples until it explores the whole+-- search space so you almost certainly want to apply some cut-off criterion. +maximize :: (t -> Float) -> Probe t -> [(t, Float)]+maximize eval = runIdentity . maximize_ id (Identity . eval)++-- | The opposite of maximize. +-- +-- @minimize eval = map (fmap negate) . maximize (negate . eval)@+minimize :: (t -> Float) -> Probe t -> [(t, Float)]+minimize eval = map (fmap negate) . maximize (negate . eval)++type OptimizeM m t = (t -> m Float) -> Probe t -> m [(t, Float)]++invert :: Monad m => OptimizeM m t -> OptimizeM m t+invert maximize' eval = liftM (map $ fmap negate) . + maximize' (liftM negate . eval)++-- | Maximize in the given monad. The underlying bind operator must be lazy if+-- you want to generate the result list incrementally. +maximizeM :: Monad m => (t -> m Float) -> Probe t -> m [(t, Float)]+maximizeM eval = maximize_ id eval++-- | The opposite of maximizeM+minimizeM :: Monad m => (t -> m Float) -> Probe t -> m [(t, Float)]+minimizeM = invert maximizeM++-- | The equivalent of maximize, but running in the IO Monad. Generates the +-- output list lazily.+maximizeIO :: (t -> IO Float) -> Probe t -> IO [(t, Float)]+maximizeIO eval = maximize_ unsafeInterleaveIO eval++-- | The opposite of maximizeIO+minimizeIO :: (t -> IO Float) -> Probe t -> IO [(t, Float)]+minimizeIO = invert maximizeIO++highestYet_ :: Ord b => (a -> b) -> [a] -> [a]+highestYet_ _ [] = []+highestYet_ f (x:xs) = x : go (f x) xs+ where go _ [] = []+ go k (y:ys)+ | m > k = y : go m ys+ | otherwise = go k ys+ where m = f y++lowestYet_ :: (Num b, Ord b) => (a -> b) -> [a] -> [a]+lowestYet_ f = highestYet_ (negate . f)++-- | Preserves only those elements @(_, b)@ for which @b@ is higher than for+-- all previous previous values in the list. Designed for use with +-- maximization+highestYet ::[(a, Float)] -> [(a, Float)]+highestYet = highestYet_ snd++-- | Preserves only those elements @(_, b)@ for which @b@ is lower than for all+-- previous values in the list. Designed for use with minimization.+-- +-- @lowestYet xs == map (fmap negate) . highestYet . map (fmap negate)@+lowestYet :: [(a, Float)] -> [(a, Float)]+lowestYet = lowestYet_ snd++getTimeInUsecs :: IO Int64 +getTimeInUsecs = do TimeSpec s n <- getTime Monotonic + return $ 1000000 * s + n `div` 1000 ++-- | Take the largest prefix of @xs@ which can be evaluated within @dt@ +-- microseconds.+evaluateForusecs :: Int -> [a] -> IO [a] +evaluateForusecs dt xs = do{t <- getTimeInUsecs; go t xs} + where go !_ ![] = return [] + go t (x:ys) = + do t' <- getTimeInUsecs + m <- timeout (fromIntegral . max 0 $ t + fromIntegral dt - t') $ + evaluate x + case m of + Nothing -> return [] + Just y -> do zs <- unsafeInterleaveIO $ go t ys+ return $ y:zs+
+ Control/SpaceProbe/Internal/Probe.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | +-- Module : Control.SpaceProbe.Probe +-- Copyright : Sean Burton 2015 +-- License : BSD3 +-- +-- Maintainer : burton.seanr@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- An applicative combinator library for parameter optimization designed +-- to perform well over high-dimensional and/or discontinuous search spaces, +-- using Monte-Carlo Tree Search with several enhancements. ++module Control.SpaceProbe.Internal.Probe where++import Control.Applicative (+ Alternative, + Applicative, + empty,+ pure, + (<*>), + (<|>),+ (<$>))+import Data.Number.Erf (Erf, InvErf, invnormcdf, normcdf)+import Data.Tree(Forest, Tree(..))++-- | The main data structure for this module; it describes +-- a search space and an associated exploration strategy.+-- +-- This type is an instance of the following classes: +-- +-- * 'Functor' which does the obvious thing.+-- +-- * 'Applicative', which allows us to combine multiple search spaces and +-- optimize over them simultaneously.+--+-- * 'Alternative', which allows us to optimize over the disjoint union of +-- two search spaces.+data Probe t = forall s . Probe {+ _initial :: s, + -- ^ The initial search space.+ _partition :: s -> Forest s,+ -- ^ A function to partition a given search space and+ -- remove its representative from contention+ _draw :: s -> Maybe t+ -- ^ Try to choose a 'representative element' from the search space.+ -- For example, if the search space were the interval [0, 10),+ -- a suitable representative might be the midpoint 5. After the + -- initial search space has been recursively partitioned as deeply as+ -- possible, every possible element should be the representative of exactly + -- one subspace.+}++-- | generate a partition function to be use in the construction of custom+-- Probes. +newPartition :: (s -> [s]) -> (s -> Forest s)+newPartition f = map (\x -> Node x []) . f++tipConcatMap :: (a -> Forest a) -> Tree a -> Tree a+tipConcatMap f (Node x []) = Node x $ f x+tipConcatMap f (Node x xs) = Node x $+ case xs of + [] -> f x+ _ -> map (tipConcatMap f) xs++instance Functor Probe where+ fmap g (Probe x f d) = Probe x f $ fmap g . d ++instance Applicative Probe where+ pure x = Probe x (const []) (Just . id)+ (Probe x0 f0 d0) <*> (Probe x1 f1 d1) = Probe (x0, x1) f d+ where f (s0, s1) = map (tipConcatMap (t1 . fst)) $ t0 s1 + where t0 s1' = [do {s0' <- t; return (s0', s1')} | t <- f0 s0]+ t1 s0' = [do {s1' <- t; return (s0', s1')} | t <- f1 s1]+ d (s0, s1) = d0 s0 <*> d1 s1 ++instance Alternative Probe where+ empty = Probe [] (const []) undefined+ (Probe x0 f0 d0) <|> (Probe x1 f1 d1) = + Probe {+ _initial = Nothing,+ _partition = partition, + _draw = draw+ } where partition Nothing = map (flip Node [] . Just) [Left x0, Right x1]+ partition (Just (Left x)) = map (fmap $ Just . Left) $ f0 x+ partition (Just (Right x)) = map (fmap $ Just . Right) $ f1 x+ draw m = m >>= either d0 d1++ave :: Num a => (a -> a -> a) -> a -> a -> a+ave divide a b = a + (b - a) `divide` 2++floatAve :: Floating a => a -> a -> a+floatAve = ave (/)++intAve :: Integral a => a -> a -> a+intAve = ave quot++-- | Uses inverse transform sampling to draw from a probability distribution +-- given the associated inverse cumulative distribution function.+distribution :: Floating b => (b -> a) -> Probe a+distribution invcdf = invcdf <$> uniform 0 1 ++-- | Sample from the exponential distribution with given mean. Useful for+-- constants which are potentially unbounded but probably small.+exponential :: Floating a => a -> Probe a +exponential mu = distribution $ \x -> mu * log(1 / (1 - x)) ++-- | Sample from the normal distribution with given mean and standard +-- deviation+normal :: (Eq a, InvErf a) => a -> a -> Probe a+normal mu sigma = (\x -> x * sigma + mu) <$> distribution invnormcdf++-- | Sample uniformly from the interval [a, b). +uniform :: Floating a => a -> a -> Probe a +uniform a b = Probe {+ _initial = (a, floatAve a b, b),+ _partition = newPartition $+ \(a', x, b') -> [(a', floatAve a' x, x), + (x, floatAve x b', b')],+ _draw = \(_, x, _) -> Just x+}++bisect :: (Integral a, Num b, Ord b) => (a -> b) -> b -> a -> a -> a+bisect f y a b = go (intAve a b) a b+ where go u a' b'+ | b' <= a' = u+ | otherwise = let v = intAve a' b' + z = f v+ in case compare z y of + LT -> go v (v + 1) b' + EQ -> v + GT -> go v a' v++-- | Approximately sample from a probability distribution over the range+-- [a, b). Relies on splitting the range into regions of approximately +-- equal probability so will be less accurate for small ranges +-- or highly unequal distributions.+intDistribution :: (Integral a, Floating b, Ord b) => + (a -> b) ->+ a -> + a ->+ Probe a+intDistribution cdf a b = Probe {+ _initial = (a, mid a b, b),+ _partition = newPartition partition,+ _draw = \(_, x, _) -> Just x+} where mid a' b' = bisect cdf (floatAve (cdf a') (cdf b')) a' b'+ partition (a', x, b') = + filter (\(u, _, v) -> v > u) + [(a', mid a' x, x),+ (x + 1, mid (x + 1) b', b')]++exponentialInt :: (Bounded a, Integral a) => Float -> Probe a+exponentialInt mu = + intDistribution (\x -> 1 - exp (-fromIntegral x / mu)) 0 maxBound++-- | Sample from an approximate normal distribution with given mean and +-- standard deviation. May fail if a very large mean and/or standard deviation +-- is given.+normalInt :: (Bounded a, Integral a) => Float -> Float -> Probe a+normalInt mu sigma = + intDistribution (\x -> normcdf $ (fromIntegral x - mu) / sigma) + (round (mu - bound) + 1)+ (round (mu + bound) - 1) + where bound = 6 * sigma++-- | Sample uniformly from the interval [a, b).+uniformInt :: (Eq a, Integral a) => a -> a -> Probe a+uniformInt a b = Probe {+ _initial = (a, intAve a b, b),+ _partition = newPartition partition',+ _draw = \(_, x, _) -> Just x+} where partition' (a', x, b') =+ filter (\(u, _, v) -> v > u) [(a', intAve a' x, x),+ (x + 1, intAve (x + 1) b', b')]++-- | Choose from a list of constants with equal probability.+constants :: [a] -> Probe a+constants xs = Probe Nothing partition id+ where partition Nothing = map (flip Node [] . Just) xs+ partition _ = []++permutation :: [Integer] -> [a] -> Integer -> [a]+permutation _ [] _ = []+permutation [] _ _ = error "permutation: factorial list too short"+permutation (u:facs) xs n = y : permutation facs ys r+ where (q, r) = quotRem n u+ (y:ys) = let (us, v:vs) = splitAt (fromIntegral q) xs + in v:us ++ vs ++-- | Samples uniformly from permutations of @xs@. Makes the assumption that +-- permutations which are lexicographically close are likely to have similar+-- fitness.+permute :: [a] -> Probe [a]+permute xs = permutation facs xs <$> uniformInt 0 u + where (u:facs) = + reverse $ scanl (*) 1 [1..fromIntegral $ length xs] :: [Integer]++extractElem :: [a] -> [(a, [a])]+extractElem [] = []+extractElem (x:xs) = (x, xs) : map (\(y, ys) -> (y, x:ys)) (extractElem xs)++-- | Samples sublists of @xs@ of size @k@. The order of elements in @xs@ is +-- irrelevant.+sizedSublist :: Int -> [a] -> Probe [a]+sizedSublist k xs = Probe {+ _initial = (0, xs, []),+ _partition = newPartition $ + \(n, xs', ys) -> + if n == k + then [] + else [(n + 1, zs, x:ys) | (x, zs) <- extractElem xs'],+ _draw = \(m, xs', ys) -> Just $ ys ++ take (k - m) xs' +}++-- | Samples sublists of @xs@ of size @k@ with replacement. +-- The order of elements in @xs@ is irrelevant.+sizedWithReplacement :: Int -> [a] -> Probe [a]+sizedWithReplacement k xs = Probe {+ _initial = (0, []),+ _partition = newPartition $ \(n, ys) -> if n == k + then [] + else [(n + 1, x:ys) | x <- xs],+ _draw = Just . snd +}++-- | Samples progressively larger sublists of @xs@. More 'important' elements+-- (those which are likely to affect the fitness of a sample more) should+-- ideally be placed closest to the start of @xs@.+sublist :: [a] -> Probe [a]+sublist xs = Probe {+ _initial = (xs, []),+ _partition = newPartition $ \(xs', ys) ->+ case xs' of + [] -> []+ (x:xs'') -> [(xs'', x:ys), (xs'', ys)],+ _draw = Just . reverse . snd +}++-- | Samples progressively larger sublists of @xs@ with replacement. The order+-- of elements in @xs@ is irrelevant.+withReplacement :: [a] -> Probe [a]+withReplacement xs = Probe {+ _initial = [],+ _partition = newPartition $ \ys -> map (:ys) xs,+ _draw = Just . id+}
+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2015, Sean Burton +All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,21 @@+# This is spaceprobe!++Spaceprobe is an applicative combinator library for parameter optimization +based on Monte-Carlo Tree Search with several enhancements. It is designed+to be easy to use, and to work robustly on discontinuous and/or +high-dimensional search spaces.++# Contribution++I'm more than happy to recieve bug reports, fixes, improved documentation, +feature enhancements, and other improvements.++Please report bugs using the [github issue tracker](https://github.com/SeanRBurton/spaceprobe/issues/).++Authors +-------++This library is written and maintained by Sean Burton. You can contact me at +<burton.seanr@gmail.com>.++
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ benchmarks/Benchmarks.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE BangPatterns #-}++import Control.Applicative+import Control.SpaceProbe+import Criterion.Main++dsq :: Float -> Float -> Float +dsq x y = x ** 2 + y ** 2++dist :: Float -> Float -> Float +dist x y = sqrt $ dsq x y++sinsq :: Float -> Float+sinsq = (**2) . sin++cubic :: Float -> Float +cubic x = abs $ x ** 3++ackley :: (Float, Float) -> Float+ackley (x, y) = -20 * exp (-0.2 * sqrt (0.5 * dsq x y)) -+ exp(0.5 * (f x + f y)) + exp 1 + 20+ where f z = cos(2 * pi * z)++sphere :: [Float] -> Float+sphere = sum . map (**2)++rosenbrock :: [Float] -> Float+rosenbrock xs = + sum $ zipWith (\x y -> 100 * (x - y ** 2) ** 2 + (y - 1) ** 2) (tail xs ) xs++beale :: (Float, Float) -> Float+beale (x, y) = (1.5 - x + x * y) ** 2 + + (2.25 - x + x * y ** 2) ** 2 + + (2.625 - x + x * y ** 3) ** 2++goldsteinPrice :: (Float, Float) -> Float+goldsteinPrice (x, y) = + (1 + (x + y + 1) ** 2 * (19 - 14 * x + 3 * x ** 2 - 14 * y + + 6 * x * y + 3 * y ** 2)) * + (30 + (2 * x - 3 * y) ** 2 * + (18 - 32 * x + 12 * x ** 2 + 48 * y - 36 * x * y + 27 * y ** 2))++booth :: (Float, Float) -> Float+booth (x, y) = (x + 2 * y - 7) ** 2 + (2 * x + y - 5) ** 2++bukin :: (Float, Float) -> Float +bukin (x, y) = 100 * (sqrt . abs $ y - 0.01 * x ** 2) + 0.01 * abs (x + 10)++matyas :: (Float, Float) -> Float+matyas (x, y) = 0.26 * (x ** 2 + y ** 2) - 0.48 * x * y++levi :: (Float, Float) -> Float+levi (x, y) = sinsq(2 * pi * x) + (x - 1) ** 2 * (1 + sinsq(3 * pi * y)) ++ (y - 1) ** 2 * (1 + sinsq(2 * pi * y)) + +camel :: (Float, Float) -> Float +camel (x, y) = 2 * x ** 2 - 1.05 * x ** 4 + x ** 6 / 6 + x * y + y ** 2++easom :: (Float, Float) -> Float+easom (x, y) = -cos x * cos y * exp(-((x - pi) ** 2 + (y - pi) ** 2))++crossInTray :: (Float, Float) -> Float+crossInTray (x, y) = -0.0001 * (1 + abs (sin x * sin y * exp (abs u))) ** 0.1+ where u = 100 - dist x y / pi++eggHolder :: (Float, Float) -> Float+eggHolder (x, y) = -(y + 47) * sin(sqrt . abs $ y + x / 2 + 47) - + x * sin(sqrt . abs $ x - (y + 47))++table :: (Float, Float) -> Float+table (x, y) = negate . abs $ sin x * cos y * exp(abs $ 1 - dist x y / pi)++mcCormick :: (Float, Float) -> Float+mcCormick (x, y) = sin(x + y) + (x - y) ** 2 - 1.5 * x + 2.5 * y + 1++schafferN2 :: (Float, Float) -> Float+schafferN2 (x, y) = + 0.5 + (sinsq(x**2 - y**2) - 0.5) / (1 + 0.001 * dsq x y) ** 2++schafferN4 :: (Float, Float) -> Float+schafferN4 (x, y) =+ 0.5 + (cossq(sin(abs $ x ** 2 - y ** 2)) - 0.5) / (1 + 0.001 * dsq x y) ** 2+ where cossq = (**2) . cos++styblinskiTang :: [Float] -> Float+styblinskiTang xs = sum [x ** 4 - 16 * x ** 2 + 5 * x | x <- xs] / 2++simionescu :: (Float, Float) -> Float+simionescu (x, y)+ | dsq x y <= (1 + 0.2 * cos(8 * atan(x / y))) ** 2 = 0.1 * x * y + | otherwise = infIO+ where infIO = 1.0 / 0++replicateA :: Applicative f => Int -> f a -> f [a]+replicateA k a = go k (pure []) + where go !0 !acc = acc+ go m acc = go (m - 1) $ (:) <$> a <*> acc++takeWhileInclusive :: (a -> Bool) -> [a] -> [a]+takeWhileInclusive p xs = a ++ take 1 b+ where (a, b) = span p xs++farFrom :: Float -> Float -> Bool+farFrom 0 y = abs(y) >= 0.01+farFrom x y = abs(y - x) / abs(x) >= 0.01++runBenchmark :: Show a => (a -> Float) -> Probe a -> Float -> IO (a, Float)+runBenchmark f p x = fmap (last . lowestYet) .+ evaluateForusecs 700000 . + takeWhileInclusive (farFrom x . snd) $ + minimize f p++square :: Float -> Float -> Probe (Float, Float)+square l u = (,) <$> uniform l u <*> uniform l u++centeredSquare :: Float -> Probe (Float, Float)+centeredSquare x = square (-x) x++perturbedSquare :: Float -> Probe (Float, Float)+perturbedSquare x = square (-x * 0.97) (x * 0.995)++perturbedHypercube :: Int -> Float -> Probe [Float]+perturbedHypercube k x = hypercube k (-x * 0.97) (x * 0.995)++hypercube :: Int -> Float -> Float -> Probe [Float]+hypercube k l u = replicateA k $ uniform l u++main :: IO ()+main = defaultMain [+ bgroup "all" [ bench "cubic" . nfIO $ runBenchmark cubic (normal 10 50) 0,+ bench "ackley" . nfIO $ + runBenchmark ackley (perturbedSquare 5) 0,+ bench "sphere" . nfIO $+ runBenchmark sphere (perturbedHypercube 10 10) 0, + bench "rosenbrock" . nfIO $ + runBenchmark rosenbrock (hypercube 3 (-100) 100) 0,+ bench "beale" . nfIO $ + runBenchmark beale (centeredSquare 4.5) 0,+ bench "goldsteinPrice" . nfIO $ + runBenchmark goldsteinPrice (centeredSquare 2) 3,+ bench "booth" . nfIO $ + runBenchmark booth (centeredSquare 10) 0,+ bench "bukin" . nfIO $ + runBenchmark bukin ((,) <$> uniform (-15) (-5) <*> + uniform (-3) 3) 0,+ bench "matyas" . nfIO $ + runBenchmark matyas (perturbedSquare 10) 0,+ bench "levi" . nfIO $ + runBenchmark levi (centeredSquare 10) 0,+ bench "camel" . nfIO $ + runBenchmark camel (centeredSquare 5) 0,+ bench "easom" . nfIO $ + runBenchmark easom (centeredSquare 100) (-1),+ bench "crossInTray" . nfIO $ + runBenchmark crossInTray (centeredSquare 10) (-2.06261),+ bench "eggHolder" . nfIO $ + runBenchmark eggHolder (centeredSquare 512) (-959.6407),+ bench "table" . nfIO $ + runBenchmark table (centeredSquare 10) (-19.2085),+ bench "mcCormick" . nfIO $ + runBenchmark mcCormick ((,) <$> uniform (-1.5) 4 <*> + uniform (-3) 4) 0,+ bench "schafferN2" . nfIO $ + runBenchmark schafferN2 (perturbedSquare 100) 0,+ bench "schafferN4" . nfIO $ + runBenchmark schafferN4 (centeredSquare 100) 0.292579,+ bench "styblinskiTang" . nfIO $ + runBenchmark styblinskiTang (hypercube 5 (-5) 5) + (-5 * 39.16617),+ bench "simionescu" . nfIO $ + runBenchmark simionescu (centeredSquare 1.25) (-0.072)]]
+ spaceprobe.cabal view
@@ -0,0 +1,69 @@+name: spaceprobe+version: 0.0.0+license: BSD3+license-file: LICENSE+category: Optimization+author: Sean Burton <burton.seanr@gmail.com> +maintainer: Sean Burton <burton.seanr@gmail.com>+stability: experimental+tested-with: GHC == 7.6+synopsis: Optimization over arbitrary search spaces +cabal-version: >= 1.8+homepage: https://github.com/SeanRBurton/spaceprobe+bug-reports: https://github.com/SeanRBurton/spaceprobe/issues+build-type: Simple+description:+ A parameter optimization library, designed for optimizing over + arbitrary search spaces. It is particularly well suited for discontinuous+ and/or high-dimensional search spaces.+extra-source-files:+ README.markdown+ benchmarks/*.hs+ tests/*.hs++library+ build-depends: base >= 2 && < 4,+ containers,+ clock,+ erf,+ mtl+ exposed-modules: Control.SpaceProbe+ Control.SpaceProbe.Internal.Probe+ Control.SpaceProbe.Internal.Optimize+ ghc-options: -O3 -funbox-strict-fields -fllvm -Wall++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests .+ main-is: Tests.hs++ ghc-options:+ -Wall++ build-depends:+ base >=2 && <4,+ QuickCheck >= 2.7,+ test-framework >= 0.8.0.2,+ test-framework-quickcheck2 >= 0.3.0.3,+ clock,+ erf,+ containers,+ mtl++benchmark benchmarks+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: Benchmarks.hs++ ghc-options: -O2 -Wall++ build-depends:+ base >=2 && <4,+ criterion,+ spaceprobe++ +source-repository head+ type: git+ location: https://github.com/SeanRBurton/spaceprobe+
+ tests/Tests.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleInstances #-}++import Control.Exception (assert)+import Control.Monad.Identity (Identity(..), runIdentity)+import Control.SpaceProbe+import Control.SpaceProbe.Internal.Optimize+import Data.List (sort)+import Data.Maybe (isJust)+import Test.Framework (Test, defaultMain)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck++validateSearchTree :: SearchTree t -> Bool+validateSearchTree (SearchTree node xs)+ = assert (n == 0 || mu <= m) $+ assert (not $ isNaN mu) $+ assert (not $ isNaN m) $+ assert (minimum [n, fromIntegral k, fromIntegral k'] >= 0) $+ assert (fromIntegral k' <= n) $+ assert (fromIntegral k == length xs) $+ assert (fromIntegral k' == length explored) $+ assert (n == sum playouts + if isJust x && n /= 0 then 1 else 0) $+ assert (null xs || m >= maximum maxes) $+ if n == 0 + then True + else assert (all validateSearchTree xs)+ True + where SearchNode x mu m n k k' = node+ nodes = map _node xs+ fullyExplored (SearchNode _ _ _ n_ k_ k'_) = k_ == k'_ && (n_ /= 0)+ explored = filter fullyExplored nodes+ maxes = map _maximum nodes+ playouts = map _playouts nodes++playout :: (t -> Float) -> Float -> Float -> SearchTree t -> PlayoutResult t+playout eval l u = runIdentity . playoutM (Identity . eval) l u++maximizationTree :: (t -> Float) -> Probe t -> Int -> SearchTree t+maximizationTree eval p k = go k inf (-inf) $ searchTree p+ where inf = 1 / 0 :: Float + go 0 _ _ t = t+ go k' l u t+ | b || (u' == inf) = t'+ | otherwise = go (k' - 1) l' u' t'+ where PlayoutResult t' _ _ l' u' b = playout eval l u t ++data Eval a = Eval String (a -> Float)++instance Show (Eval a) where+ show (Eval s _) = s++floatEvals :: [Eval Float]+floatEvals = [+ Eval "square" $ \x -> x ** 2,+ Eval "poly" $ \x -> x ** 3 + 5 * x ** 2 + 0.01 * x ** 7,+ Eval "case" $ \x -> if x < 2 then x else x + 4,+ Eval "sin" sin,+ Eval "floor log" $ \x -> (x - fromIntegral (floor x :: Integer)) + 5 + + log (2 + abs x),+ Eval "sub" $ \x -> x - 2,+ Eval "exp" exp,+ Eval "const" $ const 0, + Eval "sqrt" $ \x -> abs x ** 0.5]++intEvals :: [Eval Int]+intEvals = [Eval s (f . fromIntegral) | Eval s f <- floatEvals]++instance Arbitrary (Eval Float) where+ arbitrary = oneof $ map return floatEvals++instance Arbitrary (Eval Int) where+ arbitrary = oneof $ map return intEvals++validProbe :: Probe t -> (t -> Float) -> Int -> Bool+validProbe p eval k = validateSearchTree $ maximizationTree eval p k++data DefaultProbe t = Exponential t | Normal t t+ | Uniform t t deriving (Show)++makeFloatProbe :: DefaultProbe Float -> Probe Float +makeFloatProbe (Exponential mu) = exponential mu+makeFloatProbe (Normal mu sigma) = normal mu sigma+makeFloatProbe (Uniform a b) = uniform a b++makeIntProbe :: DefaultProbe Int -> Probe Int+makeIntProbe (Exponential mu) = exponentialInt (fromIntegral mu)+makeIntProbe (Normal mu sigma) = + normalInt (fromIntegral mu) $ fromIntegral sigma +makeIntProbe (Uniform a b) = uniformInt a b++arbitraryExponential :: (Arbitrary t, Num t, Ord t) => Gen (DefaultProbe t)+arbitraryExponential = + do (NonNegative mu) <- arbitrary+ return $ Exponential mu ++arbitraryNormal :: (Arbitrary t, Num t, Ord t) => Gen (DefaultProbe t)+arbitraryNormal = + do mu <- arbitrary+ (NonNegative sigma) <- arbitrary+ return $ Normal mu sigma ++arbitraryUniform :: (Arbitrary t, Num t, Ord t) => Gen (DefaultProbe t)+arbitraryUniform = + do a <- arbitrary+ (NonNegative x) <- arbitrary+ return $ Uniform a x ++instance (Arbitrary t, Num t, Ord t) => Arbitrary (DefaultProbe t) where+ arbitrary = oneof [arbitraryExponential, arbitraryNormal, arbitraryUniform]++prop_ValidFloat :: DefaultProbe Float -> Eval Float -> NonNegative Int -> Bool+prop_ValidFloat p (Eval _ eval) (NonNegative k) =+ validProbe (makeFloatProbe p) eval k++prop_ValidInt :: DefaultProbe Int -> Eval Int -> NonNegative Int -> Bool+prop_ValidInt p (Eval _ eval) (NonNegative k) = + validProbe (makeIntProbe p) eval k++prop_ExponentialIntBounds :: NonNegative Float -> Positive Int -> Bool+prop_ExponentialIntBounds (NonNegative mu) (Positive k) = + all (>=(0 :: Int)) .+ take k .+ map fst .+ maximize (const 0) $+ exponentialInt mu++prop_UniformIntExhaustive :: Int -> Positive Int -> Property+prop_UniformIntExhaustive a (Positive x) = + sort (map fst . maximize (const 0) $ uniformInt a b) === [a..b-1]+ where b = a + x++prop_UniformBounds :: Float -> Positive Float -> Positive Int -> Bool+prop_UniformBounds a (Positive x) (Positive k) = + all (\y -> a <= y && y < b) . + take k . + map fst . + maximize (const 0) $ + uniform a b+ where b = a + x++prop_ExponentialBounds :: NonNegative Float -> Positive Int -> Bool+prop_ExponentialBounds (NonNegative mu) (Positive k) = + all (>=0) .+ take k . + map fst .+ maximize (const 0) $+ exponential mu ++strictMonotone :: Ord a => [a] -> Bool+strictMonotone [] = True+strictMonotone xs = all id $ zipWith (>) xs (tail xs) ++prop_LowestYet :: [(Int, Float)] -> Bool+prop_LowestYet = strictMonotone . map snd . lowestYet++prop_HighestYet :: [(Int, Float)] -> Bool+prop_HighestYet = strictMonotone . reverse . map snd . highestYet++tests :: [Test]+tests = [testProperty "prop_ValidFloat" prop_ValidFloat,+ testProperty "prop_ValidInt" prop_ValidInt,+ testProperty "prop_UniformIntExhaustive" prop_UniformIntExhaustive,+ testProperty "prop_UniformBounds" prop_UniformBounds,+ testProperty "prop_ExponentialBounds" prop_ExponentialBounds,+ testProperty "prop_LowestYet" prop_LowestYet,+ testProperty "prop_HighestYet" prop_HighestYet,+ testProperty "prop_ExponentialIntBounds" prop_ExponentialIntBounds] ++main :: IO ()+main = defaultMain tests