HsASA-0.1: Optimize/ASA.hsc

{-# OPTIONS -ffi -fglasgow-exts #-}
-- | interface to the Adaptive Simulated Annealing algorithm.

module Optimize.ASA where 

#include "asa_usr.h"

import Optimize.Parameter
import Foreign.C.Types
import Foreign.Storable
import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Random
import Data.Array.Unboxed
import Data.Int


newtype UserOptions = UserOptions (Ptr UserOptions)
type Doubles = UArray Int Double    

data ExitCode =  NormalExit | PTempTooSmall | CTempTooSmall | CostRepeating | TooManyInvalidStates | ImmediateExit | InvalidUserInput | InvalidCostFunction | InvalidCostFunctionDeriv 
    deriving(Eq,Ord,Enum,Show,Read)


data Results x = Results {
    optimalValue :: Double,
    optimalParam :: x,
    exitCode :: ExitCode
    }


type CostFunction =  Ptr Double -> Ptr Int -> IO Double

foreign import ccall "wrapper" mkCostFunction :: CostFunction -> IO (FunPtr CostFunction)  
foreign import ccall "asa_usr.h asa_main" asa_main :: FunPtr CostFunction -> CInt -> Ptr Double -> Ptr Double -> Ptr CInt -> Ptr Double -> Ptr Double -> Ptr CInt -> CInt -> IO CInt




asa :: UserOptions     -- Options
    -> (Doubles -> IO (Maybe Double)) -- cost function 
    -> Int64           -- random number seed
    -> Maybe Doubles   -- starting position
    -> Doubles         -- upper bounds
    -> Doubles         -- lower bounds
    -> UArray Int Bool -- parameters are integral
    -> IO (ExitCode,Doubles)      -- final answers
asa = undefined

toBasicCostFunction :: Parameter z x => z -> (x -> Double) -> CostFunction
toBasicCostFunction z fn = f where
    thePeek = peekParam z 
    f pd pf = do
        poke pf 1
        x <- thePeek pd
        let v = fn x
        --putStrLn $ ">> Haskell Function Called: " ++ show v 
        return $  v
        

minimize :: Parameter z x => z -> (x -> Double) -> IO x 
minimize z (fn :: x -> Double ) = do
    cf <- mkCostFunction (toBasicCostFunction z fn)
    let n = numParams (undefined :: x) z 
    let ps = paramInfo (undefined :: x) z []
    withArray (map limitLow ps) $ \lower_bounds -> do  
    withArray (map limitHigh ps) $ \upper_bounds -> do  
    withArray (map (\x -> if isIntegral x then (#const INTEGER_TYPE) else (#const REAL_TYPE)) ps) $ \real_int -> do  
    alloca $ \dummy_cost_val -> do 
    allocaArray n $ \ret -> do
    alloca $ \exit_code -> do 
    r <- randomIO
    asa_main cf (fromIntegral n) upper_bounds lower_bounds real_int dummy_cost_val ret exit_code (fromIntegral (r :: Int))
    --code <- peek exit_code
    --print (toEnum (fromIntegral code) :: ExitCode)
    peekParam z ret