/**********************************************************************
 
	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	"xl.h"
#include	"unit.h"


int
field_equals(XL_SYM_FIELD * sf_1,XL_SYM_FIELD * sf_2)
{
L_CHAR * attr;
XL_SYM_FIELD * sf;
	if ( sf_1 == sf_2 )
		return 1;
	for ( sf = sf_1 ; sf ; sf = sf->next ) {
		attr = get_sf_attribute(sf_2,sf->name);
		if ( attr == 0 )
			return 0;
		if ( l_strcmp(sf->data,attr) )
			return 0;
	}
	for ( sf = sf_2 ; sf ; sf = sf->next ) {
		attr = get_sf_attribute(sf_1,sf->name);
		if ( attr == 0 )
			return 0;
		if ( l_strcmp(sf->data,attr) )
			return 0;
	}
	return 1;
}


XL_SEXP *
equ_sym(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
	if ( l_strcmp(s1->symbol.data,s2->symbol.data) == 0 ) {
		if ( field_equals(s1->symbol.field,s2->symbol.field) )
			return get_integer(1,0);
		return get_integer(0,0);
	}
	else	return get_integer(0,0);
}

XL_SEXP *
equ_str(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
	if ( l_strcmp(s1->string.data,s2->string.data) == 0 )
		return get_integer(1,0);
	else	return get_integer(0,0);
}

XL_SEXP *
equ_func(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
	return get_integer(0,0);
}

int
equ_conv_int(XLISP_ENV * env,int * i1,int * i2,XL_SEXP * s1,XL_SEXP * s2)
{
int _i1,_i2;
DIMENSION d1[DIM],d2[DIM],dest[DIM];
int ret;
int er;

	name2dim(get_uenv(env),d1,s1->integer.unit);
	name2dim(get_uenv(env),d2,s2->integer.unit);
	if ( dim_power_cmp(d1,d2) )
		return -1;
	fit_dimension_integer(dest,d1,d2);
	_i1 = conv_unit_integer(&er,get_uenv(env),s1->integer.data,d1,dest);
	_i2 = conv_unit_integer(&er,get_uenv(env),s2->integer.data,d2,dest);
	*i1 = _i1;
	*i2 = _i2;
	return 0;
}


int
equ_conv_float(XLISP_ENV * env,
	       double * i1,double * i2,XL_SEXP * s1,XL_SEXP * s2)
{
DIMENSION d1[DIM],d2[DIM],dest[DIM];
double ret;
int er;
double _i1,_i2;

	name2dim(get_uenv(env),d1,s1->floating.unit);
	name2dim(get_uenv(env),d2,s2->floating.unit);
	if ( dim_power_cmp(d1,d2) )
		return -1;
	fit_dimension_floating(dest,d1,d2);
	_i1 = conv_unit_floating(&er,get_uenv(env),s1->floating.data,d1,dest);
	_i2 = conv_unit_floating(&er,get_uenv(env),s2->floating.data,d2,dest);
	*i1 = _i1;
	*i2 = _i2;
	return 0;
}


XL_SEXP *
equ_int(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
int i1,i2;
	if ( equ_conv_int(env,&i1,&i2,s1,s2) < 0 )
		return get_integer(0,0);
	if ( i1 == i2 )
		return get_integer(1,0);
	else	return get_integer(0,0);
}

XL_SEXP *
equ_float(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
double i1,i2;
	if ( equ_conv_float(env,&i1,&i2,s1,s2) < 0 )
		return get_integer(0,0);
	if ( i1 == i2 )
		return get_integer(1,0);
	else	return get_integer(0,0);
}

XL_SEXP *
equ_pair(XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
extern BINARY_TABLE equ_t[XLT_MAX][XLT_MAX];
XL_SEXP * a;
int type1,type2;
	for ( ; ; ) {
		type1 = get_type(s1);
		type2 = get_type(s2);
		if ( type1 == XLT_ERROR )
			return s1;
		if ( type2 == XLT_ERROR )
			return s2;
		if ( type1 == 0 && type2 == 0 )
			return get_integer(1,0);
		if ( type1 == 0 || type2 == 0 )
			return get_integer(0,0);
		if ( type1 != XLT_PAIR || type2 != XLT_PAIR )
			return binary(equ_t,env,s1,s2);
		a = binary(equ_t,env,car(s1),car(s2));
		if ( a->integer.data == 0 )
			return a;

		s1 = cdr(s1);
		s2 = cdr(s2);
	}
}

XL_SEXP *
gb_equ(XLISP_ENV * e,XL_SEXP * s)
{
extern BINARY_TABLE equ_t[XLT_MAX][XLT_MAX];
	return binary(
		equ_t,
		e,
		get_el(s,1),
		get_el(s,2));
}

int
gbb_equ(XL_SEXP * s1,XL_SEXP * s2)
{
extern BINARY_TABLE equ_t[XLT_MAX][XLT_MAX];
XL_SEXP * ret;
	ret = binary(equ_t,gblisp_top_env0,s1,s2);
	switch ( get_type(ret) ) {
	case XLT_INTEGER:
		return ret->integer.data;
	case XLT_FLOAT:
		return ret->floating.data;
	default:
		return -1;
	}
}
