// 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>
#include <LINK/stkWrapper/Wrapper.h>
#include <LINK/stkWrapper/gc.h>
#include <LINK/graph/Vertex.h>
#include <LINK/graph/Edge.h>
#include <LINK/graph/Graph.h>
#include <LINK/graph/HyperGraph.h>
#include <LINK/graph/UHyperGraph.h>
#include <LINK/graph/DHyperGraph.h>
#include <LINK/graph/BinGraph.h>
#include <LINK/graph/UBinGraph.h>
#include <LINK/graph/DBinGraph.h>

#define GraphObject_CXX_DATA(x)  (*(GraphObject**) (EXTDATA(VAL(x))))
#define Graph_CXX_DATA(x)  (*(Graph**) (EXTDATA(VAL(x))))

char *getName(SCM id)
{
        if (STRINGP(id)) {
                return newString(CHARS(id));
        } else if (SYMBOLP(id)) {
                return newString(PNAME(id));
        } else if (INTEGERP(id)) {
                char vname[20];
                sprintf(vname, "%d", INTEGER(id));
                return newString(vname);
        } else {
                Err("illegal name: ", id);
                return 0;
        }
}

//
// Collection<T>* getCollection(SCM) :  this is a templated method of the 
//					SetFuncsWrapper<> class
//


Graph* getGraph(SCM go)
{
	if     (CXX_TYPEP(go, Wrapper<Graph*>::type) ||
		CXX_TYPEP(go, Wrapper<MHyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<MUHyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<MDHyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<MBinGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<MUBinGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<MDBinGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<HyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<UHyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<DHyperGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<BinGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<UBinGraph*>::type) ||
		CXX_TYPEP(go, Wrapper<DBinGraph*>::type))
		return (Graph*) GraphObject_CXX_DATA(go);
	return (Graph*) 0;
}

GraphObject* getGraphObject(SCM go)
{
	if     (CXX_TYPEP(go, Wrapper<Vertex*>::type) ||
		CXX_TYPEP(go, Wrapper<Graph*>::type) ||
		CXX_TYPEP(go, Wrapper<Edge*>::type))
		return (GraphObject*) GraphObject_CXX_DATA(go);
	return (GraphObject*) getGraph(go);
}

//extern struct gc_protected *protected_registers;

Tcl_HashTable listTable;	// keeps track of class instances pointing
				// to wrapped List objects.  This is to
				// ensure that Lists created and used 
				// exclusively in C++ will be protected
				// from gc

void initListTable()
{
        Tcl_InitHashTable(&listTable, TCL_ONE_WORD_KEYS);
}

void deleteListTable()
{
        Tcl_DeleteHashTable(&listTable);
}


void my_STk_release_cell(SCM l)
{
	l->type = tc_free_cell;
	l->cell_info = 0;
	CDR(l) = STk_freelist;
	STk_freelist = l;
}

/*
void STk_gc_unprotect(SCM l)
{
  struct gc_protected *reg, *tmp_gcp;
  SCM tmp_scm;

  //cout << "STk_gc_unprotect: trying to release: " << l << endl;
  //cout << "---------------------" << endl;
  //for (reg = protected_registers; reg; reg = reg->next) {
//	cout << *(reg->location) << endl;
//	len++;
 // }
 // cout << "---------------------" << endl;
  //cout << "STk_gc_unprotect: the list has length: " << len << endl;
  for (reg = protected_registers; reg; reg = reg->next) 
	if (reg->next && (*(reg->next->location) == l)) {
		//cout << "released. " << endl;
		tmp_gcp = reg->next;
		tmp_scm = *tmp_gcp->location;
		reg->next = reg->next->next;
		//my_STk_release_cell(tmp_scm);
		//cout << "releasing: " << tmp_scm << endl;
		//cout << "deleting: " << tmp_gcp << endl;
		delete tmp_gcp->location;
		delete tmp_gcp;
		return;
	} else if (*(reg->location) == l) {
		//cout << "first element released. " << endl;
		tmp_gcp = reg;
		tmp_scm = *tmp_gcp->location;
		protected_registers = reg->next;
		//my_STk_release_cell(tmp_scm);
		//cout << "releasing: " << tmp_scm << endl;
		//cout << "deleting: " << tmp_gcp << endl;
		delete tmp_gcp->location;
		delete tmp_gcp;
		return;
	}
	//cout << "STk_gc_unprotect: error: " << l << "not found" << endl;
}
*/

PRIMITIVE my_copy_tree(SCM l)
{
	//cout << "copy_tree: ";
	//if (CONSP(l) && (TYPEP(CAR(l), tc_CXXwrapper)))
		//cout << "CXXwrapper: " <<EXTID((SCM) CAR(l))<<endl;
	if (CONSP(l)) {
  		return STk_cons(my_copy_tree((SCM) CAR(l)), 
				my_copy_tree((SCM) CDR(l)));
	} else
		return l;
}

PRIMITIVE my_examine_tree(SCM l)
{
	//cout << "examine tree: " << endl;
	//cout << "address of l: " << l << endl;
	//cout << "TYPE of l: " << TYPE(l) << endl;
	if (CONSP(l)) {
		//cout << "looking at car:" << endl;
  		SCM z1 = my_examine_tree((SCM) CAR(l)); 
		//cout << "looking at cdr:" << endl;
		SCM z2 = my_examine_tree((SCM) CDR(l));
  		return STk_cons(z1, z2);
	} else
		//cout << "not a cons." << endl;
		return l;
}


void defineNewMethod(char *name)
{
	ostrstream oss;
	char *scheme_cmd;

	oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\"))"
						<< ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "DEFINE METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete scheme_cmd;
}

void addZeroArgMethod(char *name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	oss << "(define-generic " << new_name << ")";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) "; 
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	*/
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
        oss << "(define-method " << new_name <<" ()" <<
                                "(" << fcn_name << "))";
        oss << "(define-method " << new_name <<" args" <<
                                "(apply " << fcn_name << " args))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addOneArgMethod(char *name, char *arg1_name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	oss << "(define-generic " << new_name << ")";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) "; 
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	*/
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
        oss << "(define-method " << new_name <<" ()" <<
                                "(" << fcn_name << "))";
        oss << "(define-method " << new_name <<" ((a <top>)) "
					"( " << name << " a))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg1_name << "))" <<
                                "(" << fcn_name << " a))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addTwoArgMethod(char *name, char *arg1_name, char *arg2_name,
			char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	oss << "(define-generic " << new_name << ")";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) ";
		oss << "(define (" << name << " a) " << 
				"(error \"" << name 
				  << ": not enough parameters\")))";
	}
	*/
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
        oss << "(define-method " << new_name <<" ()" <<
                                "(" << fcn_name << "))";
	/*
        oss << "(define-method " << new_name <<" args" <<
                                "(apply " << fcn_name << " args))";
	*/
        oss << "(define-method " << new_name <<" ((a <top>)) "
					"( " << name << " a))";
        oss << "(define-method " << new_name <<" ((a <top>) (b <top>)) "
					"( " << name << " a b))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg1_name << ")" <<
                                "(b "<< arg2_name << "))" <<
                                "(" << fcn_name << " a b))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addThreeArgMethod(char *name, char *arg1_name, char *arg2_name,
		       char *arg3_name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	oss << "(define-generic " << new_name << ")";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) " ;
		oss << "(begin (define (" << name << " a) " << 
				"(error \"" << name << ": wrong "
				"number of parameters\"))";
		oss << "(define (" << name << " a b) " << 
				"(error \"" << name << ": wrong "
				"number of parameters\"))))";
	}
	*/
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
        oss << "(define-method " << new_name <<" ()" <<
                                "(" << fcn_name << "))";
	/*
        oss << "(define-method " << new_name <<" args" <<
                                "(apply " << fcn_name << " args))";
	*/
        oss << "(define-method " << new_name <<" ((a <top>)) "
					"( " << name << " a))";
        oss << "(define-method " << new_name <<" ((a <top>) (b <top>)) "
					"( " << name << " a b))";
        oss << "(define-method " << new_name <<
					" ((a <top>) (b <top>) (c <top>)) "
					"( " << name << " a b c))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg1_name << ")" <<
                                "(b "<< arg2_name << ")" <<
                                "(c "<< arg3_name << "))" <<
                                "(" << fcn_name << " a b c))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl << ends;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addArbMethod(char *name, char *arg_name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) "; 
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	*/
	oss << "(define-generic " << new_name << ")";
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
	if (ov)
        	oss << "(define-method " << new_name <<" () (" << name << ")) ";
	else
        	oss << "(define-method " << new_name <<" () " <<
			"(error \"" << name << ": requires argument(s)\"))";
	oss << "(define-method " << new_name <<" ()" <<
                                "(" << fcn_name << "))";
        oss << "(define-method " << new_name <<" ((a <top>)) "
					"( " << name << " a))";
        oss << "(define-method " << new_name <<" ((a <top>) (b <top>)) "
					"( " << name << " a b))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg_name << "))" <<
                                "(" << fcn_name << " a))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg_name << ")" <<
                                "(b "<< arg_name << "))" <<
                                "(" << fcn_name << " a b))";
        oss << "(define-method " << new_name <<" args " <<
                                "(" << new_name << 
					" (car args) "
                                <<   "(apply " << new_name << " (cdr args))))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addListMethod(char *name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) ";
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	oss << "(define-generic " << new_name << ")";
        oss << "(define-method " << new_name <<" ()" <<
                                //**** CollectionWrapper methods take an arg
                                //**** ---just pass empty list
                                "(" << fcn_name << "'() ))";  
        oss << "(define-method " << new_name <<" args " <<
                                "(" << fcn_name << " args))";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addIntListMethod(char *name, char *fcn_name1, char *fcn_name2, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) ";
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	*/
	oss << "(define-generic " << new_name << ")";
        oss << "(define-method " << new_name <<" args " 
                  << "(cond ( (and (not (null? args)) (integer? (car args)))"
                  << "                  (" << fcn_name2 << " args))" 
                  << "            (#t (" << fcn_name1 << " args))))";
	/*
        oss << "(define-method " << new_name <<" args " 
                  << "(cond ( (and (not (null? args)) (integer? (car args)))"
                  << "                  (" << fcn_name2 << " args))" 
                  << "      ( (or (null? args) (int? (car args)))"
                  << "            (" << fcn_name1 << " args))"
                  << "      ( #t (apply " << name << " args))))";
	*/
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}

void addBooleanMethod(char *name, char *arg_name, char *fcn_name, int ov)
{
	ostrstream oss, oss2;
	char *scheme_cmd, *new_name;

	oss2 << "new-" << name << ends;
	new_name = oss2.str();
	
	oss << "(begin";
	oss << "(define-generic " << new_name << ")";
	/*
	if (!ov) {
		oss << "(if (not (symbol-bound? '" << name << " )) ";
		oss << "(define (" << name << " a) " << 
				"(error \"" << name << ": bad argument\")))";
	}
	*/
        oss << "(let ((" << name << " " << name << ")";
        oss << "     )";
        oss << "(define-method " << new_name <<" ((a <top>)) "
					"( " << name << " a))";
        oss << "(define-method " << new_name <<" ((a <top>) (b <top>)) "
					"( " << name << " a b))";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg_name << "))" <<
                                "#t)";
        oss << "(define-method " << new_name <<" (" <<
                                "(a "<< arg_name << ")" <<
                                "(b "<< arg_name << "))" <<
                                "(" << fcn_name << " a b))";
        oss << "(define-method " << new_name <<" args " <<
                                "(and (" << new_name << 
					" (car args) (car (cdr args)))"
                                <<   "(apply " << new_name << " (cdr args))))";
        oss << ")";
        oss << "(set! " << name << " " << new_name << " )";
        oss << ")" << ends;
        scheme_cmd = oss.str();
	//cout << "****************************" << endl;
	//cout << "NEW METHOD: " << scheme_cmd << endl;
	//cout << "****************************\n" << endl;
        SCM dummy = STk_eval_C_string(scheme_cmd, NIL);
        delete new_name;
        delete scheme_cmd;
}