module Numeric.Optimization.Algorithms.CMAES (
run, Config(..), defaultConfig,
minimize, minimizeIO,
minimizeT, minimizeTIO,
minimizeG, minimizeGIO,
)where
import Control.Monad hiding (forM_, mapM)
import qualified Control.Monad.State as State
import Data.Data
import Data.Generics
import Data.List (isPrefixOf)
import Data.Maybe
import Data.Foldable
import Data.Traversable
import System.IO
import System.Process
import Prelude hiding (concat, mapM, sum)
import Paths_cmaes
data Config tgt = Config
{ funcIO :: tgt -> IO Double
, projection :: tgt -> [Double]
, embedding :: [Double] -> tgt
, initXs :: [Double]
, sigma0 :: Double
, scaling :: Maybe [Double]
, typicalXs :: Maybe [Double]
, tolFacUpX :: Maybe Double
, tolUpSigma :: Maybe Double
, tolFun :: Maybe Double
, tolStagnation :: Maybe Int
, tolX :: Maybe Double
, verbose :: Bool
}
defaultConfig :: Config a
defaultConfig = Config
{ funcIO = error "funcIO undefined"
, projection = error "projection undefined"
, embedding = error "embedding undefined"
, initXs = error "initXs undefined"
, sigma0 = 0.25
, scaling = Nothing
, typicalXs = Nothing
, tolFacUpX = Just 1e10
, tolUpSigma = Just 1e20
, tolFun = Just 1e-11
, tolStagnation = Nothing
, tolX = Just 1e-11
, verbose = False
}
minimize :: ([Double]-> Double) -> [Double] -> Config [Double]
minimize f xs = minimizeIO (return . f) xs
minimizeIO :: ([Double]-> IO Double) -> [Double] -> Config [Double]
minimizeIO fIO xs =
defaultConfig
{ funcIO = fIO
, initXs = xs
, projection = id
, embedding = id
}
minimizeT :: (Traversable t) => (t Double-> Double) -> t Double -> Config (t Double)
minimizeT f tx = minimizeTIO (return . f) tx
minimizeTIO :: (Traversable t) => (t Double-> IO Double) -> t Double -> Config (t Double)
minimizeTIO fIO tx =
defaultConfig
{ funcIO = fIO
, initXs = proj tx
, projection = proj
, embedding = embd
}
where
proj = toList
embd = zipTWith (\_ y -> y) tx
minimizeG :: (Data a) => (a -> Double) -> a -> Config a
minimizeG f tx = minimizeGIO (return . f) tx
minimizeGIO :: (Data a) => (a -> IO Double) -> a -> Config a
minimizeGIO fIO initA =
defaultConfig
{ funcIO = fIO
, initXs = getDoubles initA
, projection = getDoubles
, embedding = flip putDoubles initA
}
run :: forall tgt. Config tgt -> IO tgt
run Config{..} = do
fn <- getDataFileName wrapperFn
(Just hin, Just hout, _, _) <- createProcess (proc "python2" [fn])
{ std_in = CreatePipe, std_out = CreatePipe }
sendLine hin $ unwords (map show initXs)
sendLine hin $ show sigma0
sendLine hin $ show $ length options
forM_ options $ \(key, val) -> do
sendLine hin key
sendLine hin val
let loop = do
str <- recvLine hout
let ws = words str
case ws!!0 of
"a" -> do
return $ embedding $ map read $ drop 1 ws
"q" -> do
ans <- funcIO . embedding $ map read $ drop 1 ws
sendLine hin $ show ans
loop
_ -> do
fail "ohmy god"
loop
where
options :: [(String, String)]
options = concat $ map maybeToList
[ "scaling_of_variables" `is` scaling
, "typical_x" `is` typicalXs
, "tolfacupx" `is` tolFacUpX
, "tolupsigma" `is` tolUpSigma
, "tolfunhist" `is` tolFun
, "tolstagnation" `is` tolStagnation
, "tolx" `is` tolX
]
is :: Show a => String -> Maybe a -> Maybe (String,String)
is key = fmap (\val -> (key, show val))
wrapperFn, commHeader :: String
wrapperFn = "cmaes_wrapper.py"
commHeader = "<CMAES_WRAPPER_PY2HS>"
recvLine :: Handle -> IO String
recvLine h = do
str <- hGetLine h
when (verbose) $ hPutStrLn stderr str
if commHeader `isPrefixOf` str
then return $ unwords $ drop 1 $ words str
else do
recvLine h
sendLine :: Handle -> String -> IO ()
sendLine h str = do
hPutStrLn h str
hFlush h
zipTWith :: (Traversable t1, Traversable t2) => (a->b->c) -> (t1 a) -> (t2 b) -> (t1 c)
zipTWith op xs0 ys0 = State.evalState (mapM zipper xs0) (toList ys0)
where
zipper x = do
(y:ys) <- State.get
State.put ys
return (op x y)
getDoubles :: Data d => d -> [Double]
getDoubles d = reverse $ State.execState (everywhereM getter d) []
where
getter :: GenericM (State.State [Double])
getter a = do
ys <- State.get
let da = fmap (flip asTypeOf (head ys)) $ cast a
case da of
Nothing -> return a
Just d -> do
State.put $ d:ys
return a
putDoubles :: Data d => [Double] -> d -> d
putDoubles ys0 d = State.evalState (everywhereM putter d) ys0
where
putter :: GenericM (State.State [Double])
putter a = do
ys <- State.get
let ma' = (cast =<<) $ fmap (asTypeOf (head ys)) $ cast a
case ma' of
Nothing -> return a
Just a' -> do
State.put $ tail ys
return a'