// 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: 12-Jul-1998
// 
#include <stk.h>
#include <iostream.h>
#include <strstream.h>
#include <LINK/stkWrapper/LINK_STk.h>
template <class Item> 

Matrix<Item>* 
MatrixWrapper<Item>::getMatrix(SCM p)
{
	int &Matrix_Type 	= Wrapper<Matrix<Item> >::type;
	Matrix<Item> *cp;
	if (CXX_TYPEP(p, Matrix_Type))
		cp = (Matrix<Item>*) CLASSDATA(p);
	else
		cp = 0;
	return cp;
}
template <class Item> 
Bool 
MatrixWrapper<Item>::isMatrix(SCM p)
{
	int &Matrix_Type 	= Wrapper<Matrix<Item> >::type;
	if (CXX_TYPEP(p, Matrix_Type))
		return TRUE;
	return FALSE;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::linkMatrixP(SCM l)
{
	return  isMatrix(l) ? Truth : Ntruth; 
}

template <class Item> 
void 
MatrixWrapper<Item>::markTypedMatrix(SCM p)
{}

template <class Item> 
void 
MatrixWrapper<Item>::freeTypedMatrix(SCM p)
{
	int &Matrix_Type 	= Wrapper<Matrix<Item> >::type;
	if (CXXw_TYPEP(p, Matrix_Type))
		if (!EXTSTATICP(p))
	    		delete (Matrix<Item> *) EXTDATA(p); 
	else
		Err("free-typed-matrix: wrong type of argument", p);
}
	
template <class Item> 
void 
MatrixWrapper<Item>::displayTypedMatrix(SCM c, SCM port, int mode)
{
	int &Matrix_Type 	= Wrapper<Matrix<Item> >::type;
	Matrix<Item>* cp;
	if (CXXw_TYPEP(c, Matrix_Type))
		cp = (Matrix<Item>*) EXTDATA(c);
	else 
		Err("display-typed-matrix: wrong type of argument", c);
        ostrstream oss;
	oss << endl;
        cp->display(oss);
	oss << ends;
        char *buffer = oss.str();
        Puts(buffer, (port));
        delete buffer;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::makeLinkMatrix(SCM i, SCM j)
{
	int r = STk_integer_value(i);
	int c = STk_integer_value(j);
	SCM ns;
	Matrix<Item>* new_matrix;
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
        new_matrix = new Matrix<Item>(r, c);
	ns = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				 (void*)new_matrix,LINK_DYNAMIC);
	return ns;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::makeFilledLinkMatrix(SCM row, SCM col,  SCM e)
{
	int i, j;
	int r = STk_integer_value(row);
	int c = STk_integer_value(col);
	SCM ns;
	Matrix<Item>* new_matrix;
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	if  (CXX_NTYPEP(e, Wrapper<Item>::type))
                Err("typed-matrix-insert: wrong type of argument", e);
        new_matrix = new Matrix<Item>(r,c);
	ns = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				 (void*)new_matrix,LINK_DYNAMIC);
	Item elem =  * (Item *) CLASSDATA(e);
	for (i=0; i<r; i++)
		for (j=0; j<c; j++)
			(*new_matrix)(i,j) = elem;
	return ns;
}

template <class Item>
double MatrixWrapper<Item>::getNumber(SCM e)
{
	double val; 
	if (!NUMBERP(e))
                Err("typed-matrix-insert: wrong type of argument", e);
	if (INTEGERP(e))
		val = INTEGER(e);
	else
		val = FLONM(e);
	return val;
}


template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::copyLinkMatrix(SCM l)
{
	SCM ns;
	Matrix<Item> *new_matrix, *old_matrix;
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	if (isMatrix(l))
		old_matrix = getMatrix(l);	
        new_matrix = new Matrix<Item>(*old_matrix);
	ns = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				 (void*)new_matrix,LINK_DYNAMIC);
	return ns;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::fillLinkMatrix(SCM l, SCM e)
{
	int i, j, rows, cols;
	Matrix<Item>* a;
	if  (CXX_NTYPEP(l, Wrapper<Matrix<Item> >::type))
                Err("typed-matrix-insert: argument not an matrix", l);
	if  (CXX_NTYPEP(e, Wrapper<Item>::type))
                Err("typed-matrix-insert: wrong type of argument", e);
        if (isMatrix(l))
        	a = getMatrix(l);
	Item elem =  * (Item *) CLASSDATA(e);
	rows = a->numRows();
	cols = a->numCols();
	for (i=0; i<rows; i++)		//or else it needs an allocation() mth.
		for (j=0; j<cols; j++)	
			(*a)(i,j) = elem;
	return UNDEFINED;
}

template <class Item>
PRIMITIVE
MatrixWrapper<Item>::stkList2LinkMatrix(SCM rows, int len)
{
	int Item_type = Wrapper<Item>::type;
        SCM row;
        Tcl_HashEntry *p;
        if (len <= 0)
                return Ntruth;
        else {
                row = CAR(rows);
        }
        if (NCONSP(rows)) {
               Err("matrix: bad arg 1, list of lists expected", rows);
        }
        if (NCONSP(row)) {
               Err("matrix: bad arg 1, list of lists expected", row);
        }
        int numrows = STk_llength(rows);
        int numcols = STk_llength(row);
        //
        // make sure each row has numcols columns
        //
        SCM l=rows, l2;
        for (;;) {
                if (NULLP(l))
                        break;
                if (STk_llength(CAR(l)) != numcols)
                        Err("matrix: bad number of columns: ", CAR(l));
                l = CDR(l);
        }
        Matrix<Item> *m = new Matrix<Item>(numrows, numcols);
        int i=0, j=0;
        l = rows;
        for (;;) {
                if ((NULLP(l)) || (NCONSP(CAR(l))))
                        break;
                l2 = CAR(l);
                j=0;
                for (;;) {
                        if (NULLP(l2))
                                break;
			if (!CXX_TYPEP(CAR(l2), Item_type))
                                Err("matrix: bad argument type: ", CAR(l2));
			(*m)(i,j) = *(Item*) (CLASSDATA(CAR(l2)));
                        l2 = CDR(l2);
                        j++;
                }
                l = CDR(l);
                i++;
        }
        int &Matrix_Type = Wrapper<Matrix<Item> >::type;
        char*Matrix_Name = Wrapper<Matrix<Item> >::name;
        PRIMITIVE ns = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
                                 (void*)m,LINK_DYNAMIC);
        return ns;
}

template <class Item>
PRIMITIVE
MatrixWrapper<Item>::linkMatrix2STkList(SCM l)
{
        if (!isMatrix(l))
                Err("typed-matrix-convert: wrong type of argument", l);
        Matrix<Item> *cp = getMatrix(l);
        int numrows=0, numcols=0;
        if (cp) {
                numrows = cp->numRows();
                numcols = cp->numCols();
        }
        Item e;
        int i, j;
        SCM head_row=NIL, new_row;
        for (i=0; i<numrows; i++) {
           SCM newnode=NIL, head=NIL;
           for (j=0; j<numcols; j++) {
                e = (*cp)(i, j);
		SCM new_el = STk_make_CXXwrapper(Wrapper<Item>::type, 
					  Wrapper<Item>::name,
			(void*)new Item(e),LINK_DYNAMIC);
                NEWCELL(newnode, tc_cons);
                CAR(newnode) = new_el;
                CDR(newnode) = head;
                head = newnode;
          }
          NEWCELL(new_row, tc_cons);
          CAR(new_row) = STk_reverse(head);
          CDR(new_row) = head_row;
          head_row = new_row;
        }
        return STk_reverse(head_row);
}


template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::numRowsLinkMatrix(SCM l)
{
	if (!isMatrix(l))
		Err("typed-matrix-num-rows: wrong type of argument", l);
	Matrix<Item> *cp = getMatrix(l);
	SCM z;
  	NEWCELL(z, tc_integer);
  	SET_INTEGER(z, cp->numRows());
  	return z;
}
template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::numColsLinkMatrix(SCM l)
{
	if (!isMatrix(l))
		Err("typed-matrix-num-cols: wrong type of argument", l);
	Matrix<Item> *cp = getMatrix(l);
	SCM z;
  	NEWCELL(z, tc_integer);
  	SET_INTEGER(z, cp->numCols());
  	return z;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::eqvLinkMatrix(SCM l, SCM l2)
{
	if (!isMatrix(l))
		Err("typed-matrix-eqv?: wrong type of argument", l);
	if (!isMatrix(l2))
		Err("typed-matrix-eqv?: wrong type of argument", l2);
	Matrix<Item> *cp = getMatrix(l);
	Matrix<Item> *cp2 = getMatrix(l2);
	return (*cp == *cp2) ? Truth : Ntruth;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::refLinkMatrix(SCM l, SCM i, SCM j)
{
	SCM res = NIL;
	Matrix<Item>* cp;
	long r = STk_integer_value(i);
	long c = STk_integer_value(j);
	if (isMatrix(l)) {
		cp = getMatrix(l);
		Item t = (*cp)(r, c);
		res = STk_make_CXXwrapper(Wrapper<Item>::type, 
					  Wrapper<Item>::name,
			(void*)new Item(t),LINK_DYNAMIC);
	}
	return res;
}


template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::setLinkMatrix(SCM alist, int len)
{
	if (len < 4)
		Err("usage: typed-matrix-set m i j e", alist);
	SCM l = CAR(alist); 
	SCM i = CAR(CDR(alist)); 
	SCM j = CAR(CDR(CDR(alist)));  
	SCM e = CAR(CDR(CDR(CDR(alist))));
	Matrix<Item>* cp;
	if  (CXX_NTYPEP(e, Wrapper<Item>::type))
                Err("typed-matrix-set: wrong type of argument", e);
	long r = STk_integer_value(i);
	long c = STk_integer_value(j);
	if (isMatrix(l)) {
		Item elem =  * (Item *) CLASSDATA(e);
		cp = getMatrix(l);
		(*cp)(r, c) = elem;
	}
	return UNDEFINED;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::transpose(SCM l)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(l))
		Err("typed-matrix-transpose: wrong type of argument", l);
	Matrix<Item> *cp = getMatrix(l);
	Matrix<Item> *res = new Matrix<Item>(cp->transpose());
	res_scm = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				(void*)res,LINK_DYNAMIC);
	return res_scm;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::multiply(SCM l, SCM l2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(l))
		Err("typed-matrix-multiply: wrong type of argument", l);
	if (l2 == UNBOUND)	// see tc_subr_1_or_2 in Extending STk
		return l;
	if (!isMatrix(l2))
		Err("typed-matrix-multiply: wrong type of argument", l2);
	Matrix<Item> *cp = getMatrix(l);
	Matrix<Item> *cp2 = getMatrix(l2);
	Matrix<Item> *res = new Matrix<Item>
			 ( (*(Matrix<Item>*)cp) * (*(Matrix<Item>*)cp2) );
	res_scm = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				(void*)res,LINK_DYNAMIC);
	return res_scm;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::sum(SCM l, SCM l2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(l))
		Err("typed-matrix-sum: wrong type of argument", l);
	if (l2 == UNBOUND)	// see tc_subr_1_or_2 in Extending STk
		return l;
	if (!isMatrix(l2))
		Err("typed-matrix-sum wrong type of argument", l2);
	Matrix<Item> *cp = getMatrix(l);
	Matrix<Item> *cp2 = getMatrix(l2);
	Matrix<Item> *res = new Matrix<Item>
			 ( (*(Matrix<Item>*)cp) + (*(Matrix<Item>*)cp2) );
	res_scm = STk_make_CXXwrapper(Matrix_Type,Matrix_Name,
				(void*)res,LINK_DYNAMIC);
	return res_scm;
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::swapRows(SCM m, SCM r1, SCM r2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("swap-rows: wrong type of argument", m);
	if (!INTEGERP(r1))
		Err("swap-rows: wrong type of argument", r1);
	if (!INTEGERP(r2))
		Err("swap-rows: wrong type of argument", r2);
	Matrix<Item> *cp = getMatrix(m);
	int i1 = INTEGER(r1);
	int i2 = INTEGER(r2);
	return STk_makeinteger(cp->swapRows(i1,i2));
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::swapCols(SCM m, SCM c1, SCM c2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("swap-rows: wrong type of argument", m);
	if (!INTEGERP(c1))
		Err("swap-rows: wrong type of argument", c1);
	if (!INTEGERP(c2))
		Err("swap-rows: wrong type of argument", c2);
	Matrix<Item> *cp = getMatrix(m);
	int i1 = INTEGER(c1);
	int i2 = INTEGER(c2);
	return STk_makeinteger(cp->swapCols(i1,i2));
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::addRows(SCM m, SCM r1, SCM r2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("add-rows: wrong type of argument", m);
	if (!INTEGERP(r1))
		Err("add-rows: wrong type of argument", r1);
	if (!INTEGERP(r2))
		Err("add-rows: wrong type of argument", r2);
	Matrix<Item> *cp = getMatrix(m);
	int i1 = INTEGER(r1);
	int i2 = INTEGER(r2);
	return STk_makeinteger(cp->addRows(i1,i2));
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::addCols(SCM m, SCM c1, SCM c2)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("add-cols: wrong type of argument", m);
	if (!INTEGERP(c1))
		Err("add-cols: wrong type of argument", c1);
	if (!INTEGERP(c2))
		Err("add-cols: wrong type of argument", c2);
	Matrix<Item> *cp = getMatrix(m);
	int j1 = INTEGER(c1);
	int j2 = INTEGER(c2);
	return STk_makeinteger(cp->addCols(j1,j2));
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::scalarMultRow(SCM m, SCM r, SCM s)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("scalar-mult-row: wrong type of argument", m);
	if (!INTEGERP(r))
		Err("scalar-mult-row: wrong type of argument", r);
	if (!NUMBERP(s))
		Err("scalar-mult-row: wrong type of argument", s);
	Matrix<Item> *cp = getMatrix(m);
	int row = INTEGER(r);
	double scalar = getNumber(s);
	return STk_makeinteger(cp->scalarMultRow(scalar,row));
}

template <class Item> 
PRIMITIVE 
MatrixWrapper<Item>::scalarMultCol(SCM m, SCM c, SCM s)
{
	int &Matrix_Type = Wrapper<Matrix<Item> >::type;
	char*Matrix_Name = Wrapper<Matrix<Item> >::name;
	SCM res_scm;
	if (!isMatrix(m))
		Err("scalar-mult-col: wrong type of argument", m);
	if (!INTEGERP(c))
		Err("scalar-mult-col: wrong type of argument", c);
	if (!NUMBERP(s))
		Err("scalar-mult-col: wrong type of argument", s);
	Matrix<Item> *cp = getMatrix(m);
	int col = INTEGER(c);
	double scalar = getNumber(s);
	return STk_makeinteger(cp->scalarMultRow(scalar,col));
}
