File: nlopt.c

package info (click to toggle)
libctl 3.2.2-4
  • links: PTS
  • area: main
  • in suites: stretch
  • size: 2,304 kB
  • ctags: 1,178
  • sloc: sh: 11,466; ansic: 5,903; lisp: 2,311; makefile: 123
file content (114 lines) | stat: -rw-r--r-- 3,331 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
/* 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 */