/**********************************************************************
 
	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	"xlerror.h"

XL_SEXP * xl_NaturalJoin();
XL_SEXP * sort_list();

void
init_NaturalJoin(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"NaturalJoin"),
		get_func_prim(xl_NaturalJoin,FO_APPLICATIVE,0,3,3));
}

int
njoin_cmp_field(XL_SEXP ** retp,XLISP_ENV * env,XL_SEXP * s1,XL_SEXP * s2)
{
extern BINARY_TABLE lt_t[XLT_MAX][XLT_MAX];
XL_SEXP * ret;

	ret = binary(lt_t,env,s1,s2);
	switch ( get_type(ret) ) {
	case XLT_INTEGER:
		if ( ret->integer.data )
			return -1;
		break;
	default:
		*retp = ret;
		return -2;
	}
	ret = binary(lt_t,env,s2,s1);
	switch ( get_type(ret) ) {
	case XLT_INTEGER:
		if ( ret->integer.data )
			return 1;
		else	return 0;
	}
	*retp = ret;
	return -2;
}

int
njoin_cmp_field_list(XL_SEXP ** retp,
	XLISP_ENV * env,
	XL_SEXP * flist,
	XL_SEXP * s1,XL_SEXP * s2)
{
XL_SEXP * field;
XL_SEXP * xl_GetElement();
XL_SEXP * ss1,* ss2;
int ret;
	for ( ; get_type(flist) ; flist = cdr(flist) ) {
		field = car(flist);
		if ( get_type(field) != XLT_SYMBOL )
			er_panic("njoin_cmp_field_list");
		ss1 = xl_GetElement(0,
			List(n_get_symbol("GetElement"),s1,field,-1));
		ss2 = xl_GetElement(0,
			List(n_get_symbol("GetElement"),s2,field,-1));
		ret = njoin_cmp_field(retp,env,ss1,ss2);
		if ( ret )
			return ret;
	}
	return 0;
}

XL_SEXP *
njoin_cmp_s(XLISP_ENV * e,XL_SEXP * s)
{
XL_SEXP * s1,* s2, * ret;
XL_SEXP * flist;
int r;
	s1 = get_el(s,1);
	s2 = get_el(s,2);
	flist = eval(e,n_get_symbol("field-list"));
	if ( flist == 0 )
		return 0;
	r = njoin_cmp_field_list(&ret,e,flist,s1,s2);
	if ( r == -2 )
		return ret;
	return get_integer(r,0);
}

int
get_sort_option(XL_SYM_FIELD * sf)
{
int opt;
	opt = RO_SORT1|RO_SORT2;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"sort1")) == 0 ) {
			if ( l_strcmp(sf->data,l_string(std_cm,"off")) == 0 ) {
				opt &= ~RO_SORT1;
			}
			else {
				opt |= RO_SORT1;
			}
		}
		else if ( l_strcmp(sf->name,l_string(std_cm,"sort2")) == 0 ) {
			if ( l_strcmp(sf->data,l_string(std_cm,"off")) == 0 ) {
				opt &= ~RO_SORT2;
			}
			else {
				opt |= RO_SORT2;
			}
		}
	}
	return opt;
}

XL_SEXP *
get_join_option(XL_SYM_FIELD * sf)
{
XL_SEXP * ret, * ret2;
L_CHAR * buf;
L_CHAR * p1,*p2;
L_CHAR ch;
	ret = 0;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"field")) == 0 )
			goto ok;
	}
	return 0;
ok:
	buf = ll_copy_str(sf->data);
	p1 = buf;
	ch = buf[0];
	for ( ; ch ; ) {
		p2 = p1;
		for ( ; *p1 && *p1 != ',' ; p1 ++ );
		ch = *p1;
		*p1 = 0;
		ret = cons(
			get_symbol(p2),
				ret);
		p1 ++;
	}
	ret2 = 0;
	for ( ; ret ; ret = cdr(ret) )
		ret2 = cons(car(ret),ret2);
	return ret2;
}

XL_SEXP *
_make_record(L_CHAR * field,XL_SEXP * b)
{
XL_SEXP * c, * sym, * r;
	c = 0;
	for ( ; get_type(b) ; b = cdr(b) ) {
		r = car(b);
		if ( get_type(r) != XLT_PAIR ) {
			c = cons(r,c);
			continue;
		}
		sym = car(r);
		if ( get_type(sym) != XLT_SYMBOL ) {
			c = cons(r,c);
			continue;
		}
		if ( l_strcmp(sym->symbol.data,field) == 0 )
			continue;
		c = cons(r,c);
	}
	b = 0;
	for ( ; get_type(c) ; c = cdr(c) ) {
		b = cons(car(c),b);
	}
	return b;
}

XL_SEXP * 
make_record(XL_SEXP * flist,XL_SEXP * a,XL_SEXP * b)
{
	if ( get_type(car(b)) == XLT_SYMBOL )
		b = cdr(b);
	for ( ; get_type(flist) ; flist = cdr(flist) )
		b = _make_record(car(flist)->symbol.data,b);
	return append(a,b);
}

XL_SEXP *
xl_NaturalJoin(XLISP_ENV * env,XL_SEXP * s,
	      XLISP_ENV * a,XL_SYM_FIELD * sf)
{
int opt;
XL_SEXP * s1,* s2, * sp1, * sp2;
XL_SEXP * field_list;
XL_SEXP * nj_cmp;
XLISP_ENV * e;
int cmp;
XL_SEXP * ret;
XL_SEXP * result;
	opt = get_sort_option(sf);
	field_list = get_join_option(sf);
	s1 = get_el(s,1);
	s2 = get_el(s,2);
	e = new_env(gblisp_top_env0);
	set_env(e,l_string(std_cm,"field-list"),field_list);
	nj_cmp = get_func_prim(njoin_cmp_s,FO_APPLICATIVE,0,3,3);
	if ( opt & RO_SORT1 )
		s1 = sort_list(e,s1,nj_cmp);
	if ( opt & RO_SORT2 )
		s2 = sort_list(e,s2,nj_cmp);
	result = 0;
	for ( ; get_type(s1) == XLT_PAIR && get_type(s2) == XLT_PAIR ; ) {
/*
print_sexp(s_stdout,car(s1),0);
printf(" -- ");
print_sexp(s_stdout,car(s2),0);
*/
		cmp = njoin_cmp_field_list(&ret,env,field_list,car(s1),car(s2));
/*
printf(" + %i\n",cmp);
*/
		switch ( cmp ) {
		case 0:
			break;
		case -1:
			s1 = cdr(s1);
			continue;
		case 1:
			s2 = cdr(s2);
			continue;
		case -2:
			return ret;
		}
		sp2 = s2;
		for ( ; ; ) {
			cmp = njoin_cmp_field_list(&ret,
				env,
				field_list,car(s1),car(sp2));
			switch ( cmp ) {
			case 0:
				result = cons(
					make_record(field_list,
						car(s1),car(sp2)),
					result);
				sp2 = cdr(sp2);
				if ( sp2 == 0 )
					break;
				continue;
			case -2:
				return ret;
			default:
				break;
			}
			break;
		}
		s1 = cdr(s1);
	}
	return result;
}
