// Copyright (C) 1996 DIMACS Center, Rutgers, The State University of New Jersey
// Author(s): Jonathan Berry

// This software is copyrighted by the DIMACS Center at Rutgers, The State
// University of New Jersey.  IT IS PROVIDED AS IS, AND THE AUTHORS, DIMACS, AND
// RUTGERS, THE STATE UNIVERSITY OF NEW JERSEY  DISCLAIM
// ALL LIABILITY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
// DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
// DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
// POSSIBILITY OF SUCH DAMAGE.

// THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
// INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
// FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
// IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
// NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
// MODIFICATIONS.

// The authors hereby grant permission to use, copy, modify, distribute,
// and license this software and its documentation for any purpose, provided
// that existing copyright notices are retained in all copies and that this
// notice is included verbatim in any distributions. No written agreement,
// license, or royalty fee is required for any of the authorized uses.
// Modifications to this software may be copyrighted by their authors
// and need not follow the licensing terms described here, provided that
// the new terms are clearly indicated on the first page of each file where
// they apply.

// Last File Update: 31-Jul-1996
// 

#include <stk.h>
#include <iostream.h>
#include <strstream.h>
#include <LINK/stkWrapper/LINK_STk.h>


template <class T> 
Array<T>* 
ArrayWrapper<T>::getArray(SCM p)
{
	int &Array_Type 	= Wrapper<Array<T> >::type;
	Array<T> *cp;
	if (CXX_TYPEP(p, Array_Type))
		cp = (Array<T>*) CLASSDATA(p);
	else
		cp = 0;
	return cp;
}

template <class T> 
Bool 
ArrayWrapper<T>::isArray(SCM p)
{
	int &Array_Type 	= Wrapper<Array<T> >::type;
	if (CXX_TYPEP(p, Array_Type))
		return TRUE;
	return FALSE;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::linkArrayP(SCM l)
{
	return  isArray(l) ? Truth : Ntruth; 
}

template <class T> 
void 
ArrayWrapper<T>::markTypedArray(SCM p)
{}

template <class T> 
void 
ArrayWrapper<T>::freeTypedArray(SCM p)
{
	int &Array_Type 	= Wrapper<Array<T> >::type;

	if (CXXw_TYPEP(p, Array_Type))
		if (!EXTSTATICP(p))
	    		delete (Array<T> *) EXTDATA(p); 
	else
		Err("free-typed-array: wrong type of argument", p);
}
	
template <class T> 
void 
ArrayWrapper<T>::displayTypedArray(SCM c, SCM port, int mode)
{
	int &Array_Type 	= Wrapper<Array<T> >::type;

	Array<T>* cp;
	if (CXXw_TYPEP(c, Array_Type))
		cp = (Array<T>*) EXTDATA(c);
	else 
		Err("display-typed-array: wrong type of argument", c);
        ostrstream oss;
        cp->display(oss);
	oss << ends;
        char *buffer = oss.str();
        Puts(buffer, FILEPTR(port));
        delete buffer;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::makeLinkArray(SCM k)
{
	int x = STk_integer_value(k);
	SCM ns;
	Array<T>* new_array;
	int &Array_Type = Wrapper<Array<T> >::type;
	char*Array_Name = Wrapper<Array<T> >::name;

        new_array = new Array<T>(x);
	ns = STk_make_CXXwrapper(Array_Type,Array_Name,
				 (void*)new_array,LINK_DYNAMIC);
	return ns;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::makeFilledLinkArray(SCM k, SCM e)
{
	int i;
	int x = STk_integer_value(k);
	SCM ns;
	Array<T>* new_array;
	int &Array_Type = Wrapper<Array<T> >::type;
	char*Array_Name = Wrapper<Array<T> >::name;

	if  (CXX_NTYPEP(e, Wrapper<T>::type))
                Err("typed-array-insert: wrong type of argument", e);

        new_array = new Array<T>(x);
	ns = STk_make_CXXwrapper(Array_Type,Array_Name,
				 (void*)new_array,LINK_DYNAMIC);
	T elem =  * (T *) CLASSDATA(e);
	for (i=0; i<x; i++)
		(*new_array)[i] = elem;
	return ns;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::copyLinkArray(SCM l)
{
	SCM ns;
	Array<T> *new_array, *old_array;
	int &Array_Type = Wrapper<Array<T> >::type;
	char*Array_Name = Wrapper<Array<T> >::name;

	if (isArray(l))
		old_array = getArray(l);	

        new_array = new Array<T>(*old_array);
	ns = STk_make_CXXwrapper(Array_Type,Array_Name,
				 (void*)new_array,LINK_DYNAMIC);
	return ns;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::fillLinkArray(SCM l, SCM e)
{
	int i, count;
	Array<T>* a;

	if  (CXX_NTYPEP(l, Wrapper<Array<T> >::type))
                Err("typed-array-insert: argument not an array", l);
	if  (CXX_NTYPEP(e, Wrapper<T>::type))
                Err("typed-array-insert: wrong type of argument", e);

        if (isArray(l))
        	a = getArray(l);
	T elem =  * (T *) CLASSDATA(e);
	count = a->_size;		//need to be a friend of class Array
	for (i=0; i<count; i++)		//or else it needs an allocation() mth.
		(*a)[i] = elem;
	return UNDEFINED;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::buildLinkArray(SCM l)
{
	int i;
	SCM tmp, ns;
	Array<T>* new_array;
	int &Array_Type = Wrapper<Array<T> >::type;
	char*Array_Name = Wrapper<Array<T> >::name;

	if (l == NIL)
                new_array = new Array<T>;
	else if (INTEGERP(l)) {
                new_array = new Array<T>(INTEGER(l));
	} else if (isArray(l)) {
		new_array = getArray(l);
		new_array = new Array<T>(*new_array);
	} else 
		Err("typed-array: wrong type of argument", l);
	ns = STk_make_CXXwrapper(Array_Type,Array_Name,
				 (void*)new_array,LINK_DYNAMIC);
	return ns;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::stkList2LinkArray(SCM l)
{
	return buildLinkArray(l);
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::linkArray2STkList(SCM l)
{
	SCM z;

	if (!isArray(l))
		Err("typed-array-convert: wrong type of argument", l);
	Array<T> *cp = getArray(l);
	//cp->display(cout);
	Iterator<T> get_next(cp);
	T e;
	if (get_next(e)) {
		SCM new_el = STk_make_CXXwrapper(Wrapper<T>::type, 
			Wrapper<T>::name, (void*) new T(e), LINK_DYNAMIC);
		SCM tail, head;
		NEWCELL(tail, tc_cons);
		CAR(tail) = new_el;
		CDR(tail) = NIL;
		head = tail;
		SCM z;
		while (get_next(e)) {
			SCM new_el  = STk_make_CXXwrapper(Wrapper<T>::type, 
				Wrapper<T>::name,(void*) new T(e),LINK_DYNAMIC);
			NEWCELL(z, tc_cons);
			CAR(z) = new_el;
			CDR(z) = NIL;
			CDR(tail) = z;
			tail = z;
		}
		return head;
	}
	return NIL;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::lengthLinkArray(SCM l)
{
	if (!isArray(l))
		Err("typed-array-length: wrong type of argument", l);
	Array<T> *cp = getArray(l);
	SCM z;
  	NEWCELL(z, tc_integer);
  	SET_INTEGER(z, cp->size());
  	return z;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::eqvLinkArray(SCM l, SCM l2)
{
/*
	if (Wrapper<Array<T> >::compareItems(l, l2) == 0)
		return Truth;
	return Ntruth;
*/
	if (!isArray(l))
		Err("typed-array-eqv?: wrong type of argument", l);
	if (!isArray(l2))
		Err("typed-array-eqv?: wrong type of argument", l2);
	Array<T> *cp = getArray(l);
	Array<T> *cp2 = getArray(l2);
	return (*cp == *cp2) ? Truth : Ntruth;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::lthLinkArray(SCM l, SCM l2)
{
	if (!isArray(l))
		Err("typed-array-<: wrong type of argument", l);
	if (!isArray(l2))
		Err("typed-array-<: wrong type of argument", l2);
	Array<T> *cp = getArray(l);
	Array<T> *cp2 = getArray(l2);
	return (*cp < *cp2) ? Truth : Ntruth;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::leLinkArray(SCM l, SCM l2)
{
	if (!isArray(l))
		Err("typed-array-<=: wrong type of argument", l);
	if (!isArray(l2))
		Err("typed-array-<=: wrong type of argument", l2);
	Array<T> *cp = getArray(l);
	Array<T> *cp2 = getArray(l2);
	return (*cp <= *cp2) ? Truth : Ntruth;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::grLinkArray(SCM l, SCM l2)
{
	if (!isArray(l))
		Err("typed-array->?: wrong type of argument", l);
	if (!isArray(l2))
		Err("typed-array->?: wrong type of argument", l2);
	Array<T> *cp = getArray(l);
	Array<T> *cp2 = getArray(l2);
	return (*cp > *cp2) ? Truth : Ntruth;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::geLinkArray(SCM l, SCM l2)
{
	if (!isArray(l))
		Err("typed-array->?: wrong type of argument", l);
	if (!isArray(l2))
		Err("typed-array->?: wrong type of argument", l2);
	Array<T> *cp = getArray(l);
	Array<T> *cp2 = getArray(l2);
	return (*cp >= *cp2) ? Truth : Ntruth;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::refLinkArray(SCM l, SCM k)
{
	SCM res = NIL;
	Array<T>* cp;
	long x = STk_integer_value(k);

	if (isArray(l)) {
		cp = getArray(l);
		T t = (*cp)[x];
		res = STk_make_CXXwrapper(Wrapper<T>::type, Wrapper<T>::name,
			(void*)new T(t),LINK_DYNAMIC);
	}
	return res;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::setLinkArray(SCM l, SCM k, SCM e)
{
	Array<T>* cp;

	if  (CXX_NTYPEP(e, Wrapper<T>::type))
                Err("typed-array-insert: wrong type of argument", e);
	long x = STk_integer_value(k);

	if (isArray(l)) {
		T elem =  * (T *) CLASSDATA(e);
		cp = getArray(l);
		(*cp)[x] = elem;
	}
	return UNDEFINED;
}

template <class T> 
PRIMITIVE 
ArrayWrapper<T>::resizeLinkArray(SCM l, SCM k)
{
	Array<T>* cp;

	long x = STk_integer_value(k);

	if (isArray(l)) {
		cp = getArray(l);
		cp->resize(x);
	}
	return UNDEFINED;
}