/**********************************************************************
 
	Copyright (C) 2003 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	"memory_debug.h"
#include	"ex_matrix.h"


EX_MATRIX *
new_ex_matrix(int v,int h)
{
EX_MATRIX * ret;
EX_MATRIX m;
int size,i;
	m.h_size = h;
	m.v_size = v;
	ret = d_alloc(size=((int)(&XD(&m,v,0)))-((int)&m));
	for ( i = 0 ; i < h*v ; i ++ )
		ret->d[i] = 0;
	ret->h_size = h;
	ret->v_size = v;

	return ret;
}

void
free_ex_matrix(EX_MATRIX * m)
{
	d_f_ree(m);
}

EX_MATRIX *
add_ex(EX_MATRIX * m1,EX_MATRIX * m2)
{
int i;
EX_MATRIX * ret;
int h,v;
	if ( m1->h_size != m2->h_size )
		return 0;
	if ( m1->v_size != m2->v_size )
		return 0;
	h = m1->h_size;
	v = m1->v_size;
	ret = new_ex_matrix(v,h);
	for ( i = 0 ; i < m1->h_size * m1->v_size ; i ++ )
		ret->d[i] = m1->d[i] + m2->d[i];
	return ret;
}

EX_MATRIX *
sub_ex(EX_MATRIX * m1,EX_MATRIX * m2)
{
int i;
EX_MATRIX * ret;
int h,v;

	if ( m2 ) {
		if ( m1->h_size != m2->h_size )
			return 0;
		if ( m1->v_size != m2->v_size )
			return 0;
		h = m1->h_size;
		v = m1->v_size;
		ret = new_ex_matrix(v,h);
		for ( i = 0 ; i < m1->h_size * m1->v_size ; i ++ )
			ret->d[i] = m1->d[i] - m2->d[i];
		return ret;
	}
	else {
		h = m1->h_size;
		v = m1->v_size;
		ret = new_ex_matrix(v,h);
		for ( i = 0 ; i < m1->h_size * m1->v_size ; i ++ )
			ret->d[i] =  - m1->d[i];
		return ret;
	}
}

EX_MATRIX * 
mul_ex(EX_MATRIX * m1,EX_MATRIX * m2)
{
EX_MATRIX * ret;
int x,y,i,len;
int h,v;
double acc;
	if ( m1->h_size != m2->v_size )
		return 0;
	len = m1->h_size;
	ret = new_ex_matrix(v = m1->v_size,h = m2->h_size);
	for ( x = 0 ; x < h ; x ++ )
		for ( y = 0 ; y < v ; y ++ ) {
			acc = 0;
			for ( i= 0 ; i < len ; i ++ )
				acc += XD(m1,y,i)*XD(m2,i,x);
			XD(ret,y,x) = acc;
		}
	return ret;
}

double
inner_ex(int * er,EX_MATRIX * m1,EX_MATRIX * m2)
{
double ret;
int i,size;
	*er = -1;

	if ( m1->h_size != m2->h_size )
		return 0;
	if ( m1->v_size != m2->v_size )
		return 0;
	if ( m1->h_size != 1 && m1->v_size != 1 )
		return 0;
	size = m1->h_size* m1->v_size;
	ret = 0;
	for ( i = 0 ; i < size ; i ++ )
		ret += m1->d[i] * m2->d[i];
	*er = 0;
	return ret;
}


EX_MATRIX *
get_ex_from_sexp(XL_SEXP * s)
{
XL_SEXP * sym;
L_CHAR * h, * v;
int _h,_v;
EX_MATRIX * ret;
int i;
XL_SEXP * d;

	if ( get_type(s) != XLT_PAIR )
		return 0;
	sym = car(s);
	if ( get_type(sym) != XLT_SYMBOL )
		return 0;
	h = get_sf_attribute(sym->symbol.field,l_string(std_cm,"h"));
	v = get_sf_attribute(sym->symbol.field,l_string(std_cm,"v"));
	if ( h )
		_h = atoi(n_string(std_cm,h));
	else	_h = 1;
	if ( _h == 0 )
		_h = 1;
	if ( v )
		_v = atoi(n_string(std_cm,v));
	else	_v = 1;
	if ( _v == 0 )
		_v = 1;
	ret = new_ex_matrix(_v,_h);
	s = cdr(s);
	for ( i = 0 ; i < _v*_h ; i ++ , s = cdr(s) ) {
		if ( get_type(s) != XLT_PAIR )
			goto err;
		d = car(s);
		switch ( get_type(d) ) {
		case XLT_INTEGER:
			ret->d[i] = d->integer.data;
			break;
		case XLT_FLOAT:
			ret->d[i] = d->floating.data;
			break;
		default:
			goto err;
		}
	}
	return ret;
err:
	free_ex_matrix(ret);
	return 0;
}

XL_SEXP *
get_sexp_from_ex(EX_MATRIX * m)
{
XL_SEXP * ret;
XL_SEXP * sym;
char buf[10];
int total,i;

	sym = n_get_symbol("matrix");
	sprintf(buf,"%i",m->v_size);
	set_attribute(sym,
		l_string(std_cm,"v"),
		l_string(std_cm,buf));
	sprintf(buf,"%i",m->h_size);
	set_attribute(sym,
		l_string(std_cm,"h"),
		l_string(std_cm,buf));
	ret = cons(sym,0);
	total = m->v_size*m->h_size;
	for ( i = 0 ; i < total ; i ++ )
		ret = cons(get_floating(m->d[i],0),ret);
	return reverse(ret);
}

