/******************************************************************************

			UNSW Prolog (version 4)

			Written by Claude Sammut
		     Department of Computer Science
		     University of New South Wales
		   (and St. Joseph's U., Philadelphia)

		   Copyright (c)  1983 - Claude Sammut

******************************************************************************/





		/*	Meta-logical predicates		*/

#include "pred.h"


extern pval termb, intern(), new(), mkclause();
extern compterm *record();
extern clause *create();
extern int argn, bind(), unbind(), isbound();
extern atom *_comma, *_neck, *same_proc;
extern binding *frameb;
extern integer *stack_int;
extern var **varcell;


static
assert PREDICATE
{
	register pval rval;
	var **old_vc, *vc[MAXVAR];

	if (iscompound(arg[0]))
	{
		argn = 0;
		old_vc = varcell;
		varcell = vc;
		rval = mkclause(arg[0], frame[0]);
		rval -> g.nvars = argn;
		add_clause(rval);
		varcell = old_vc;
		argn = 0;
		return(TRUE);
	}
	else fail("Assert - argument must be compound")
}

static
asserta PREDICATE
{
	register pval rval;
	register atom *x;
	register clause *y;
	var **old_vc, *vc[MAXVAR];

	if (iscompound(arg[0]))
	{
		argn = 0;
		varcell = vc;
		rval = mkclause(arg[0], frame[0]);
		rval -> g.nvars = argn;
		x = (atom *) rval -> g.goal[0] -> c.term[0];
		y = VAL(x);
		VAL(x) = (clause *) rval;
		VAL(x) ->  rest = y;
		same_proc = 0;
		varcell = old_vc;
		argn = 0;
		return(TRUE);
	}
	else fail("Asserta - argument must be compound")
}


static
pterm PREDICATE
{
	register int i;

	if (TYPE(arg[0]) != INT || TYPE(arg[1]) == VAR)
		fail("Arg - bad argument")
	i = INT_VAL(0);
	if (isatom(arg[1]) && i == 0)
		return(unify(arg[2], frame[2], arg[1], 0));
	else if (iscompound(arg[1]) && i <= SIZE(arg[1]))
		return(unify(arg[2], frame[2], arg[1] -> c.term[i], frame[1]));
	else return(FALSE);
}


#define MAX_VAR 20

static int _nvars = 0;
static var *_var[MAX_VAR];

static
pval mkfn(functor, arity)
atom *functor;
int arity;
{
	register compterm *rval;
	register int i;
	register var *v;
	char buf[6];

	if (arity > MAX_VAR)
		fail("Functor - Too many variables")

	rval = record(arity);
	rval -> term[0] = (pval) functor;
	for (i = 0; i < arity; i++)
	{
		if (i < _nvars) rval -> term[i + 1] = (pval) _var[i];
		else {
			sprintf(buf, "_%d", i + 1);
			v = (var *) new(VAR);
			v -> offset = i;
			v -> pname = (atom *) intern(ATOM, buf, strlen(buf)+1, FALSE);
			_var[_nvars++] = v;
			rval -> term[i + 1] = (pval) v;
		}
	}
	return((pval) rval);
}


static
functor PREDICATE
{
	extern binding *stack;
	extern short sp;
	register pval rval;
	register int arity;

	if (isvariable(arg[0]) && isatom(arg[1]) && isinteger(arg[2]))
	{
		if ((arity = INT_VAL(2)) == 0)
		{
			bind(arg[0], frame[0], arg[1], 0);
			return(TRUE);
		}
		if ((int)(rval = mkfn(arg[1], arity)) == FALSE) return(FALSE);
		bind(arg[0], frame[0], rval, &stack[sp]);
		clear_frame(arity);
		return(TRUE);
	}
	if (TYPE(arg[1]) != VAR || TYPE(arg[2]) != VAR)
		fail("Functor - 2nd and 3rd arguments must be variables")
	else if (isatom(arg[0]))
	{
		bind(arg[1], frame[1], arg[0], 0);
		bind_num(2, 0);
		return(TRUE);
	}
	else if (TYPE(arg[0]) == FN)
	{
		bind(arg[1], frame[1], arg[0] -> c.term[0], 0);
		bind_num(2, SIZE(arg[0]));
		return(TRUE);
	}
	else fail("Functor - first argument must be functor")
}


static
concat PREDICATE
{
	extern atom *nil;
	extern char token_buff[];
	register i = 0;
	pval tl_term, rval;
	binding *tl_frame;

	if (arg[0] == (pval) nil) return(FALSE);
	if (TYPE(arg[0]) == LIST)
	{
		termb = arg[0];
		frameb = frame[0];
		while (TYPE(termb) != VAR && termb != (pval) nil)
		{
			tl_term = termb;
			tl_frame = frameb;
			unbind(termb -> c.term[0], frameb);
			if (isatom(termb))
			{
				sprintf(&token_buff[i], "%s", NAME(termb));
				i = strlen(token_buff);
			}
			else if (isinteger(termb))
				if (termb == (pval) stack_int)
				{
					sprintf(&token_buff[i], "%d", (int) frameb);
					i = strlen(token_buff);
				}
				else {
					sprintf(&token_buff[i], "%d", termb -> i.int_val);
					i = strlen(token_buff);
				}
			else fail("Concat - list members must be atomic")
			unbind(tl_term -> c.term[1], tl_frame);
		}
		token_buff[i++] = 0;
		rval = intern(atype(token_buff), token_buff, i, FALSE);
		if (isatom(arg[1])) return(arg[1] == rval);
		else if (isvariable(arg[1]))
		{
			bind(arg[1], frame[1], rval, 0);
			return(TRUE);
		}
		else fail("Concat - bad second argument")
	}
	else fail("Concat - first argument must be a list")
}



typedef enum
{
  WORDCH , STRINGCH , SYMBOLCH , PUNCTCH , QUOTECH , DIGIT , WHITESP , 
 ILLEGALCH
} chartype;

static
p_char PREDICATE
{
	extern chartype chtype[];
	char buf[2];
	register i;
	register pval rval;

	if (isinteger(arg[0]) && isatom(arg[1]))
	{
		i = INT_VAL(0);
		if (i < 1 || i > strlen(NAME(arg[1]))) return(FALSE);
		buf[0] = NAME(arg[1])[i - 1];
		buf[1] = 0;
		rval = intern(ATOM, buf, 2, chtype[buf[0]] != WORDCH);
		if (isatom(arg[2])) return(rval == arg[2]);
		else if (isvariable(arg[2]))
		{
			bind(arg[2], frame[2], rval, 0);
			return(TRUE);
		}
	}
	fail("Char - bad argument")
}

#define BOTTOM -1

extern var _1, _2;
static struct {itemtype type; var *_1, *_2;} _list = {LIST, &_1, &_2};


static
ancestors PREDICATE
{
	extern environment *env_stack;
	extern short parent, sp;
	extern binding *stack;
	extern atom *nil;	/* 9/9/86 - WEN - needed for VAX C */
	register pval t;
	register short i;
	register environment *p;
	binding *f, *s;

	t = arg[0]; f = frame[0];
	for (i = env_stack[parent].parent; i != BOTTOM; i = env_stack[i].parent)
	{
		p = &env_stack[i];
		s = &stack[sp];
		clear_frame(2);
		if (! unify(t, f, &_list, s))
			fail("Ancestors - incorrect argument")
		s -> termv = (pval)(*(p -> cl));
		if (p -> parent == -1) s -> framev = stack;
		else s -> framev = &stack[env_stack[p -> parent].sp];
		t = (pval)(&_2); f = s;
	}
	bind(t, f, nil, 0);
	return(TRUE);
}


static int next_no = 0;

static
numv(x, f)
pval x;
binding *f;
{
	int i, limit;
	pval a;
	char buf[16];

	switch (TYPE(x))
	{
	   case LIST:
	   case FN:	limit = SIZE(x);
			break;
	   case VAR:	if (isbound(x, f))
				numv(termb, frameb);
			else {
				sprintf(buf, "_%d", next_no++);
				i = strlen(buf);
				a = intern(ATOM, buf, i + 1, FALSE);
				bind(x, f, a, 0);
			}
	   default:	return;
	}

	for (i = 0; i <= limit; i++)
		numv(x -> c.term[i], f);
}


static
number_vars PREDICATE
{
	if (TYPE(arg[1]) != INT)
		fail("Numbervars - second argument must be an integer")
	if (TYPE(arg[2]) != INT && TYPE(arg[2]) != VAR)
		fail("Numbervars - third arg must be integer or variable")
	next_no = INT_VAL(1);
	numv(arg[0], frame[0]);
	return(unify(arg[2], frame[2], stack_int, next_no));
}


atom_table p_meta =
{
	SET_PRED(NONOP, 0, 3, "term", pterm),
	SET_PRED(NONOP, 0, 3, "arg", pterm),
	SET_PRED(NONOP, 0, 3, "functor", functor),
	SET_PRED(NONOP, 0, 1, "assert", assert),
	SET_PRED(NONOP, 0, 1, "asserta", asserta),
	SET_PRED(NONOP, 0, 1, "assertz", assert),
	SET_PRED(NONOP, 0, 2, "concat", concat),
	SET_PRED(NONOP, 0, 3, "char", p_char),
	SET_PRED(NONOP, 0, 1, "ancestors", ancestors),
	SET_PRED(NONOP, 0, 3, "numbervars", number_vars),
	END_MARK
};