{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------------- -- | -- Module : Bindings.LevMar -- Copyright : (c) 2009 Roel van Dijk & Bas van Dijk -- License : BSD-style (see the file LICENSE) -- -- Maintainer : vandijk.roel@gmail.com, v.dijk.bas@gmail.com -- Stability : Experimental -- -- A binding to the C levmar (Levenberg-Marquardt) library -- -- For documentation see: -- -------------------------------------------------------------------------------- module Bindings.LevMar ( _LM_VERSION -- * Maximum sizes of arrays. , _LM_OPTS_SZ , _LM_INFO_SZ -- * Errors. , _LM_ERROR_LAPACK_ERROR , _LM_ERROR_NO_JACOBIAN , _LM_ERROR_NO_BOX_CONSTRAINTS , _LM_ERROR_FAILED_BOX_CHECK , _LM_ERROR_MEMORY_ALLOCATION_FAILURE , _LM_ERROR_CONSTRAINT_MATRIX_ROWS_GT_COLS , _LM_ERROR_CONSTRAINT_MATRIX_NOT_FULL_ROW_RANK , _LM_ERROR_TOO_FEW_MEASUREMENTS , _LM_ERROR_SINGULAR_MATRIX , _LM_ERROR_SUM_OF_SQUARES_NOT_FINITE -- * Default values for minimization options. , _LM_INIT_MU , _LM_STOP_THRESH , _LM_DIFF_DELTA -- * Model & Jacobian. , Model , Jacobian , withModel , withJacobian -- * Types of the Levenberg-Marquardt algorithms. , LevMarDer , LevMarDif , LevMarBCDer , LevMarBCDif , LevMarLecDer , LevMarLecDif , LevMarBLecDer , LevMarBLecDif -- * Levenberg-Marquardt algorithms. , dlevmar_der , slevmar_der , dlevmar_dif , slevmar_dif , dlevmar_bc_der , slevmar_bc_der , dlevmar_bc_dif , slevmar_bc_dif , dlevmar_lec_der , slevmar_lec_der , dlevmar_lec_dif , slevmar_lec_dif , dlevmar_blec_der , slevmar_blec_der , dlevmar_blec_dif , slevmar_blec_dif ) where import Foreign.C.Types (CInt, CFloat, CDouble) import Foreign.Ptr (Ptr, FunPtr, freeHaskellFunPtr) import Control.Exception (bracket) #include -- | The version of the C levmar library. _LM_VERSION :: String _LM_VERSION = #const_str LM_VERSION -------------------------------------------------------------------------------- -- Maximum sizes of arrays. -------------------------------------------------------------------------------- -- | The maximum size of the options array. _LM_OPTS_SZ :: Int _LM_OPTS_SZ = #const LM_OPTS_SZ -- | The size of the info array. _LM_INFO_SZ :: Int _LM_INFO_SZ = #const LM_INFO_SZ -------------------------------------------------------------------------------- -- Errors. -------------------------------------------------------------------------------- #{enum CInt, , _LM_ERROR_LAPACK_ERROR = LM_ERROR_LAPACK_ERROR , _LM_ERROR_NO_JACOBIAN = LM_ERROR_NO_JACOBIAN , _LM_ERROR_NO_BOX_CONSTRAINTS = LM_ERROR_NO_BOX_CONSTRAINTS , _LM_ERROR_FAILED_BOX_CHECK = LM_ERROR_FAILED_BOX_CHECK , _LM_ERROR_MEMORY_ALLOCATION_FAILURE = LM_ERROR_MEMORY_ALLOCATION_FAILURE , _LM_ERROR_CONSTRAINT_MATRIX_ROWS_GT_COLS = LM_ERROR_CONSTRAINT_MATRIX_ROWS_GT_COLS , _LM_ERROR_CONSTRAINT_MATRIX_NOT_FULL_ROW_RANK = LM_ERROR_CONSTRAINT_MATRIX_NOT_FULL_ROW_RANK , _LM_ERROR_TOO_FEW_MEASUREMENTS = LM_ERROR_TOO_FEW_MEASUREMENTS , _LM_ERROR_SINGULAR_MATRIX = LM_ERROR_SINGULAR_MATRIX , _LM_ERROR_SUM_OF_SQUARES_NOT_FINITE = LM_ERROR_SUM_OF_SQUARES_NOT_FINITE } -------------------------------------------------------------------------------- -- Default values for minimization options. -------------------------------------------------------------------------------- #let const_real r = "%e", r _LM_INIT_MU, _LM_STOP_THRESH, _LM_DIFF_DELTA :: Fractional a => a _LM_INIT_MU = #const_real LM_INIT_MU _LM_STOP_THRESH = #const_real LM_STOP_THRESH _LM_DIFF_DELTA = #const_real LM_DIFF_DELTA -------------------------------------------------------------------------------- -- Model & Jacobian. -------------------------------------------------------------------------------- -- | Functional relation describing measurements. type Model r = Ptr r -- p -> Ptr r -- hx -> CInt -- m -> CInt -- n -> Ptr () -- adata -> IO () type Jacobian a = Model a foreign import ccall "wrapper" mkModel :: Model a -> IO (FunPtr (Model a)) mkJacobian :: Jacobian a -> IO (FunPtr (Jacobian a)) mkJacobian = mkModel withModel :: Model a -> (FunPtr (Model a) -> IO b) -> IO b withModel m = bracket (mkModel m) freeHaskellFunPtr withJacobian :: Jacobian a -> (FunPtr (Jacobian a) -> IO b) -> IO b withJacobian j = bracket (mkJacobian j) freeHaskellFunPtr -------------------------------------------------------------------------------- -- Types of the Levenberg-Marquardt algorithms. -------------------------------------------------------------------------------- type LevMarDer cr = FunPtr (Model cr) -- func -> FunPtr (Jacobian cr) -- jacf -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarDif cr = FunPtr (Model cr) -- func -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarBCDer cr = FunPtr (Model cr) -- func -> FunPtr (Jacobian cr) -- jacf -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- lb -> Ptr cr -- ub -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarBCDif cr = FunPtr (Model cr) -- func -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- lb -> Ptr cr -- ub -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarLecDer cr = FunPtr (Model cr) -- func -> FunPtr (Jacobian cr) -- jacf -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- A -> Ptr cr -- B -> CInt -- k -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarLecDif cr = FunPtr (Model cr) -- func -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- A -> Ptr cr -- B -> CInt -- k -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarBLecDer cr = FunPtr (Model cr) -- func -> FunPtr (Jacobian cr) -- jacf -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- lb -> Ptr cr -- ub -> Ptr cr -- A -> Ptr cr -- B -> CInt -- k -> Ptr cr -- wghts -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt type LevMarBLecDif cr = FunPtr (Model cr) -- func -> Ptr cr -- p -> Ptr cr -- x -> CInt -- m -> CInt -- n -> Ptr cr -- lb -> Ptr cr -- ub -> Ptr cr -- A -> Ptr cr -- B -> CInt -- k -> Ptr cr -- wghts -> CInt -- itmax -> Ptr cr -- opts -> Ptr cr -- info -> Ptr cr -- work -> Ptr cr -- covar -> Ptr () -- adata -> IO CInt -------------------------------------------------------------------------------- -- Levenberg-Marquardt algorithms. -------------------------------------------------------------------------------- foreign import ccall "slevmar_der" slevmar_der :: LevMarDer CFloat foreign import ccall "dlevmar_der" dlevmar_der :: LevMarDer CDouble foreign import ccall "slevmar_dif" slevmar_dif :: LevMarDif CFloat foreign import ccall "dlevmar_dif" dlevmar_dif :: LevMarDif CDouble foreign import ccall "slevmar_bc_der" slevmar_bc_der :: LevMarBCDer CFloat foreign import ccall "dlevmar_bc_der" dlevmar_bc_der :: LevMarBCDer CDouble foreign import ccall "slevmar_bc_dif" slevmar_bc_dif :: LevMarBCDif CFloat foreign import ccall "dlevmar_bc_dif" dlevmar_bc_dif :: LevMarBCDif CDouble foreign import ccall "slevmar_lec_der" slevmar_lec_der :: LevMarLecDer CFloat foreign import ccall "dlevmar_lec_der" dlevmar_lec_der :: LevMarLecDer CDouble foreign import ccall "slevmar_lec_dif" slevmar_lec_dif :: LevMarLecDif CFloat foreign import ccall "dlevmar_lec_dif" dlevmar_lec_dif :: LevMarLecDif CDouble foreign import ccall "slevmar_blec_der" slevmar_blec_der :: LevMarBLecDer CFloat foreign import ccall "dlevmar_blec_der" dlevmar_blec_der :: LevMarBLecDer CDouble foreign import ccall "slevmar_blec_dif" slevmar_blec_dif :: LevMarBLecDif CFloat foreign import ccall "dlevmar_blec_dif" dlevmar_blec_dif :: LevMarBLecDif CDouble -- The End ---------------------------------------------------------------------