/* interface calling into the fortran routine */
static int lbfgs(index_t *x0, at *f, at *g, double gtol, htable_t *p, at *vargs)
{
/* argument checking and setup */
extern void lbfgs_(int *n, int *m, double *x, double *fval, double *gval, \
int *diagco, double *diag, int iprint[2], double *gtol, \
double *xtol, double *w, int *iflag);
ifn (IND_STTYPE(x0) == ST_DOUBLE)
error(NIL, "not an array of doubles", x0->backptr);
ifn (Class(f)->listeval)
error(NIL, "not a function", f);
ifn (Class(f)->listeval)
error(NIL, "not a function", g);
ifn (gtol > 0)
error(NIL, "threshold value not positive", NEW_NUMBER(gtol));
at *gx = copy_array(x0)->backptr;
at *(*listeval_f)(at *, at *) = Class(f)->listeval;
at *(*listeval_g)(at *, at *) = Class(g)->listeval;
at *callf = new_cons(f, new_cons(x0->backptr, vargs));
at *callg = new_cons(g, new_cons(gx, new_cons(x0->backptr, vargs)));
htable_t *params = lbfgs_params();
if (p) htable_update(params, p);
int iprint[2];
iprint[0] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-1")));
iprint[1] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-2")));
lb3_.gtol = Number(htable_get(params, NEW_SYMBOL("ls-gtol")));
lb3_.stpmin = Number(htable_get(params, NEW_SYMBOL("ls-stpmin")));
lb3_.stpmax = Number(htable_get(params, NEW_SYMBOL("ls-stpmax")));
int m = (int)Number(htable_get(params, NEW_SYMBOL("lbfgs-m")));
int n = index_nelems(x0);
double *x = IND_ST(x0)->data;
double fval;
double *gval = IND_ST(Mptr(gx))->data;
int diagco = false;
double *diag = mm_blob(n*sizeof(double));
double *w = mm_blob((n*(m+m+1)+m+m)*sizeof(double));
double xtol = eps(1); /* machine precision */
int iflag = 0;
ifn (n>0)
error(NIL, "empty array", x0->backptr);
ifn (m>0)
error(NIL, "m-parameter must be positive", NEW_NUMBER(m));
/* reverse communication loop */
do {
fval = Number(listeval_f(Car(callf), callf));
listeval_g(Car(callg), callg);
lbfgs_(&n, &m, x, &fval, gval, &diagco, diag, iprint, >ol, &xtol, w, &iflag);
assert(iflag<2);
} while (iflag > 0);
return iflag;
}
at *make_list(int n, at *v)
{
at *ans = NIL;
if (n < 0)
RAISEF("value must be non-negative", NEW_NUMBER(n));
if (n > 32767)
RAISEF("value too large", NEW_NUMBER(n));
MM_ENTER;
while (n--)
ans = new_cons(v, ans);
MM_RETURN(ans);
}
struct lispobj *subr_minus(struct lispobj *args)
{
if(length(args) == 0)
return ERROR_ARGS;
struct lispobj *num;
char num_value[30];
snprintf(num_value, 30, "%d", NUMBER_VALUE(CAR(args)));
num = NEW_NUMBER(num_value);
args = CDR(args);
if(args == NULL) {
NUMBER_VALUE(num) = 0 - NUMBER_VALUE(num);
} else {
while(args != NULL) {
if(CAR(args) != NULL && OBJ_TYPE(CAR(args)) == NUMBER) {
NUMBER_VALUE(num) -= NUMBER_VALUE(CAR(args));
args = CDR(args);
} else {
object_delete(num);
return NEW_ERROR("Argument is not a number.\n");
}
}
}
return num;
}
void storage_clear(storage_t *st, at *init, size_t from)
{
/* don't need to check read-only status here because
it will be checked by the setat function below */
int size = st->size;
if (from>=size)
RAISEF("invalid value for 'from'", NEW_NUMBER(from));
/* clear from from to to */
if (st->type == ST_AT) {
for (int off = from; off < size; off++)
(storage_setat[st->type])(st, off, init);
} else if (storage_setat[st->type] == Number_setat) {
get_write_permit(st);
void (*set)(gptr, size_t, real) = storage_setd[st->type];
for (int off = from; off < size; off++)
set(st->data, off, Number(init));
} else if (storage_setat[st->type] == gptr_setat) {
get_write_permit(st);
gptr *pt = st->data;
for (int off=from; off<size; off++)
pt[off] = Gptr(init);
} else if (storage_setat[st->type] == mptr_setat) {
get_write_permit(st);
gptr *pt = st->data;
for (int off=from; off<size; off++)
pt[off] = Mptr(init);
} else
RAISEF("don't know how to clear this storage", st->backptr);
}
/*
* makelist ex: (makelist 4 'a) --> (a a a a)
*/
at *
makelist(int n, at *v)
{
at *ans;
ans = NIL;
if (n < 0)
error(NIL, "illegal negative value", NEW_NUMBER(n));
if (n > 32767)
error(NIL, "too large integer in makelist", NEW_NUMBER(n));
while (n--) {
LOCK(v);
ans = cons(v, ans);
}
return ans;
}
void
learn_lvq3(struct codebook *cbdata, struct codebook *cbref,
int nbit, flt a0, flt win)
{
int i,j,nn1,nn2,c;
flt alph = Fzero;
for (i = 0; i < nbit; i++) {
CHECK_MACHINE("on");
for (j = 0; j < cbdata->ncode; j++)
{
c = cbdata->code[j].label;
one_nn_and_a_half(cbdata->code[j].word,cbref,c,&nn1,&nn2);
if (c!=cbref->code[nn1].label)
{
if (nn2<0)
error(NIL,"Class not represented in the references",
NEW_NUMBER(c));
if (in_window(&(cbref->code[nn1]), &(cbref->code[nn2]),
&(cbdata->code[j]), cbdata->ndim,
win ) )
{
alph=alpha(a0,i,nbit);
adapt(&(cbdata->code[j]),&(cbref->code[nn1]),alph,cbdata->ndim);
adapt(&(cbdata->code[j]),&(cbref->code[nn2]),-alph,cbdata->ndim);
}
}
}
}
}
/* timer_add --
* Add a timer targeted to the specified handler
* firing after delay milliseconds and every period
* milliseconds after that. Specifying period equal
* to zero sets a one shot timer.
*/
void *timer_add(at *handler, int delay, int period)
{
evtime_t now, add;
evtime_now(&now);
if (!handler)
RAISEF("invalid event handler", handler);
if (delay < 0)
RAISEF("invalid timer delay", NEW_NUMBER(delay));
if (period < 0)
RAISEF("invalid timer interval", NEW_NUMBER(period));
if (period > 0 && period < 20)
period = 20;
add.sec = delay/1000;
add.msec = delay%1000;
evtime_add(&now, &add, &add);
return timer_add_sub(handler, add.sec, add.msec, period);
}
/* timer_add --
Add a timer targeted to the specified handler
firing after delay milliseconds and every period
milliseconds after that. Specifying period equal
to zero sets a one shot timer.
*/
void *
timer_add(at *handler, int delay, int period)
{
evtime_t now, add;
evtime_now(&now);
if (! handler)
error(NIL,"Illegal null event handler",NIL);
if (delay < 0)
error(NIL,"Illegal timer delay",NEW_NUMBER(delay));
if (period < 0)
error(NIL,"Illegal timer interval",NEW_NUMBER(period));
if (period > 0 && period < 20)
period = 20;
add.sec = delay/1000;
add.msec = delay%1000;
evtime_add(&now, &add, &add);
return timer_add_sub(handler, add.sec, add.msec, period);
}
static void
convertsave(neurone *n) /* pour mapneur */
{
int i;
i=n-neurbase;
if ( netconvert[i]<0 )
netconvert[i]= (++indice);
else
error(NIL,"cell referenced twice in 'save-net' listes",NEW_NUMBER(i));
}
/* set_vars
sets the lisp variables
Nnum,Snum,Wnum,Nmax,Smax,Nmax
*/
void
set_vars(void)
{
at *p;
p = NEW_NUMBER(neurnombre);
var_SET(var_Nnum,p);
UNLOCK(p);
p = NEW_NUMBER(synnombre);
var_SET(var_Snum,p);
UNLOCK(p);
p = NEW_NUMBER(neurmax);
var_SET(var_Nmax,p);
UNLOCK(p);
p = NEW_NUMBER(synmax);
var_SET(var_Smax,p);
UNLOCK(p);
#ifdef ITERATIVE
p = NEW_NUMBER(weightnombre);
var_SET(var_Wnum,p);
UNLOCK(p);
p = NEW_NUMBER(weightmax);
var_SET(var_Wmax,p);
UNLOCK(p);
#endif
}
static int
number_of_labels(struct codebook *cb)
{
int i;
int nb=-1;
for (i = 0; i < cb->ncode; i++) {
if (cb->code[i].label > nb)
nb=cb->code[i].label;
if (cb->code[i].label < 0)
error(NIL,"Codebook labels is negative for item",NEW_NUMBER(i));
}
return(nb+1);
}
static at *
Nacces(int arg_number, at **arg_array, int champ)
{
flt val = Fzero;
int numero;
ALL_ARGS_EVAL;
if (arg_number <1 || arg_number >=3)
ARG_NUMBER(-1);
numero = AINTEGER(1);
if (numero<0 || numero>=neurnombre)
error(NIL,"illegal neuron number",NEW_NUMBER(numero));
switch(arg_number) {
case 1:
val=get_Nfield(numero,champ);
break;
case 2:
val = AFLT(2);
set_Nfield(numero,champ,val);
break;
}
return NEW_NUMBER(Ftofp(val));
}
static struct lispobj *env_subr_init(struct subrs *s, int size, int i)
{
if(i < size) {
struct lispobj *cell, *frame, *val;
char num[32];
snprintf(num, 32, "%d", (int) s[i].val);
val = list(2, NEW_SYMBOL("SUBR"), NEW_NUMBER(num));
cell = NEW_CONS(NEW_SYMBOL(s[i].var), val);
frame = NEW_CONS(cell, env_subr_init(s, size, i + 1));
return frame;
}
return NULL;
}
struct lispobj *subr_multi(struct lispobj *args)
{
struct lispobj *num;
num = NEW_NUMBER("1");
while(args != NULL) {
if(CAR(args) != NULL && OBJ_TYPE(CAR(args)) == NUMBER) {
NUMBER_VALUE(num) *= NUMBER_VALUE(CAR(args));
args = CDR(args);
} else {
object_delete(num);
return NEW_ERROR("Argument is not a number.\n");
}
}
return num;
}
void cg_grad_adaptor(double *g, double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *stx = NULL;
static storage_t *stg = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *g = var_get(named("g"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (g)
error(NIL, "g not found", NIL);
listeval = Class(g)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
stx = new_storage(ST_DOUBLE);
stx->flags = STS_FOREIGN;
stx->size = nx;
stx->data = (char *)-1;
stg = new_storage(ST_DOUBLE);
stg->flags = STS_FOREIGN;
stg->size = nx;
stg->data = (char *)-1;
call = new_cons(g,
new_cons(NEW_INDEX(stg, IND_SHAPE(ind)),
new_cons(NEW_INDEX(stx, IND_SHAPE(ind)),
vargs)));
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
stx->data = x;
stg->data = g;
listeval(Car(call), call);
}
}
struct lispobj *subr_mod(struct lispobj *args)
{
if(length(args) != 2)
return ERROR_ARGS;
struct lispobj *number, *div;
number = CAR(args);
div = CADR(args);
if(OBJ_TYPE(number) == NUMBER && OBJ_TYPE(div) == NUMBER) {
char mod[30];
snprintf(mod, 30, "%d", NUMBER_VALUE(number) % NUMBER_VALUE(div));
return NEW_NUMBER(mod);
} else {
return NEW_ERROR("Arguments must be numbers.\n");
}
}
void
ev_add(at *handler, at *event, const char *desc, int mods)
{
if (handler && event)
{
at *p;
at *d = NIL;
if (mods == (unsigned char)mods)
d = NEW_NUMBER(mods);
if (desc && d)
d = cons(new_gptr((gptr)desc), d);
else if (desc)
d = new_gptr((gptr)desc);
LOCK(event);
p = cons(new_gptr(handler),cons(d,event));
add_finalizer(handler, ev_finalize, 0);
tail->Cdr = cons(p,NIL);
tail = tail->Cdr;
}
}
void ev_add(at *handler, at *event, const char *desc, int mods)
{
MM_ENTER;
if (handler && event) {
at *d = NIL;
if (mods == (unsigned char)mods)
d = NEW_NUMBER(mods);
if (desc && d) {
gptr p = (gptr)desc;
d = new_cons(NEW_GPTR(p), d);
} else if (desc) {
gptr p = (gptr)desc;
d = NEW_GPTR(p);
}
at *p = new_cons(NEW_GPTR(handler), new_cons(d, event));
add_notifier(handler, (wr_notify_func_t *)ev_notify, 0);
Cdr(tail) = new_cons(p,NIL);
tail = Cdr(tail);
}
MM_EXIT;
}
static htable_t *lbfgs_params(void)
{
htable_t *p = new_htable(31, false, false);
/* these control verbosity */
htable_set(p, NEW_SYMBOL("iprint-1"), NEW_NUMBER(-1));
htable_set(p, NEW_SYMBOL("iprint-2"), NEW_NUMBER(0));
/* these control line search behavior */
htable_set(p, NEW_SYMBOL("ls-gtol"), NEW_NUMBER(lb3_.gtol));
htable_set(p, NEW_SYMBOL("ls-stpmin"), NEW_NUMBER(lb3_.stpmin));
htable_set(p, NEW_SYMBOL("ls-stpmax"), NEW_NUMBER(lb3_.stpmax));
/* LBFGS parameters */
htable_set(p, NEW_SYMBOL("lbfgs-m"), NEW_NUMBER(7));
return p;
}
double cg_value_adaptor(double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *st = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *f = var_get(named("f"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (f)
error(NIL, "f not found", NIL);
listeval = Class(f)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
st = new_storage(ST_DOUBLE);
st->flags = STS_FOREIGN;
st->size = nx;
st->data = (char *)-1;
call = new_cons(f, new_cons(NEW_INDEX(st, IND_SHAPE(ind)), vargs));
return NAN;
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
st->data = x;
return Number(listeval(Car(call), call));
}
}
static void
set_Nfield(int numero, int champ, float val)
{
switch (champ)
{
case F_VAL:
neuraddress[numero]->Nval=val;
break;
case F_SUM:
neuraddress[numero]->Nsum=val;
break;
case F_GRAD:
neuraddress[numero]->Ngrad=val;
break;
case F_BACKSUM:
neuraddress[numero]->Nbacksum=val;
break;
case F_EPSILON:
#ifdef SYNEPSILON
setsyneps(neuraddress[numero],val);
#else
neuraddress[numero]->Nepsilon=val;
#endif
break;
#ifdef DESIRED
case F_DESIRED:
neuraddress[numero]->Ndesired=val;
break;
case F_FREEDOM:
neuraddress[numero]->Nfreedom=val;
break;
#endif
#ifdef NEWTON
case F_GGRAD:
neuraddress[numero]->Nggrad=val;
break;
case F_SQBACKSUM:
neuraddress[numero]->Nsqbacksum=val;
break;
case F_SIGMA:
#ifdef SYNEPSILON
setsynsigma(neuraddress[numero],val);
break;
#else
neuraddress[numero]->Nsigma=val;
break;
#endif
#endif
#ifndef NOSPARE
case F_SPARE1:
neuraddress[numero]->Nspare1=val;
break;
case F_SPARE2:
neuraddress[numero]->Nspare2=val;
break;
case F_SPARE3:
neuraddress[numero]->Nspare3=val;
break;
#endif
default:
error(NIL,"illegal Nfield number",NEW_NUMBER(champ));
}
}
static at *
four_integers(int i1, int i2, int i3, int i4)
{
return cons(NEW_NUMBER(i1), cons(NEW_NUMBER(i2), two_integers(i3, i4)));
}
static at *
two_integers(int i1, int i2)
{
return cons(NEW_NUMBER(i1), cons(NEW_NUMBER(i2), NIL));
}
static void at_setf(gptr pt, size_t off, float x)
{
((at **)pt)[off] = NEW_NUMBER(x);
}
static void at_setd(gptr pt, size_t off, double x)
{
((at **)pt)[off] = NEW_NUMBER(x);
}
static at *Number_getat(storage_t *st, size_t off)
{
double (*get)(gptr,size_t) = storage_getd[st->type];
return NEW_NUMBER( (*get)(st->data, off) );
}
static flt
get_Nfield(int numero, int champ)
{
flt val;
switch (champ)
{
case F_VAL:
val=neuraddress[numero]->Nval;
break;
case F_SUM:
val=neuraddress[numero]->Nsum;
break;
case F_GRAD:
val=neuraddress[numero]->Ngrad;
break;
case F_BACKSUM:
val=neuraddress[numero]->Nbacksum;
break;
case F_EPSILON:
#ifdef SYNEPSILON
val=averagesyneps(neuraddress[numero]);
#else
val=neuraddress[numero]->Nepsilon;
#endif
break;
#ifdef DESIRED
case F_DESIRED:
val=neuraddress[numero]->Ndesired;
break;
case F_FREEDOM:
val=neuraddress[numero]->Nfreedom;
break;
#endif
#ifdef NEWTON
case F_GGRAD:
val=neuraddress[numero]->Nggrad;
break;
case F_SQBACKSUM:
val=neuraddress[numero]->Nsqbacksum;
break;
case F_SIGMA:
#ifdef SYNEPSILON
val=avsigma(neuraddress[numero]);
break;
#else
val=neuraddress[numero]->Nsigma;
break;
#endif
#endif
#ifndef NOSPARE
case F_SPARE1:
val=neuraddress[numero]->Nspare1;
break;
case F_SPARE2:
val=neuraddress[numero]->Nspare2;
break;
case F_SPARE3:
val=neuraddress[numero]->Nspare3;
break;
#endif
default:
error(NIL,"illegal Nfield number",NEW_NUMBER(champ));
}
return val;
}
