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

XL_SEXP * xl_Sort();

typedef struct sort_element {
	struct sort_element *	next;
	XL_SEXP *		el;
} SORT_ELEMENT;

typedef struct sort_list {
	struct sort_list *	next;
	SORT_ELEMENT *		el;
} SORT_LIST;

void
print_sort_list(SORT_LIST * sl)
{
SORT_ELEMENT * se;
	printf("SL\n");
	for ( ; sl ; sl = sl->next ) {
		printf("\t[");
		for ( se = sl->el ; se ; se = se->next ) {
			print_sexp(s_stdout,se->el,0);
			printf(",");
		}
		printf("]\n");
	}
}

SORT_LIST *
get_sort_list(XL_SEXP * s)
{
SORT_LIST * sl1,*sl2;
SORT_ELEMENT * se1;
	sl1 = 0;
	for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
		se1 = d_alloc(sizeof(*se1),55);
		se1->el = car(s);
		se1->next = 0;
		sl2 = d_alloc(sizeof(*sl2),25);
		sl2->el = se1;
		sl2->next = sl1;
		sl1 = sl2;
	}
	return sl1;
}

void
free_sort_element(SORT_ELEMENT * se)
{
SORT_ELEMENT * se1;
	for ( ; se ; ) {
		se1 = se->next;
		d_f_ree(se);
		se = se1;
	}
}

void
free_sort_list(SORT_LIST * sl)
{
SORT_LIST *sl1;
	for ( ; sl ; ) {
		sl1 = sl->next;
		free_sort_element(sl->el);
		d_f_ree(sl);
		sl = sl1;
	}
}

SORT_LIST *
marge_sort_list(XL_SEXP ** retp,
	SORT_LIST * sl,XLISP_ENV * env,XL_SEXP * func)
{
SORT_ELEMENT * se1, * se2, ** sep;
SORT_ELEMENT * se3;
SORT_LIST * sl1;
XL_SEXP * ret;

	*retp = 0;
	if ( sl == 0 )
		return 0;
	if ( sl->next == 0 )
		return sl;
	se1 = sl->el;
	se2 = sl->next->el;

	sl1 = sl;
	sl = sl->next;
	d_f_ree(sl1);

	sl->el = 0;
	sep = &sl->el;

	for ( ; se1 && se2 ; ) {
		gc_push(0,0,"Sort");
		ret = eval(env,
			List(func,
				List(get_symbol(l_string(std_cm,"quote")),
					se1->el,
					-1),
				List(get_symbol(l_string(std_cm,"quote")),
					se2->el,
					-1),
				-1));
		switch ( get_type(ret) ) {
		case XLT_ERROR:
			*retp = ret;
			free_sort_element(se1);
			free_sort_element(se2);
			free_sort_list(sl);
			gc_pop(0,0);
			return 0;
		case XLT_INTEGER:
			break;
		default:
			*retp = get_error(
				func->h.file,
				func->h.line,
				XLE_SEMANTICS_TYPE_MISSMATCH,
				l_string(std_cm,"Sort"),
				n_get_string(
			"return value type missmatch of compare function"));
			free_sort_element(se1);
			free_sort_element(se2);
			free_sort_list(sl);
			gc_pop(0,0);
			return 0;
		}
		if ( ret->integer.data < 0 ) {
			se3 = se2;
			se2 = se2->next;
		}
		else {
			se3 = se1;
			se1 = se1->next;
		}
		gc_pop(0,0);
		se3->next = 0;
		*sep = se3;
		sep = &se3->next;
	}
	if ( se1 )
		*sep = se1;
	else	*sep = se2;
	return sl;
}

void
init_Sort(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Sort"),
		get_func_prim(xl_Sort,FO_APPLICATIVE,0,2,3));
}

XL_SEXP *
sort_list(XLISP_ENV * env,XL_SEXP * list,XL_SEXP * func)
{
SORT_LIST * sl1, * sl2, * sl3;
XL_SEXP * ret;
SORT_ELEMENT * se1;
	sl1 = get_sort_list(list);
	if ( sl1 == 0 )
		return list;
	for ( ; sl1->next ; ) {
		sl2 = 0;
		for ( ; sl1 ; ) {
			sl1 = marge_sort_list(&ret,sl1,env,func);
			if ( get_type(ret) == XLT_ERROR ) {
				free_sort_list(sl2);
				return ret;
			}
			if ( sl1 == 0 )
				er_panic("Sort");
			sl3 = sl1;
			sl1 = sl1->next;
			sl3->next = sl2;
			sl2 = sl3;
		}
		sl1 = sl2;
	}
	ret = 0;
	for ( se1 = sl1->el ; se1 ; se1 = se1->next )
		ret = cons(se1->el,ret);
	free_sort_list(sl1);
	return ret;
}




XL_SEXP *
xl_Sort(XLISP_ENV * env,XL_SEXP * s,
	XLISP_ENV * a,XL_SYM_FIELD * sf)
{
XL_SEXP * list, * func;
char * tm;
XL_SEXP * field_list;
XLISP_ENV * e;
extern XL_SEXP * njoin_cmp_s();
extern XL_SEXP * get_join_option();
	field_list = get_join_option(sf);
	list = get_el(s,1);
	if ( get_type(list) != XLT_PAIR ) {
		tm = "list";
		goto type_missmatch;
	}
	if ( field_list == 0 ) {
		func = get_el(s,2);
		if ( get_type(func) != XLT_FUNC ) {
			tm = "compare function";
			goto type_missmatch;
		}
		e = env;
	}
	else {
		func = get_func_prim(njoin_cmp_s,FO_APPLICATIVE,0,3,3);
		e = new_env(env);
		set_env(e,l_string(std_cm,"field-list"),field_list);
	}
	return sort_list(e,list,func);
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"Sort"),
		List(n_get_string(tm),
			n_get_string("is type missmatch"),
			-1));
}
