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

			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

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





		/*	The basic Prolog predicates	*/


#include "pred.h"

extern integer *stack_int;

short arith_failure = FALSE;


	/* Issue warning when a predefined predicate fails */

warning(s)
char *s;
{
	fprintf(stderr, "\nWARNING - %s\n", s);
	arith_failure = TRUE;
}


		/*	ARITH evaluates arithmetic expressions	*/


int arith(term, frame)
pval term;
binding *frame;
{
	int i, x, arg[4];
	extern pval termb;
	extern binding *frameb;

	arith_failure = FALSE;
	switch (TYPE(term))
	{
	   case INT:	if (term == (pval) stack_int) return((int) frame);
			else return(((integer *) term) -> int_val);
	   case VAR:	if (isbound(term, frame))
				return(arith(termb, frameb));
			else warning("Unbound variable in arithmetic expression");
			break;
	   case FN:	if (TYPE(term -> c.term[0]) != PREDEF)
			{
				warning("Unrecognized arithmetic operator");
				break;
			}
			if (SIZE(term) > 4)
				warning("ARITH - TOO MANY ARGUMENTS");
			for (i = 0; i < SIZE(term); i++)
				arg[i] = arith(term -> c.term[i + 1], frame);
			switch (VAL(term -> c.term[0]))
			{
			   case PLUS:	return(arg[0] + arg[1]);
			   case MINUS:	return(arg[0] - arg[1]);
			   case TIMES:	return(arg[0] * arg[1]);
			   case DIV:	return(arg[0] / arg[1]);
			   case MOD:	return(arg[0] % arg[1]);
			   case POW:	if (arg[1] < 0)
					{
						warning("Negative powers not permitted");
						break;
					}
					x = 1;
					for (i = arg[1]; i != 0; i--)
						x *= arg[0];
					return(x);
			   case UPLUS:	return(arg[0]);
			   case UMINUS:	return(- arg[0]);
			   default:	warning("Unknown arithmetic operation");
					break;
			}
	    default:	warning("Incorrect arithmetic expression");
			break;
	}
}


static
is PREDICATE
{
	int i;

	i = arith(arg[1], frame[1]);
	if (arith_failure) return(FALSE);
	return(unify(arg[0], frame[0], stack_int, i));
}


static
int compare(arg, frame)
pval arg[];
binding **frame;
{
	int x, y;

	if (isatom(arg[0]) && isatom(arg[1]))
		return(strcmp(NAME(arg[0]), NAME(arg[1])));
	x = arith(arg[0], frame[0]);
	if (arith_failure) return(FALSE);
	y = arith(arg[1], frame[1]);
	if (arith_failure) return(FALSE);
	return(x - y);
}


static
lt PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) < 0));
}


static
le PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) <= 0));
}

static
gt PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) > 0));
}

static
ge PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) >= 0));
}

static
eq PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) == 0));
}


static
neq PREDICATE
{
	return((! arith_failure) && (compare(arg, frame) != 0));
}

static
is_int PREDICATE
{
	return(isinteger(arg[0]));
}

static
is_atom PREDICATE
{
	return(isatom(arg[0]));
}


static
quoted PREDICATE
{
	return(TYPE(arg[0]) == STRING);
}


static
atomic PREDICATE
{
	switch (TYPE(arg[0]))
	{
	   case ATOM:
	   case STRING:
	   case PREDEF:
	   case INT:	return(TRUE);
	   default: return(FALSE);
	}
}


static
is_var PREDICATE
{
	return(isvariable(arg[0]));
}


static
nonvar PREDICATE
{
	return(! isvariable(arg[0]));
}


static
length PREDICATE
{
	extern atom *nil;
	extern pval termb;	/* 9/9/86 - WEN - needed for VAX C */
	extern binding *frameb;	/* 9/9/86 - WEN - needed for VAX C */
	register i;

	if (arg[0] == (pval) nil) i = 0;
	else if (TYPE(arg[0]) == LIST)
	{
		i = 0;
		termb = arg[0];
		frameb = frame[0];
		repeat
		{
			if (TYPE(termb) == VAR || TYPE(termb) != LIST)
				break;
			else i++;
			unbind(termb -> c.term[1], frameb);
		}
	}
	else {
		warning("Length - first argument must be a list");
		return(FALSE);
	}
	if (isinteger(arg[1])) return(i == INT_VAL(1));
	if (isvariable(arg[1]))
	{
		bind_num(1, i);
		return(TRUE);
	}
	else return(FALSE);
}


atom_table p_basic =
{
	SET_PRED(XFX, 700, 2, ">", gt),
	SET_PRED(XFX, 700, 2, "<", lt),
	SET_PRED(XFX, 700, 2, "<=", le),
	SET_PRED(XFX, 700, 2, ">=", ge),
	SET_PRED(XFX, 700, 2, "==", eq),
	SET_PRED(XFX, 700, 2, "<>", neq),
	SET_PRED(XFX, 700, 2, "<>", neq),
	SET_PRED(XFX, 700, 2, "is", is),
	SET_PRED(NONOP, 0, 1, "integer", is_int),
	SET_PRED(NONOP, 0, 1, "atom", is_atom),
	SET_PRED(NONOP, 0, 1, "quoted", quoted),
	SET_PRED(NONOP, 0, 1, "atomic", atomic),
	SET_PRED(NONOP, 0, 1, "nonvar", nonvar),
	SET_PRED(NONOP, 0, 2, "length", length),
	SET_PRED(NONOP, 0, 1, "var", is_var),
	END_MARK
};