LBFGSAux.hs

-- -------------------------------------------------
--
--                    Author: Kiet Lam
--                    File LBFGSAUX_HS
--
-- -------------------------------------------------
-- Last Updated: Time-stamp: <2012-01-19 00:25:43 (lam)>
--
--
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.


module AI.Training.Internal.LBFGSAux (
  minimizeLBFGS
  ) where


import Data.Packed.Vector
import Foreign.C.Types
import Foreign.Ptr(Ptr, FunPtr)
import Foreign.Marshal.Array
import System.IO.Unsafe(unsafePerformIO)



-- Don't make too much changes here

type TV = CInt -> Ptr Double -> IO CInt
type TVV = CInt -> Ptr Double -> TV


aux_LToL :: ([Double] -> [Double]) -> TVV
aux_LToL f n1 p1 _ p2 =
  do
    v <- peekArray (fromIntegral n1) p1
    let vr = f v in
      do
        pokeArray p2 vr
        return 0


aux_LToD :: ([Double] -> Double)
            -> CInt -> Ptr Double -> Double
aux_LToD f n p =
  unsafePerformIO $
  do
    v <- peekArray (fromIntegral n) p
    return $ f v


foreign import ccall "wrapper"
  mkListFun :: (CInt -> Ptr Double -> Double)
               -> IO (FunPtr (CInt -> Ptr Double -> Double))


foreign import ccall "wrapper"
  mkListListFun :: (TVV) -> IO (FunPtr TVV)


foreign import ccall "lbfgs_aux.c minimizeLBFGS"
  c_minimizeLBFGS :: Double
                     -> CInt
                     -> Double
                     -> Double
                     -> FunPtr (CInt -> Ptr Double -> Double)
                     -> FunPtr (CInt -> Ptr Double -> CInt -> Ptr Double -> IO CInt)
                     -> CInt -> Ptr Double
                     -> CInt -> Ptr Double
                     -> IO CInt


vecFuncToLFunc :: (Vector Double -> Vector Double) -> [Double] -> [Double]
vecFuncToLFunc f vec = (toList . f . fromList) vec


vecFuncToFunc :: (Vector Double -> Double) -> [Double] -> Double
vecFuncToFunc f vec = (f . fromList) vec


minimizeLBFGS_aux :: Double
                     -> Int
                     -> Double
                     -> Double
                     -> (Vector Double -> Double)
                     -> (Vector Double -> Vector Double)
                     -> Vector Double
                     -> [Double]
minimizeLBFGS_aux prec maxIter initStep tol f df initVec =
  let f' = vecFuncToFunc f
      df' = vecFuncToLFunc df
      initVec' = toList initVec
      n = length initVec'
  in
   unsafePerformIO $ withArray initVec' $ \ar -> allocaArray n $ \res ->
   do
     fp <- mkListFun (aux_LToD f')
     dfp <- mkListListFun (aux_LToL df')
     _ <- c_minimizeLBFGS prec (fromIntegral maxIter) initStep tol fp dfp (fromIntegral n) ar (fromIntegral n) res
     peekArray n res


minimizeLBFGS :: Double
                 -> Int
                 -> Double
                 -> Double
                 -> (Vector Double -> Double)
                 -> (Vector Double -> Vector Double)
                 -> Vector Double
                 -> Vector Double
minimizeLBFGS prec maxIter initStep tol f df initVec =
  fromList $ minimizeLBFGS_aux prec maxIter initStep tol f df initVec