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
|
/* 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 */
|
