/**********************************************************************
 
	Copyright (C) 2005- Hirohisa MORI <joshua@nichibun.ac.jp>
 
	This program is free software; you can redistribute it 
	and/or modify it under the terms of the GLOBALBASE 
	Library General Public License (G-LGPL) as published by 

	http://www.globalbase.org/
 
	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.

**********************************************************************/

#include	"machine/include.h"
#include	"memory_debug.h"
#include	"pri_level.h"
#include	"lock_level.h"
#include	"utils.h"
#include	"task.h"
#include	"matrix.h"
#include	"xl.h"
#include	"xlerror.h"
#include	"memory_routine.h"


XL_SEXP *
xl_mxThinnedOut(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a,XL_SYM_FIELD * sf);

void
init_mxThinnedOut(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"mxThinnedOut"),
		get_func_prim(xl_mxThinnedOut,FO_APPLICATIVE,0,2,3));
}


XL_SEXP *
xl_mxThinnedOut(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a,XL_SYM_FIELD * sf)
{
L_CHAR * opt;
int _opt;
MATRIX_TOKEN * t;
INTEGER64 * dim_code1;
void * d1, * dest;
MATRIX_DH_SET dh1;
MATRIX_DATA_TYPE * tp;
int _ret;
XL_SEXP * ret;
XL_SEXP * target_list, * sym;
XL_SEXP * sample,* dc;
int * rep_code;
L_CHAR * ch;
int _ch;
void * def_data;
MATRIX * m;
char * err_msg = 0;
	dim_code1 = 0;
	rep_code = 0;
	t = get_env_work(env);
	if ( t == 0 )
		return 0;
	m = t->process_node->matrix;
	opt = get_sf_attribute(sf,l_string(std_cm,"type"));
	if ( opt == 0 )
		_opt = 0;
	else if ( l_strcmp(opt,l_string(std_cm,"representative")) == 0 ) {
		_opt = 0;
		rep_code = get_dim_code_from_sexp_int(get_el(s,2));
		err_msg = "rep_code required";
		if ( rep_code == 0 ) {
			rep_code = d_alloc(sizeof(int)*m->p.dim);
			memset(rep_code,0,sizeof(int)*m->p.dim);
		}
	}
	else if ( l_strcmp(opt,l_string(std_cm,"avarage")) == 0 )
		_opt = 1;
	else {
		err_msg = n_string(std_cm,opt);
		goto inv_param;		
	}

	ch = get_sf_attribute(sf,l_string(std_cm,"channel"));
	if ( ch ) {
		_ch = atoi(n_string(std_cm,ch));
		err_msg = "channel No.";
		if ( _ch < 0 || 
			_ch >= t->process_node->matrix->p.channel_nos )
			goto inv_param;
		def_data = t->process_node->matrix->channel_info[_ch].default_data;
	}
	else	def_data = 0;

	target_list = get_el(s,1);


	err_msg = "target-list not a LIST";
	if ( get_type(target_list) != XLT_PAIR )
		goto type_missmatch;
	sym = car(target_list);
	err_msg = "target-list SYMBOL not a SYMBOL";
	if ( get_type(sym) != XLT_SYMBOL )
		goto type_missmatch;
	if ( l_strcmp(sym->symbol.data,l_string(std_cm,"data")) == 0 ) {
		sample = target_list;
		target_list = cons(target_list,0);
	}
	else if ( l_strcmp(sym->symbol.data,
			l_string(std_cm,"Children")) == 0 ) {
		target_list = cdr(target_list);
		sample = car(target_list);
	}
	else {
		err_msg = "target-list data or Children is required";
		goto type_missmatch;
	}


	d1 = get_vdata_from_sexp(get_el(sample,2));
	if ( d1 == 0 ) {
		err_msg = "CH data type";
		goto type_missmatch;
	}
	get_matrix_dh_set(&dh1,d1);	

	tp = get_matrix_data_type(dh1.hd->type);
	dest = mxt_alloc_vector_by_dim_code(
		t->process_node->matrix,tp,MD_MMALLOC,t->process_node->dim_code,
		def_data);

	dim_code1 = 0;
	for ( ; get_type(target_list) == XLT_PAIR ; target_list = cdr(target_list) ) {
		dc = car(target_list);
		if ( dim_code1 )
			d_f_ree(dim_code1);
		dim_code1 = get_dim_code_from_sexp(get_el(dc,1));
		err_msg = "cannot convert dim_code";
		if ( dim_code1 == 0 )
			goto type_missmatch;
		d1 = get_vdata_from_sexp(get_el(dc,2));
		err_msg = "CH data type(2)";
		if ( d1 == 0 )
			goto type_missmatch;
		if ( _opt == 0 )
			_ret = (*tp->thinned_rep)(tp,t->process_node
							->matrix,
						dim_code1,rep_code,1,
						dest,d1);
		else	_ret = (*tp->thinned_avg)(tp,t->process_node
							->matrix,
						dim_code1,1,
						dest,d1);
		if ( _ret < 0 )
			goto matrix_err;
	}

	ret = List(
		n_get_symbol("data"),
		get_sexp_from_dim_code(t->process_node->matrix,
				t->process_node->dim_code),
		get_ptr(dest,gc_text),
		-1);
	goto end;

type_missmatch:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"mxThinnedOut"),
		n_get_string(err_msg));
	goto end;
inv_param:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"mxThinnedOut"),
		List(n_get_string("invalid parameter in mxThinnedOut"),
			n_get_string(err_msg),
			-1)
			);
	goto end;
matrix_err:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_OBJECT,
		l_string(std_cm,"mxThinnedOut"),
		List(n_get_string("invalid matrix loading"),
			get_integer(_ret,0),
			-1));
end:
	if ( dim_code1 )
		d_f_ree(dim_code1);
	if ( rep_code )
		d_f_ree(rep_code);
	return ret;
}





