view release on metacpan or  search on metacpan

Algorithm-LBFGS.xs  view on Meta::CPAN

/**************************************************************************
 * EXPORTED XSUBS
 **************************************************************************/
MODULE = Algorithm::LBFGS		PACKAGE = Algorithm::LBFGS

void*
create_lbfgs_instance(lbfgs_eval, lbfgs_prgr, user_data)
        SV*     lbfgs_eval
	SV*     lbfgs_prgr
	SV*	user_data
    PREINIT:
        void* instance = malloc(3 * sizeof(SV*));
    CODE:
        ((SV**)instance)[0] = lbfgs_eval; /* ref to Perl eval callback */
	((SV**)instance)[1] = lbfgs_prgr; /* ref to Perl monitor callback */
	((SV**)instance)[2] = user_data;  /* ref to Perl user data */
	RETVAL = instance;
    OUTPUT:
        RETVAL

void
destroy_lbfgs_instance(li)
        void*   li
    CODE:
        free(li);


void*
create_lbfgs_param()
    PREINIT:
        void* lp = malloc(sizeof(lbfgs_parameter_t));
    CODE:
        lbfgs_parameter_init((lbfgs_parameter_t*)lp);
	RETVAL = lp;
    OUTPUT:
        RETVAL

void
destroy_lbfgs_param(lp)
        void*   lp
    CODE:
        free(lp);

SV*
set_lbfgs_param(lp, name, val)
        void*   lp
	char*   name
	SV*     val
    PREINIT:
        lbfgs_parameter_t* p = (lbfgs_parameter_t*)lp;
	SV* r = &PL_sv_undef;
    CODE:
        if (strcmp(name, "m") == 0) {
	    if (SvIOK(val)) p->m = SvIV(val);
	    r = newSViv(p->m);
	}
	else if (strcmp(name, "epsilon") == 0) {
	    if (SvNOK(val)) p->epsilon = SvNV(val);
	    r = newSVnv(p->epsilon);
	}
	else if (strcmp(name, "max_iterations") == 0) {
	    if (SvIOK(val)) p->max_iterations = SvIV(val);
	    r = newSViv(p->max_iterations);
	}
	else if (strcmp(name, "max_linesearch") == 0) {
	    if (SvIOK(val)) p->max_linesearch = SvIV(val);
	    r = newSViv(p->max_linesearch);
	}
	else if (strcmp(name, "min_step") == 0) {
	    if (SvNOK(val)) p->min_step = SvNV(val);
	    r = newSVnv(p->min_step);
	}
	else if (strcmp(name, "max_step") == 0) {
	    if (SvNOK(val)) p->max_step = SvNV(val);
	    r = newSVnv(p->max_step);
	}
	else if (strcmp(name, "ftol") == 0) {
	    if (SvNOK(val)) p->ftol = SvNV(val);
	    r = newSVnv(p->ftol);
	}
	else if (strcmp(name, "gtol") == 0) {
	    if (SvNOK(val)) p->gtol = SvNV(val);
	    r = newSVnv(p->gtol);
	}
	else if (strcmp(name, "xtol") == 0) {
	    if (SvNOK(val)) p->xtol = SvNV(val);
	    r = newSVnv(p->xtol);
	}
	else if (strcmp(name, "orthantwise_c") == 0) {
	    if (SvNOK(val)) p->orthantwise_c = SvNV(val);
	    r = newSVnv(p->orthantwise_c);
	}
	RETVAL = r;
    OUTPUT:
        RETVAL

SV*
do_lbfgs(param, instance, x0)
        void*   param
	void*   instance
	SV*     x0
    PREINIT:
        AV* av_x0 = (AV*)SvRV(x0);
	int n = av_len(av_x0) + 1;
	int i, s;
    CODE:
	/* build C array carr_x0 from Perl array ref x0 */
	lbfgsfloatval_t* carr_x0 = (lbfgsfloatval_t*)
	    malloc(n * sizeof(lbfgsfloatval_t));
	for (i = 0; i < n; i++) carr_x0[i] = SvNV(*av_fetch(av_x0, i, 0));
	/* call L-BFGS */
	s = lbfgs(n, carr_x0, NULL, 
                  SvOK(((SV**)instance)[0]) ? &lbfgs_evaluation_cb : NULL,
                  SvOK(((SV**)instance)[1]) ? &lbfgs_progress_cb : NULL,
                  instance, (lbfgs_parameter_t*)param);
        /* store the result back to the Perl array ref x0 */
	for (i = 0; i < n; i++) av_store(av_x0, i, newSVnv(carr_x0[i]));
	/* release the C array */
	free(carr_x0);
	RETVAL = newSViv(s);
    OUTPUT:
        RETVAL