/* wrapper around NLopt nonlinear optimization library (if installed) */

#ifdef HAVE_NLOPT

#include <stdio.h>
#include <stdlib.h>
#include <math.h>

#include <ctl.h>
#include <nlopt.h>

static double f_scm_wrap(integer n, const double *x, double *grad, void *f_scm_p)
{
     SCM *f_scm = (SCM *) f_scm_p;
     SCM ret = gh_call1(*f_scm, make_number_list(n, x));
     if (scm_real_p(ret))
	  return scm_to_double(ret);
     else { /* otherwise must be a list of value, gradient components,
	       i.e. (cons value gradient). */
	  SCM gscm = ret;
	  int i;
	  for (i = 0; i < n; ++i) {
	       gscm = SCM_CDR(gscm);
	       grad[i] = scm_to_double(SCM_CAR(gscm));
	  }
	  return scm_to_double(SCM_CAR(ret));
     }
}

/* Scheme-callable wrapper for nlopt_minimize() function.
   Note that Guile-callable C subroutines cannot take more than
   10 arguments (grrr), so we past the last few arguments with a "rest"
   list parameter */
SCM nlopt_minimize_scm(SCM algorithm_scm,
		       SCM f_scm,
		       SCM lb_scm, SCM ub_scm, SCM x_scm,
		       SCM minf_max_scm, SCM ftol_rel_scm, SCM ftol_abs_scm,
		       SCM rest
		       /*
		       SCM xtol_rel_scm, SCM xtol_abs_scm,
		       SCM maxeval_scm, SCM maxtime_scm
		       */)
{
     nlopt_algorithm algorithm = (nlopt_algorithm) scm_to_int(algorithm_scm);
     int i, n = list_length(x_scm);
     double *x, *lb, *ub, *xtol_abs = 0;
     double minf_max = scm_to_double(minf_max_scm);
     double ftol_rel = scm_to_double(ftol_rel_scm);
     double ftol_abs = scm_to_double(ftol_abs_scm);
     double xtol_rel = 0;
     double maxeval = 0;
     double maxtime = 0;
     int nrest = list_length(rest);
/*
     double xtol_rel = scm_to_double(xtol_rel_scm);
     int maxeval = scm_to_int(maxeval_scm);
     double maxtime = scm_to_double(maxtime_scm);
*/
     double minf;
     nlopt_result result;
     SCM v, ret;

     x = (double *) malloc(sizeof(double) * n * 4);
     lb = x + n; ub = lb + n;
     if (!x) {
	  fprintf(stderr, "nlopt_minimize_scm: out of memory!\n");
	  exit(EXIT_FAILURE);
     }
     if (list_length(lb_scm) != n || list_length(ub_scm) != n) {
	  fprintf(stderr, "nlopt_minimize_scm: invalid arguments\n");
	  exit(EXIT_FAILURE);
     }

     for (v=x_scm, i=0; i < n; ++i) {
	  x[i] = scm_to_double(SCM_CAR(v));
	  v = SCM_CDR(v);
     }
     for (v=lb_scm, i=0; i < n; ++i) {
	  lb[i] = scm_to_double(SCM_CAR(v));
	  v = SCM_CDR(v);
     }
     for (v=ub_scm, i=0; i < n; ++i) {
	  ub[i] = scm_to_double(SCM_CAR(v));
	  v = SCM_CDR(v);
     }

     if (nrest >= 1) xtol_rel = scm_to_double(SCM_CAR(rest));
     if (nrest >= 2) {
	  SCM xtol_abs_scm = scm_cadr(rest);
	  if (list_length(xtol_abs_scm)) {
	       xtol_abs = ub + n;
	       for (v=xtol_abs_scm, i=0; i < n; ++i) {
		    xtol_abs[i] = scm_to_double(SCM_CAR(v));
		    v = SCM_CDR(v);
	       }
	  }
     }
     if (nrest >= 3) maxeval = scm_to_int(scm_caddr(rest));
     if (nrest >= 4) maxtime = scm_to_double(scm_cadddr(rest));

     result = nlopt_minimize(algorithm, n, f_scm_wrap, &f_scm,
			     lb, ub, x, &minf,
			     minf_max, ftol_rel, ftol_abs, xtol_rel, xtol_abs,
			     maxeval, maxtime);

     ret = scm_cons(scm_from_int((int) result),
		    scm_cons(scm_from_double(minf), make_number_list(n, x)));

     free(x);

     return ret;
}

#endif /* HAVE_NLOPT */
