/*
 *  SPL - The SPL Programming Language
 *  Copyright (C) 2006  Clifford Wolf <clifford@clifford.at>
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *
 *  gen_fann.spl: Generate the SPL "fann" module from the FANN C header files
 */

load "system";
load "array";

var ctext = system("cat $parameters.infiles | indent --ignore-profile -l1000");

var f_list;
var e_list;

var types;
var types_ret;
var types_arg;

write(<:>
	: // mod_fann.c: Auto-generated by gen_fann.spl
	:
	: /**
	:  * Bindings for the FANN (Fast Artificial Neural Network) Library
	:  */
	:
	: /**
	:  * This module is a very thin wrapper for the FANN library. Thus it
	:  * is possible to write applications which do leak memory or trigger
	:  * segmentation faults by using this API incorrectly.
	:  *
	:  * Be careful, you have been warned.
	:  *
	:  * The FANN library documentation can be found on the FANN homepage:
	:  *
	:  *	http://leenissen.dk/fann/
	:  *
	:  * The SPL FANN API is a 1:1 representation of the C API. So the
	:  * original FANN documentation should answer all the questions which
	:  * are left open in this document.
	:  */
	: // manual introduction;
	:
	: /**
	:  * A little FANN example app which creates a small neural network
	:  * with two input and one output and trains it to act like a XOR
	:  * gate.
	:  *
	:  *	load "fann";
	:  *
	:  *	var ann = fann_create_standard_array(3, [2, 10, 1]);
	:  *
	:  *	for (var i=0; i<1000; i++)
	:  *	{
	:  *	    fann_train(ann, [0, 0], [0]);
	:  *	    fann_train(ann, [0, 1], [1]);
	:  *	    fann_train(ann, [1, 0], [1]);
	:  *	    fann_train(ann, [1, 1], [0]);
	:  *	}
	:  *
	:  *	for (var a=0; a<2; a++)
	:  *	for (var b=0; b<2; b++)
	:  *	{
	:  *	    var result = pop fann_run(ann, [a, b]);
	:  *	    debug "$$a XOR $$b <=> $${round(result)}  [$${fmt("%5.03f", result)}]";
	:  *	}
	:  *
	:  *	fann_destroy(ann);
	:  *
	:  * Note that the fann_destroy() call is not absolutely needed because
	:  * fann_destroy() is automatically called when the 'ann' variable is
	:  * removed by the garbage collector.
	:  */
	: // manual example;
	:
	: #include "spl.h"
	: #include "compat.h"
	:
	: #include <fann.h>
	: #include <assert.h>
	:
	: extern void SPL_ABI(spl_mod_fann_init)(struct spl_vm *vm, struct spl_module *mod, int restore);
	: extern void SPL_ABI(spl_mod_fann_done)(struct spl_vm *vm, struct spl_module *mod);
	:
	: struct fann_hnode_data {
	:	void *objptr;
	:	char *type;
	: };
	:
	: static void handler_fann_node(struct spl_task *task UNUSED, struct spl_vm *vm UNUSED,
	:                 struct spl_node *node, struct spl_hnode_args *args, void *data UNUSED)
	: {
	:	if (args->action == SPL_HNODE_ACTION_PUT) {
	:		struct fann_hnode_data *hnd = node->hnode_data;
	:		if (hnd->objptr) {
	:			if (!strcmp(hnd->type, "struct fann *"))
	:				fann_destroy(hnd->objptr);
	:			if (!strcmp(hnd->type, "struct fann_train_data *"))
	:				fann_destroy_train(hnd->objptr);
	:		}
	:		free(hnd->type);
	:		free(node->hnode_data);
	:		node->hnode_data = 0;
	:	}
	:	return;
	: }
	:
	: static void *spl2objptr(struct spl_task *task, struct spl_node *n, const char *type)
	: {
	:	struct fann_hnode_data *hnd = n ? n->hnode_data : 0;
	:
	:	if (hnd && n->hnode_name && !strcmp(n->hnode_name, "fann") && !strcmp(type, hnd->type) && hnd->objptr)
	:		return hnd->objptr;
	:
	:	spl_clib_exception(task, "FannEx", "description",
	:			SPL_NEW_PRINTF("Expected FANN <%s> Object", type),
	:			NULL);
	:	return 0;
	: }
	:
	: static struct spl_node *objptr2spl(struct spl_task *task UNUSED, void *ptr, const char *type)
	: {
	:	struct spl_node *n = SPL_NEW_STRING_DUP("FANN Node");
	:	struct fann_hnode_data *hnd = calloc(1, sizeof(struct fann_hnode_data));
	:
	:	hnd->objptr = ptr;
	:	hnd->type = strdup(type);
	:
	:	n->hnode_name = strdup("fann");
	:	n->hnode_data = hnd;
	:
	:	return n;
	: }
	:
	: static void objptr_null(struct spl_task *task UNUSED, struct spl_node *n, const char *type)
	: {
	:	struct fann_hnode_data *hnd = n ? n->hnode_data : 0;
	:
	:	if (hnd && n->hnode_name && !strcmp(n->hnode_name, "fann") && !strcmp(type, hnd->type) && hnd->objptr)
	:		hnd->objptr = 0;
	: }
</>);

foreach[] edecl (ctext =~ /^enum[\s\n]+\S+[\s\n]+{.*?}/Agsm)
{
	edecl =~ s/\/\/.*/ /g;
	edecl =~ s/\/\*.*?\*\// /gs;
	edecl =~ s/.*{|}.*|(=.*?)?,/ /gs;
	foreach[] e (edecl =~ /\S+/Ag)
		e_list[e] = 1;
}

foreach[] cline (ctext =~ /[^\n]+/Ag)
{
	if (cline !~ /^FANN_EXTERNAL/)
		continue;

	if (cline =~ /##|\.\.\.|typedef/)
		continue;

	// no fixcomma functions
	if (cline =~ /fann_get_decimal_point|fann_get_multiplier/)
		continue;

	// no training status callbacks
	if (cline =~ /fann_set_callback/)
		continue;

	cline =~ s/FANN_EXTERNAL\s+//;
	cline =~ s/FANN_API\s+//;

	cline =~ s/(?P<f_name>[^ \*]\S*?)\s*\(/\(/I;
	cline =~ s/(?P<f_ret>[^\(]+?)\s*\((.*)\);.*/$2/I;
	var f_args = cline =~ /[^, ][^,]*[^, ]/Ag;
	var f_argsdecl = "";

	types_ret[f_ret]++;
	types[f_ret]++;

	foreach[] a (f_args) {
		a =~ /(.*\*)(\S+)/ or a =~ /(.*)\s(\S+)/;
		f_argsdecl ~= (f_argsdecl ~== "" ? "" : ", ") ~ $2;
		var a.type = $1, a.name = $2;
		types_arg[a.type]++;
		types[a.type]++;
	}

	f_list[f_name] = [
		f_name: f_name,
		f_args: f_args,
		f_argsdecl: f_argsdecl,
		f_ret: f_ret,
		fixme: 0
	];
}

array_sort_by_keys(f_list, function(a,b) { return a ~> b; });
array_sort_by_keys(types, function(a,b) { return a ~> b; });

function marshal_getarg_fixme(func, type, num)
{
	f_list[func].fixme = 1;
	return "\targ_$num = 0; // FIXME\n";
}

function marshal_getarg_int(f, t, n)
{
	return "\targ_$n = spl_clib_get_int(t);\n";
}

function marshal_getarg_float(f, t, n)
{
	return "\targ_$n = spl_clib_get_float(t);\n";
}

function marshal_getarg_array(f, t, n)
{
	var matrix = [
		fann_create_shortcut_array__1: [
			size: "arg_0",
			xtype: "unsigned int",
			type: "int"
		],
		fann_create_sparse_array__2: [
			size: "arg_1",
			xtype: "unsigned int",
			type: "int"
		],
		fann_create_standard_array__1: [
			size: "arg_0",
			xtype: "unsigned int",
			type: "int"
		],
		fann_run__1: [
			size: "fann_get_num_input(arg_0)",
			type: "float"
		],
		fann_set_cascade_activation_functions__1: [
			size: "spl_clib_get_int(t)",
			xtype: "enum fann_activationfunc_enum",
			type: "int"
		],
		fann_set_cascade_activation_steepnesses__1: [
			size: "spl_clib_get_int(t)",
			type: "float"
		],
		fann_test__1: [
			size: "fann_get_num_input(arg_0)",
			type: "float"
		],
		fann_test__2: [
			size: "fann_get_num_output(arg_0)",
			type: "float"
		],
		fann_train__1: [
			size: "fann_get_num_input(arg_0)",
			type: "float"
		],
		fann_train__2: [
			size: "fann_get_num_output(arg_0)",
			type: "float"
		]
	];

	if (not declared matrix["${f}__${n}"])
		return marshal_getarg_fixme(f, t, n);
	
	import matrix["${f}__${n}"];

	if (not declared xtype)
		var xtype = type;

	return <:>
		:	struct spl_node *arg_${n}_node = spl_clib_get_node(t);
		:	int arg_${n}_size = $size;
		:	$xtype arg_${n}_buf[arg_${n}_size];
		:	arg_${n} = arg_${n}_buf;
		:	{
		:		char key[16];
		:		for (int i=0; i < arg_${n}_size; i++) {
		:			snprintf(key, 16, "%d", i);
		:			arg_${n}_buf[i] = spl_get_$type(spl_lookup(t, arg_${n}_node, key, SPL_LOOKUP_TEST));
		:		}
		:		spl_put(t->vm, arg_${n}_node);
		:		arg_${n}_node = 0;
		:	}
	</>;
}

function marshal_getarg_objptr(f, t, n)
{
	return <:>
		:	{
		:		struct spl_node *n = spl_clib_get_node(t);
		:		arg_$n = spl2objptr(t, n, "$t");
		<spl:if code="f =~ /^fann_destroy/">
		:		objptr_null(t, n, "$t");
		</spl:if>
		:		spl_put(t->vm, n);
		:	}
	</>;
}

function marshal_getret_fixme(func, type)
{
	f_list[func].fixme = 1;
	return "\treturn 0; // FIXME\n";
}

function marshal_getret_int(f, t)
{
	return "\treturn SPL_NEW_INT(ret);\n";
}

function marshal_getret_float(f, t)
{
	return "\treturn SPL_NEW_INT(ret);\n";
}

function marshal_getret_array(f, t)
{
	var matrix = [
		fann_get_cascade_activation_functions: [
			size: "fann_get_cascade_activation_steepnesses_count(arg_0)",
			type: "int"
		],
		fann_get_cascade_activation_steepnesses: [
			size: "fann_get_cascade_activation_steepnesses_count(arg_0)",
			type: "float"
		],
		fann_run: [
			size: "fann_get_num_output(arg_0)",
			type: "float"
		],
		fann_test: [
			size: "fann_get_num_output(arg_0)",
			type: "float"
		]
	];

	if (not declared matrix[f])
		return marshal_getret_fixme(f, t);
	
	import matrix[f];

	return <:>
		:	int ret_size = $size;
		:	struct spl_node *ret_node = spl_get(0);
		:	for (int i=0; i < ret_size; i++) {
		:		struct spl_node *n = spl_get(0);
		:		spl_set_$type(n, ret[i]);
		:		spl_create(t, ret_node, 0, n, SPL_CREATE_LOCAL);
		:	}
		:	return ret_node;
	</>;
}

function marshal_getret_objptr(f, t)
{
	return "\treturn objptr2spl(t, ret, \"$t\");\n";
}

var marshal_matrix = [
	"FILE *" => [
		getarg: function(f, t, n) {
			return <:>
				:	{
				:		char *s = spl_clib_get_string(t);
				:		if (!strcasecmp(s, "stdin")) arg_$n = stdin;
				:		else if (!strcasecmp(s, "stdout")) arg_$n = stdout;
				:		else if (!strcasecmp(s, "stderr")) arg_$n = stderr;
				:		else arg_$n = 0;
				:	}
			</>;
		}
	],
	"char *" => [
		getret: function(f, t) {
			return "\treturn SPL_NEW_STRING_DUP(ret);\n";
		}
	],
	"const char *" => [
		getarg: function(f, t, n) {
			return "\targ_$n = spl_clib_get_string(t);\n";
		}
	],
	"enum fann_activationfunc_enum" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"enum fann_activationfunc_enum *" => [
		getarg: marshal_getarg_array,
		getret: marshal_getret_array
	],
	"enum fann_errno_enum" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"enum fann_errorfunc_enum" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"enum fann_stopfunc_enum" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"enum fann_train_enum" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"fann_type" => [
		getarg: marshal_getarg_float,
		getret: marshal_getret_float
	],
	"fann_type *" => [
		getarg: marshal_getarg_array,
		getret: marshal_getret_array
	],
	"float" => [
		getarg: marshal_getarg_float,
		getret: marshal_getret_float
	],
	"int" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"struct fann *" => [
		getarg: marshal_getarg_objptr,
		getret: marshal_getret_objptr
	],
	"struct fann_error *" => [
		getarg: marshal_getarg_objptr,
		getret: marshal_getret_objptr
	],
	"struct fann_train_data *" => [
		getarg: marshal_getarg_objptr,
		getret: marshal_getret_objptr
	],
	"unsigned int" => [
		getarg: marshal_getarg_int,
		getret: marshal_getret_int
	],
	"unsigned int *" => [
		getarg: marshal_getarg_array
	],
];

function marshal_getarg(func, type, num)
{
	if (func =~ /^fann_set_cascade_activation_(functions|steepnesses)$/ and num == 2)
		return "\targ_2 = arg_1_size;\n";

	if (not declared marshal_matrix[type].getarg)
		return marshal_getarg_fixme(func, type, num);
	
	return marshal_matrix[type].getarg(func, type, num);
}

function marshal_getret(func, type)
{
	if (not declared marshal_matrix[type].getret)
		return marshal_getret_fixme(func, type);
	
	return marshal_matrix[type].getret(func, type);
}

foreach[] f (f_list)
{
	import f;

	write(<:>
		:
		: // Function: $f_name
		: // Return Type: $f_ret
		<spl:foreach var="i" list="f_args">
		: // Argument #$i: ${f_args[i].type} AS ${f_args[i].name}
		</spl:foreach>
		: //
		: static struct spl_node *handler_$f_name(struct spl_task *t, void *d UNUSED)
		: {
		<spl:foreach var="i" list="f_args">
		:	${f_args[i].type} arg_$i;
		</spl:foreach>
		<spl:foreach var="i" list="f_args">
			${marshal_getarg(f_name, f_args[i].type, i)}
		</spl:foreach>
		<?spl
			var call;

			if (f_ret ~!= "void")
				call ~= "$f_ret ret = ";

			call ~= "$f_name(";

			foreach i (f_args) {
				if (i) call ~= ", ";
				call ~= "arg_$i";
			}

			call ~= ");";
		?>
		:	$call
		<?spl if (f_ret ~!= "void") { ?>
			${marshal_getret(f_name, f_ret)}
		<?spl } else { ?>
		:	return 0;
		<?spl } ?>
		: }
	</>);

}

write(<:>
	:
	: /**
	:  * The following FANN functions are available via this SPL module:
	:  *
	<spl:foreach var="f" list="f_list">
	:  *	${f_list[f].f_name}(${f_list[f].f_argsdecl});
	</spl:foreach>
	:  */
	: // manual function_list;
	:
	: /**
	:  * This function converts a FANN enum name to its integer value.
	:  */
	: // builtin fann_enum(enum_name);
	: static struct spl_node *handler_fann_enum(struct spl_task *t, void *d UNUSED)
	: {
	:	char *etext = spl_clib_get_string(t);
	:
	<spl:foreach var="e" list="e_list">
	:	if (!strcmp(etext, "$e"))
	:		return SPL_NEW_INT($e);
	</spl:foreach>
	:
	:	spl_clib_exception(t, "FannEx", "description",
	:			SPL_NEW_PRINTF("Unknown FANN Enum: %s", etext),
	:			NULL);
	:	return 0;
	: }
	:
	: /**
	:  * An instance of this object is thrown on errors. Note that this
	:  * exception object is only used for errors in the FANN<->SPL
	:  * bindings. Errors which happened in FANN are handled using the
	:  * usual FANN error handling mechanism.
	:  */
	: //object FannEx
	: 
	: /**
	:  * A description text describing the error.
	:  */
	: // var description;
	:
	: // Types summary (arg, ret):
	<spl:foreach var="t" list="types">
	: // ${fmt("%-32s", t)} [${fmt("%2d", types_arg[t])}x] [${fmt("%2d", types_ret[t])}x]
	</spl:foreach>
	:
	: void SPL_ABI(spl_mod_fann_init)(struct spl_vm *vm, struct spl_module *mod UNUSED, int restore UNUSED)
	: {
	:	if (!restore)
	:		spl_eval(vm, 0, strdup(mod->name), "object FannEx { }");
	:
	:	// some paranoia checks
	:	assert(sizeof(enum fann_activationfunc_enum) == sizeof(int));
	:	assert(sizeof(fann_type) == sizeof(float));
	:
	:	spl_hnode_reg(vm, "fann", handler_fann_node, 0);
	:
	<spl:foreach var="f" list="f_list">
	:	${ f_list[f].fixme ? "// " : "" }spl_clib_reg(vm, "${f_list[f].f_name}", handler_${f_list[f].f_name}, 0);
	</spl:foreach>
	:	spl_clib_reg(vm, "fann_enum", handler_fann_enum, 0);
	: }
	:
	: void SPL_ABI(spl_mod_fann_done)(struct spl_vm *vm UNUSED, struct spl_module *mod UNUSED)
	: {
	:	return;
	: }
	:
</>);