/* ----------------------------------------------------------
% (C)1992 Institute for New Generation Computer Technology
% (Read COPYRIGHT for detailed information.)
----------------------------------------------------------- */
/*=====================================================================
* cu-Prolog III (Constraint Unification Prolog)
* Copyright: Institute for New Generation Computer Technology,Japan
* 1989--91
==================================================================== */
/*--------------------------------------------------------------------
* << defsysp.c >>
* (define system predicate entry)
* 93.7.15 add dummy in defsyspred()
* 1994.9.27 atom_to_str
* 1995.1.27 retract (type2-->type1), not (debug)
--------------------------------------------------------------------*/
#define SYSPRED 1
#include "include.h"
#if SUN4 == 1
#include <sys/time.h>
#else
#if CPUTIME != 0
#include <sys/types.h>
#include <sys/times.h>
#endif
#endif
#define XF 0210
#define YF 0200
#define FX 0101
#define FY 0100
#define XFY 0310
#define YFX 0301
#define XFX 0311
#define Def1(F,N,A,P) (F = Nfunc(TYPE1SYS,N,A))->def.f_sysfunc=P
#define Def1Red(F,N,A,P) (F = Nfunc(TYPE1SYS_REDUCED,N,A))->def.f_sysfunc=P
#define Def2(F,N,A,P) (F = Nfunc(TYPE2SYS,N,A))->def.f_sysfunc=P
#define Def2Red(F,N,A,P) (F = Nfunc(TYPE2SYS_REDUCED,N,A))->def.f_sysfunc=P
#define Deftemp(F,N,A) F = Nfunc(TEMPFUN,N,A)
#define Defatom(T,N) \
((T = Nterm(0,ETERNAL))->type.t_func = Nfunc(TYPE1SYS,N,0))
#define Npstobj(Head,Env,Tail,Flag) Neclause(Head,Env,Tail,Flag)
long OLD_TIME = 0L;
/* cf. TYPE1SYS : system functional predicate (has only one solution)
TYPE2SYS : system non-functional predicate (has many solutions) */
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
init_syspted()
initialize system predicates : called by init_status()
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
void init_syspred () { /* initialize system predicates */
void init_froles();
defsyspred (); /* define system predicate */
init_atoms(); /* init atoms */
init_operator(); /* init operator */
init_category(); /* init cat() functor */
init_froles(); /* init components */
}
void defsyspred() /* define system embedded predicate */
{
salloc((sizeof(struct func) / sizeof(int))); /* dummy 93.7.15*/
Def1Red(ABOMB_P,"aTomIcbOmb",0,abomb_pred);
Def1Red(ABOLISH_P,"abolish",2,abolish_pred); /* abolish of def */
Def2Red(APND_P,"apnd",3,apnd_pred); /* system append */
Def1Red(ARG_P,"arg",3,arg_pred); /* arg(Pos,Term,Argument) */
Def1Red(ASSERT_P,"assert",1,assert_pred); /* assert(PredName) */
Def1Red(ASSERTA_P,"asserta",1,assert_pred);
Def1Red(ASSERTZ_P,"assertz",1,assertz_pred);
Def1Red(ASSERT_P,"assert",2,assert_pred); /* assert(Pred,Defs) */
Def1Red(ASSERTA_P,"asserta",2,assert_pred);
Def1Red(ASSERTZ_P,"assertz",2,assertz_pred);
Def1Red(ASSERT_P,"assert",3,assert_pred); /* assert(Pred,Defs,Const) */
Def1Red(ASSERTA_P,"asserta",3,assert_pred);
Def1Red(ATOMTOSTR_P,"atom_to_str",2,atom_to_str_pred); /* atom_to_str(Atom,^Str) */
Def2(ATTACH_P,"attach_constraint",1,attach_pred);
Def1Red(ASSERTZ_P,"assertz",3,assertz_pred);
/* cat(Pos,Form,Adjacent,Adjunct,Subcat,Sem) */
Def1Red(CNAME_P,"condname",2, cname_pred); /* constraint name */
Def2Red(CLAUSE_P,"clause",3, clause_pred); /* clause(head,body,const) */
Def1Red(CLOSE_P,"close",1,close_pred); /* file close */
Def1Red(CMP_P,"compare",3,compare_pred);
Def2Red(CONCAT_P,"concat",3, concat_pred); /* string concatenate */
Def1Red(CONCAT2_P,"concat2", 2, concat2_pred);
Def1Red(COUNT_P,"count",1, count_pred); /* counter */
Def1Red(CUNIFY,"unify",2, cunify_pred);
Def1(CUT_P,"!", 0, cut_pred);
Def1Red(DEFAULT_P,"default",3,default_pred);
Def1Red(DIVSTR_P,"divstr",4,divstr_pred);
Def1Red(EQUAL_P,"equal",2, equal_pred); /* = (check, substitution) */
Def1Red(NEQ_P,"neq",2, nequal_pred); /* t1=\=t2 */
Def1Red(EQ_P,"eq",2, eq_pred);
Def2(EXECUTE_P,"execute",1,or_pred); /* execute(List) */
Def1Red(FAIL_P,"fail", 0, NULL); /* fail, forever */
Def1Red(GENSYM_P,"gensym",2, gensym_pred);
Def1Red(FUNCTOR_P,"functor",3, functor_pred); /* functor(a(X,Y),a,2) */
Def1Red(GENSYM_P,"gensym",1, gensym_pred); /* gensym */
Def1Red(GEQ_P,"geq",2,geq_pred); /* >= */
Def1Red(GREATER_P,"greater",2,greater_pred); /* > */
Def1Red(HALT_P,"halt",0, halt_pred);
Def2Red(ISOP_P,"isop",3,isop_pred);
Def1Red(LEQ_P,"leq",2,leq_pred); /* <= */
Def1Red(LESS_P,"less",2,less_pred); /* < */
Def1Red(MAKELIST_P,"ml",2, makelist_pred); /* a(X,Y)=..[a,X,Y] */
/* Def1(MODULAR_P,"modularize",2, cunify_pred);*/
Def2Red(MEMB_P,"memb",2,memb_pred); /* system 'member' */
Def1Red(MULTIPLY_P,"multiply",3, multiply_pred);
/*multiply(X,Y,Z) is X*Y=Z */
Def1Red(NAME_P,"name",2, name_pred); /* array<->string */
Def1Red(NL_P,"nl",0, nl_pred); /* print CR */
Def1Red(NL_P,"nl",1, nl_pred); /* print CR */
Def1Red(OP_P,"op",3,op_pred); /* operator def */
Def1Red(OPEN_P,"open",3,open_pred); /* file open */
Def2(OR_P,"or",2, or_pred); /* or */
Def2(OR_P,"or",3,or_pred);
Def2(OR_P,"or",4,or_pred);
Def2(OR_P,"or",5,or_pred);
Def1(PROJECT_P ,"project_cstr",1, project_pred); /* print constraint */
Def1(PROJECT_P ,"project_cstr",2, project_pred); /* print constraint */
Def1(PCONSTRAINT_P ,"pcon",0, pcon_pred); /* print constraint */
Def1Red(READ_P,"read",1,read_pred); /* read TERM */
Def1Red(READ_P,"read",2,read_pred);
Def1Red(RETRACT_P,"retract",1,retract_pred); /* retract(Head) */
Def1Red(RETRACT_P,"retract",2,retract_pred); /* retract(Head,Defs) */
Def1Red(RETRACT_P,"retract",3,retract_pred); /* retract(H,D,Constr) */
Def1Red(STAY_P,"stayflag",3,stay_pred); /* set stayflag */
Def1Red(SEE_P,"see",1,see_pred); /* input file open */
Def1Red(SEEN_P,"seen",0,seen_pred); /* input file close */
Def1Red(STRLEN_P,"strlen",2,strlen_pred); /* length of string */
Def1Red(STRCMP_P,"strcmp",3,strcmp_pred);
Def1Red(SUBSTR_P,"substring",3,substr_pred); /* substring(Str,F,S) */
Def1Red(SUBSTR_P,"substring",4,substr_pred); /* substring(Str,F,N,S) */
Def1Red(SUM_P,"sum",3,sum_pred); /* sum(X,Y,Z) is X+Y=Z */
Def1Red(TAB_P,"tab",0,tab_pred); /* print tab */
Def1Red(TAB_P,"tab",1,tab_pred); /* print tab */
Def1Red(TELL_P,"tell",1,tell_pred); /* output file open */
Def1Red(TOLD_P,"told",0,told_pred); /* output file close */
Def1Red(TREE_P,"tree",1,tree_pred); /* tree print */
Def2Red(TRUE_P,"true",0,true_pred); /* true, forever */
Def1Red(UNBREAK_P,"unbreak",0,unbreak_pred); /* back to tracemode */
Def1Red(VAR_P,"var",1, var_pred); /* var() pred */
Def1Red(WRITE_P,"write",1,write_pred); /* write TERM */
Def1Red(WRITE_P,"write",2,write_pred);
Def1Red(PNAMES_P,"pnames",2,pnames_pred); /* get Property Names */
Def1Red(PVALUE_P,"pvalue",3,pvalue_pred); /* pvalue(PST,PNAME,VAL) */
Def1Red(TYPE_P,"type",2,type_pred); /* what type is it? */
Def1Red(RESET_TIMER_P,"reset_timer",0,reset_timer_pred);
Def1Red(TIMER_P,"timer",2,timer_pred);
/* predicate not in hash-table */
Deftemp(MODULAR_P,"modularize",2);
Deftemp(INTEG_P,"integrate",2);
}
void init_atoms()
{
Def1(CAT_P,"cat",6, NULL); /* category */
Def1(T_P,"t",3,NULL); /* three list t(M,L,R) */
Def1(LIST,".",2,NULL); /* list */
NIL = Nterm(0,ETERNAL); /* NIL = [] : end of list*/
NIL ->type.t_func = Nfunc(ETERNAL,"NIL", 0);
NIL->type.ident = ATOMIC_TYPE;
(FAIL = Nterm(0,ETERNAL))->type.t_func = FAIL_P;
Defatom(END_OF_FILE, "end_of_file");
Anonymous_var = (struct term *)(snew(var));
Anonymous_var->type.ident = VAR_VOID_TYPE;
((struct var *)Anonymous_var)->v_name = "_";
(Anonymous_env = snew(pair))->p_body = NULL;
MFAIL = Nclause(FAIL,NULL_CL,ETERNAL);
Defatom(S_GLOBAL_VAR,"global_var");
Defatom(S_VAR,"var");
Defatom(S_INTEGER,"integer"),
Defatom(S_FLOAT,"float");
Defatom(S_STRING,"string");
Defatom(S_FILE_POINTER,"file_pointer");
Defatom(S_PST,"pst");
Defatom(S_PSTOBJ,"pst_proplist");
Defatom(S_CLAUSE,"clause");
Defatom(S_LIST,"list");
Defatom(S_FUNCTOR,"functor");
Defatom(S_ATOM,"atom");
S_GREATER = Nterm(0,ETERNAL);
S_GREATER->type.t_func = Nfunc(TYPE1SYS,">",0);
S_LESS = Nterm(0,ETERNAL);
S_LESS->type.t_func = Nfunc(TYPE1SYS,"<",0);
S_EQ = Nterm(0,ETERNAL);
S_EQ->type.t_func = Nfunc(TYPE1SYS,"==",0);
}
void init_operator()
{
Defatom(XF_P, "xf");
Defatom(YF_P, "yf");
Defatom(FX_P, "fx");
Defatom(FY_P, "fy");
Defatom(XFX_P, "xfx");
Defatom(XFY_P, "xfy");
Defatom(YFX_P, "yfx");
Def1(DEF_P, ":-",2,NULL);
Def1(QUERY1_P, ":-",1,NULL);
Def1(QUERY2_P, "?-",1,NULL);
Def1Red(NOT_P, "not",1,not_pred);
Def1(EQSIGN_P, "<=>",2, NULL);
Def1Red(EQ2_P, "=",2,equal_pred);
Def1Red(MKLIST_P, "=..",2,makelist_pred);
Def1(CONSTRAINT_P, ";",2,NULL);
Def1(CONSTRAINT2_P, "where",2,NULL);
Def1Red(GREATER2_P, ">",2,greater_pred);
Def1Red(GEQ2_P,">=",2,geq_pred);
Def1Red(LESS2_P,"<",2,less_pred);
Def1Red(LEQ2_P,"<=",2,leq_pred);
Def1Red(EQUAL2_P,"==",2,eq_pred);
/* Def1Red(NEQ_P,"=\=",2,nequal_pred); */
Def1(PNAME_P,"/",2,NULL); /* property/value */
index_op(DEF_P, XFX ,1200);
index_op(QUERY1_P, FX , 1200);
index_op(QUERY2_P, FX, 1200);
index_op(CONSTRAINT_P, YFX, 1200);
index_op(CONSTRAINT2_P, YFX, 1200);
index_op(EQSIGN_P, XFX, 1200);
index_op(NOT_P, FY, 900);
index_op(MKLIST_P, XFX, 700);
index_op(GREATER2_P, XFX, 700);
index_op(GEQ2_P, XFX, 700);
index_op(LESS2_P, XFX, 700);
index_op(LEQ2_P, XFX, 700);
index_op(EQUAL2_P, XFX, 700);
index_op(EQ2_P, XFX, 700);
/* index_op(NEQ_P, XFX, 700); */
index_op(PNAME_P,XFY, 900);
}
/* execution of system predicate:
(t,e) : goal literal
return value :
SYSNO :: 't' is not system pred.
SYSTRUE :: (t,e) succeed
SYSFAIL :: (t,e) fail
*/
/*-------- initialize components of system predicates ---------- */
struct component *NOT_VACUOUS;
void init_froles()
{
void init_system_component();
MEMORY_ALLOC(NOT_VACUOUS,component,ETERNAL);
NOT_VACUOUS->c_label=NOPSTLABEL;
NOT_VACUOUS->c_next=(struct component *)NULL;
init_system_component(ARG_P,07);
init_system_component(APND_P,03);
init_system_component(CLAUSE_P,06);
init_system_component(CONCAT_P,07);
init_system_component(CONCAT2_P,03);
init_system_component(COUNT_P,01);
init_system_component(EQ2_P,01);
init_system_component(FUNCTOR_P,07);
init_system_component(GENSYM_P,01);
init_system_component(ISOP_P,07);
init_system_component(MAKELIST_P,03);
init_system_component(MEMB_P,02);
init_system_component(MULTIPLY_P,07);
init_system_component(NAME_P,03);
init_system_component(STRLEN_P,02);
/* init_system_component(SUM_P,07); */
init_system_component(PNAMES_P,02);
init_system_component(PNAME_P,02);
init_system_component(TYPE_P,02);
}
void init_system_component(f,a) /* initialize system component */
struct func *f;
unsigned long a; /* non vacuous bit pattern */
{
register int i,arity;
for (arity = f->f_arity, i = 0; i < arity; i++, a >>= 1)
if ((a & 01) != 0) Component(f,i) = NOT_VACUOUS;
}
int system_function(t,e,n) /* solve system functional predicate */
struct term *t;
struct pair *e;
struct node *n;
{
SYSFUNC comp;
struct func *f;
f = t->type.t_func;
comp = f->def.f_sysfunc;
if (comp == NULL) {
if (f == FAIL_P) return(SYSFAIL);
if (Handle_Undefined == TRUE) {
sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name);
error(nbuf);
}
else return(SYSFAIL);
}
if (isreduced(f)) return((*comp)(t,e));
else return((*comp)(t,e,n));
}
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
system_pred()
process system predicates
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
int system_pred(t,e,n,m,status) /* system (multi valued) predicate */
struct term *t;
struct pair *e;
struct node *n, *m;
int status; /* search status UP,DOWN,BACKTRACK */
{
SYSFUNC comp;
struct func *f;
f = t->type.t_func;
comp = f->def.f_sysfunc;
if (comp == NULL) {
if (Handle_Undefined == TRUE) {
sprintf(nbuf,">>> %s <<< is UNDEFINED!",f->f_name);
error(nbuf);
}
else return(SYSFAIL);
}
if (isreduced(f)) return((*comp)(t,e,n,status));
else return((*comp)(t,e,n,m,status));
}
int cut_pred(t,e,n)
struct term *t;
struct pair *e;
struct node *n;
{
if (n->n_link != NULL) n->n_link->n_set = NULL; /* OR-cut */
n->n_last = n->n_link;
Last_BT = n->n_link;
return(SYSTRUE);
}
/* always fail */ /*
int fail_pred(t,e)
struct term *t;
struct pair *e;
{
return(SYSFAIL);
} */
int halt_pred(t,e)
struct term *t;
struct pair *e;
{
quit_prolog();
return(SYSTRUE);
}
int abomb_pred(t,e)
struct term *t;
struct pair *e;
{
tprint0("\n Quit cu-prolog !!!!!\n");
exit(1);
}
int true_pred(t,e,n,status)
struct term *t;
struct pair *e;
struct node *n;
int status;
{
n->n_set = DUMMY_DEF;
return(SYSTRUE);
}
int op_pred(t,e)
register struct term *t;
register struct pair *e;
{
struct term *tt;
register struct pair *p, *ee;
register struct func *f;
int prec, otype;
tt = Arg1(t); ee = e;
down(p,tt,ee);
if (! is_int(tt))
error_detail(t,e,
"op/3: Illegal Argument --- Precedence should be integer");
prec = num_value(tt);
if ((prec < 0) || (prec > 1000))
error_detail(t,e,
"op/3: Illegal Argument --- Precedence should be from 0 to 1000");
tt = Arg2(t); ee=e;
down(p,tt,ee);
if ((p != NULL) || (! is_functor(tt)) || (! isatom(tt)))
error_detail(t,e,"op/3: Illegal Argument as type");
f = Pred(tt);
if (f == Pred(XF_P)) otype = XF;
else if (f == Pred(YF_P)) otype = YF;
else if (f == Pred(FX_P)) otype = FX;
else if (f == Pred(FY_P)) otype = FY;
else if (f == Pred(XFX_P)) otype = XFX;
else if (f == Pred(XFY_P)) otype = XFY;
else if (f == Pred(YFX_P)) otype = YFX;
else error_detail(t,e,"op/3:Illegal Argument as type");
tt = Arg3(t);
down(p,tt,e);
while (is_list(tt)) {
t = head_of_list(tt);
down(p,t,e);
if ((p != NULL) || (! is_functor(t)) || (! isatom(t)))
error_detail(t,e,
"op/3: Illegal Argument --- operator should be functor");
index_op(t->type.t_func, otype, prec);
tt = tail_of_list(tt);
down(p,tt,e);
}
if (tt != NIL)
if (is_functor(tt) && isatom(tt))
index_op(tt->type.t_func, otype, prec);
else
error_detail(t,e,
"op/3: Illegal Argument --- operator should be functor");
return(SYSTRUE);
}
void index_op(f, type, prec)
register struct func *f;
int type, prec;
{
register struct operator *o, *olast;
if ((type & INFIX) == INFIX) { /* INFIX operator */
if (f->f_arity != 2) f = Predicate(f->f_name,2);
}
else
if (f->f_arity != 1) f = Predicate(f->f_name,1);
for(olast = o = o_list; o!=NULL; olast = o, o=o->o_link)
if ((f == o->o_func) && ((type & INFIX) == (o->o_type & INFIX))) {
if (prec==0)
if (o==o_list) o_list=o->o_link;
else olast->o_link=o->o_link;
else o->o_prec=prec;
break;
}
if ((o == NULL) && (prec != 0)) {
o=snew(operator);
o->o_func = f;
o->o_prec = prec;
o->o_type = type;
o->o_link = o_list;
o_list = o;
}
}
int isop_pred(t,e,n,status)
struct term *t;
struct pair *e;
struct node *n;
int status;
{
struct operator *o;
struct ustack *usave;
int *hsave;
struct pair *esave;
struct term *tt;
if (status == BACKTRACK)
o = (struct operator *)n->n_set;
else o = o_list;
usave = usp;
hsave = hp;
esave = ep;
while (o != NULL) {
tt = Nterm(0,TEMPORAL);
tt->type.t_func = Predicate(o->o_func->f_name,0);
if (tunify(Arg3(t),e,tt,NULL_ENV,0) == FALSE)
{
undo(usave); hp = hsave; ep = esave; o=o->o_link;
continue;
}
tt = Nnum_val((float)o->o_prec,TEMPORAL);
if (tunify(Arg1(t),e,tt,NULL_ENV,0) == FALSE)
{
undo(usave); hp = hsave; ep = esave; o=o->o_link;
continue;
}
switch (o->o_type) {
case FX: tt = FX_P; break;
case FY: tt = FY_P; break;
case XF: tt = XF_P; break;
case YF: tt = YF_P; break;
case XFX: tt = XFX_P; break;
case XFY: tt = XFY_P; break;
case YFX:
default : tt = YFX_P;
}
if (tunify(Arg2(t),e,tt,NULL_ENV,0) == FALSE)
{
undo(usave); hp = hsave; ep = esave; o=o->o_link;
continue;
}
n->n_set = (struct set *)o->o_link;
return(SYSTRUE);
}
return(SYSFAIL);
}
int not_pred(t,e)
struct term *t;
struct pair *e;
{
struct node *goal,*lbsave,*lssave;
int *hsave = hp;
struct pair *esave;
struct ustack *usave = usp;
struct term *tt = Arg1(t);
int refute();
lbsave = Last_BT; /* 95.1.27 by Seki-san */
lssave = Last_SKIP;
esave = ep;
if (is_clause(tt))
goal = Newnode((struct clause *)tt,NULL_ECL,
e,NULL_NODE,NULL_NODE);
else if (is_functor(tt))
goal = Newnode(Nclause(tt,NULL_CL,TEMPORAL),
NULL_ECL, e,NULL_NODE,
NULL_NODE);
else error_detail(t,e,"not/1: Illegal Argument");
if (refute(goal,goal,DOWN)==FALSE) {
Last_BT=lbsave;
Last_SKIP = lssave;
return(SYSTRUE);
}
/* else */
undo(usave);
hp = hsave;
ep = esave;
Last_BT=lbsave;
Last_SKIP = lssave;
return(SYSFAIL);
}
int unbreak_pred(t,e)
struct term *t;
struct pair *e;
{
longjmp(unbreak_reset,1);
}
/* pnames({a/1,b/2,c/X}, Y) -> Y=[a,b,c]) */
int pnames_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *ps;
register struct eclause *pl;
struct pst_item *target;
struct pair *pp, *ee;
struct term *ls = NIL;
ps = Arg1(t);
ee = e;
down(pp, ps, ee);
if (! is_pst(ps)) error_detail(t,e,"pnames/2: 1st arg is not PST");
target = find_pstitem(ps,ee);
if (target != NULL_PSTIT)
pl = target->p_lists;
else pl = ((struct pst *)ps)->p_lists;
while (pl != NULL_ECL) {
ls = (struct term *)Nlist(Arg1(pl->c_form), (struct clause *)ls,TEMPORAL);
pl = pl->c_link;
}
return(equalpred(Arg2(t),e,ls,NULL_ENV));
}
/* pvalue({a/1,b/2,c/x},b,Z) -> Z=2 */
int pvalue_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *ps;
register struct pair *pp;
register struct eclause *pl;
struct term *pn;
struct pair *ee, *etemp;
struct pst_item *target;
int f,i;
ps = Arg1(t); pn = Arg2(t);
ee = e;
down(pp, ps, ee);
if (! is_pst(ps)) error_detail(t,e,"pvalue/3: 1st arg is not PST");
etemp = e;
down(pp, pn, etemp);
if ((! is_functor(pn))|| (pn->t_arity != 0))
error_detail(t,e,"pvalue/3: 2nd arg is not ATOM");
f = Pred(pn)->f_number;
target = find_pstitem(ps,ee);
if (target != NULL_PSTIT) {
pl = target->p_lists;
while(pl != NULL_ECL) {
i = Pred(Arg1(pl->c_form))->f_number - f;
if (i==0)
return(equalpred(Arg3(t),e, Arg2(pl->c_form),pl->c_env));
if (i > 0) return(SYSFAIL);
pl = pl->c_link;
}
}
else {
pl = ((struct pst *)ps)->p_lists;
while (pl != NULL_ECL) {
i = Pred(Arg1(pl->c_form))->f_number - f;
if (i==0)
return(equalpred(Arg3(t),e,Arg2(pl->c_form),ee));
if (i > 0) return(SYSFAIL);
pl = pl->c_link;
}
}
return(SYSFAIL);
}
int default_pred(t,e)
struct term *t;
struct pair *e;
{
struct term *ps, *templ, *dfs;
struct pair *p, *ee, *et, *ed;
static char *emessage = "default/3: %s arg is not PST";
ps = Arg(t,0); templ = Arg(t,1); dfs = Arg(t,2);
et = ed = ee = e;
down(p,templ,et);
if (! is_pst(templ)) {
sprintf(nbuf,emessage,"2nd");
error_detail(t,e, nbuf);
}
down(p,dfs,ed);
if (! is_pst(dfs)) {
sprintf(nbuf,emessage,"3rd");
error_detail(t,e,nbuf);
}
down(p,ps,ee);
if (! is_pst(ps)) {
sprintf(nbuf,emessage,"1st");
error_detail(t,e,nbuf);
}
if (subsume(ps, ee, templ, et, FALSE)==FALSE)
return(SYSFAIL);
pst_add_unify(ps,ee,dfs,ed);
return(SYSTRUE);
}
int subsume(t, e, u, f, flag)
register struct term *t, *u;
register struct pair *e, *f;
int flag; /* TRUE if Var subsumes everything, otherwise FALSE */
{
register struct pair *p, *q;
int i, j;
down(p, t, e);
down(q, u, f);
if(p != NULL)
if ((q != NULL) || (flag == TRUE)) return(TRUE);
else return(FALSE);
if (q != NULL) return(FALSE);
switch (u->type.ident) {
case ATOMIC_TYPE: /* t,u: atomic (string,num,quote) */
if ((t==u) || (atomic_equal(u,t))) return(TRUE);
else return(TRUE);
case LIST_TYPE:
case CONST_LIST_TYPE:
if (is_list(t))
if (subsume(head_of_list(t),e,head_of_list(u),f,flag)==TRUE)
return(subsume(tail_of_list(t),e,tail_of_list(u),f,flag));
return(FALSE);
case CLAUSE_TYPE:
if (is_clause(t)) {
while ((t != NULL) && (u != NULL)) {
if (subsume(((struct clause *)t)->c_form,e,
((struct clause *)u)->c_form,f,flag) == FALSE)
return(FALSE);
t=(struct term *)((struct clause *)t)->c_link;
u=(struct term *)((struct clause *)u)->c_link;
}
if (t == u) return(TRUE);
}
return(FALSE);
case PST_TYPE:
if (is_pst(t)) return(subsume_pst(t,e,u,f,flag));
return(FALSE);
default : /* functor */
if(Pred(t) == Pred(u)) {/* t,u: complex term */
for(i = 0, j = Pred(t)->f_arity; i < j; i++) {
if (subsume(Arg(t,i), e, Arg(u,i), f,flag) == FALSE)
return(FALSE);
}
return(TRUE);
}
return(FALSE);
}
}
int subsume_pst(t,e,u,f,flag)
register struct term *t,*u;
register struct pair *e,*f;
int flag;
{
struct pst_item *target, *object;
target = find_pstitem(t,e);
if (target == NULL_PSTIT)
target = record_pstobjects((struct pst *)t,e);
object = remove_pstitem(u,f);
if (object != NULL_PSTIT)
return(subsume_pstlist(target->p_lists,object->p_lists,
NULL_ENV,flag));
return(subsume_pstlist(target->p_lists,((struct pst *)u)->p_lists, f,flag));
}
int subsume_pstlist(x,y,e,flag)
struct eclause *x,*y;
struct pair *e;
int flag;
{
int i,fnum;
while (y != NULL_ECL) {
fnum = Pred(Arg1(y->c_form))->f_number;
while (x->c_link != NULL_ECL) {
i = Pred(Arg1(x->c_form))->f_number - fnum;
if (i == 0) {
if (e != NULL_ENV) {
if (subsume(x->c_form,x->c_env,y->c_form,e,flag)==FALSE)
return(FALSE);
}
else {
if (subsume(x->c_form,x->c_env,y->c_form,y->c_env,flag)==FALSE)
return(FALSE);
}
break;
}
else if (i > 0) return(FALSE);
x = x->c_link;
}
y = y->c_link;
x = x->c_link;
}
return(TRUE);
}
void pst_add_unify(t,e,u,f)
register struct term *t,*u;
register struct pair *e,*f;
{
struct pst_item *target, *object;
target = find_pstitem(t,e);
if (target == NULL_PSTIT)
target = record_pstobjects((struct pst *)t,e);
object = remove_pstitem(u,f);
if (object != NULL_PSTIT)
pst_add_unify_sub(target,object->p_lists,NULL_ENV);
else pst_add_unify_sub(target,((struct pst *)u)->p_lists, f);
}
void pst_add_unify_sub(entry, ol, e)
struct pst_item *entry;
struct eclause *ol;
struct pair *e;
{
int i, fnum;
struct eclause *pl;
if (ol==NULL_ECL) return;
pl=entry->p_lists;
if (pl == NULL_ECL) {
upush(&(entry->p_lists));
entry->p_lists=record_pstlists(ol,e);
return;
}
i = Pred(Arg1(pl->c_form))->f_number - Pred(Arg1(ol->c_form))->f_number;
if (i == 0) ol = ol->c_link;
else if (i > 0) {
upush(&(entry->p_lists));
entry->p_lists = Npstobj(ol->c_form,e,pl,MEDIUM);
ol = ol->c_link;
pl=entry->p_lists;
}
while (ol != NULL_ECL) {
fnum = Pred(Arg1(ol->c_form))->f_number;
while (pl->c_link != NULL_ECL) {
i = Pred(Arg1(pl->c_link->c_form))->f_number - fnum;
if (i == 0) break;
else if (i > 0) {
upush(&(pl->c_link));
pl->c_link = Npstobj(ol->c_form,e,pl->c_link,MEDIUM);
break;
}
pl = pl->c_link;
}
if (pl->c_link == NULL_ECL) {
upush(&(pl->c_link));
pl->c_link = record_pstlists(ol,e);
break;
}
else pl=pl->c_link;
ol = ol->c_link;
}
}
int type_pred(t,e)
struct term *t;
struct pair *e;
{
struct term *tt,*type;
struct pair *p, *et = e;
tt = Arg(t,0);
down(p,tt,et);
switch(tt->type.ident) {
case VAR_VOID_TYPE:
case VAR_PST_TYPE:
case VAR_GLOBAL_TYPE:
return(equalpred(Arg(t,1),e,S_VAR,NULL_ENV));
case ATOMIC_TYPE:
switch(tt->t_arity) {
case FLOAT_NUM:
return(equalpred(Arg(t,1),e,S_FLOAT,NULL_ENV));
case INT_NUM:
return(equalpred(Arg(t,1),e,S_INTEGER,NULL_ENV));
case STRING:
return(equalpred(Arg(t,1),e,S_STRING,NULL_ENV));
default:
return(equalpred(Arg(t,1),e,S_FILE_POINTER,NULL_ENV));
}
case PST_TYPE:
return(equalpred(Arg(t,1),e,S_PST,NULL_ENV));
case ECLAUSE_TYPE:
return(equalpred(Arg(t,1),e,S_PSTOBJ,NULL_ENV));
case CLAUSE_TYPE:
return(equalpred(Arg(t,1),e,S_CLAUSE,NULL_ENV));
case LIST_TYPE:
case CONST_LIST_TYPE:
return(equalpred(Arg(t,1),e,S_LIST,NULL_ENV));
default :
if (t->t_arity == 0)
return(equalpred(Arg(t,1),e,S_ATOM,NULL_ENV));
return(equalpred(Arg(t,1),e,S_FUNCTOR,NULL_ENV));
}
}
int reset_timer_pred(t,e)
struct term *t;
struct pair *e;
{
#if SUN4 == 1
OLD_TIME = clock();
#else
#if CPUTIME == 0
OLD_TIME = 0L;
#else
struct tms TIMES; /* cf. times() */
times(&TIMES);
OLD_TIME = TIMES.tms_stime + TIMES.tms_utime;
#endif
#endif
CONSTRAINT_HANDLING_TIME = 0L;
return(SYSTRUE);
}
int timer_pred(t,e)
struct term *t;
struct pair *e;
{
#if CPUTIME != 0
struct tms TIMES;
#endif
static char *emsg = "timer*/2: %s is not VAR";
register struct pair *p1, *p2, *ee;
struct term *t1, *t2;
ee = e;
t1 = Arg1(t); down(p1,t1,ee);
if (p1 == NULL) {
sprintf(nbuf,emsg,"1st");
error_detail(t,e,nbuf);
}
ee = e;
t2 = Arg2(t); down(p2,t2,ee);
if (p2 == NULL) {
sprintf(nbuf,emsg,"2nd");
error_detail(t,e,nbuf);
}
#if SUN4 == 1
t1 = Nnum_val(((float)((clock())-OLD_TIME))/1000000.0,TEMPORAL);
t2 = Nnum_val(((float)CONSTRAINT_HANDLING_TIME)/1000000.0,TEMPORAL);
#else
#if CPUTIME == 0
t1 = t2 = Nnum_val(0.0,TEMPORAL);
#else
times(&TIMES);
t1 = Nnum_val(((float)(TIMES.tms_stime+TIMES.tms_utime-OLD_TIME))/(float)CPUTIME,
TEMPORAL);
t2 = Nnum_val(((float)CONSTRAINT_HANDLING_TIME)/(float)CPUTIME,TEMPORAL);
#endif
#endif
upush(&(p1->p_body)); upush(&(p1->p_env));
upush(&(p2->p_body)); upush(&(p2->p_env));
p1->p_body = t1; p1->p_env = NULL_ENV;
p2->p_body = t2; p2->p_env = NULL_ENV;
return(SYSTRUE);
}
int stay_pred(t,e)
register struct term *t;
register struct pair *e;
{
struct term *t1, *tt;
register struct pair *p, *ee;
register struct func *f;
int prec, otype;
t1 = Arg1(t); ee = e;
down(p,t1,ee);
if ((p != NULL) || (! is_functor(t1)) || (! isatom(t1)))
error_detail(t,e,"stayflag/3: Illegal Argument as functor");
tt = Arg2(t); ee = e;
down(p,tt,ee);
if (! is_int(tt))
error_detail(t,e,
"stayflag/3: Illegal Argument as Arity");
f = funcsearch(Pred(t1)->f_name,(int)num_value(tt));
if (f == NULL) error_detail(t,e,"stayflag/3: No such a predicate");
tt = Arg3(t); ee = e;
down(p,tt,ee);
if (p != NULL) { /* 2nd arg is a variable */
if (((f->f_mark) & NON_UNFOLDABLE) != 0) {
if (((f->f_mark) & STAY_IF) == 0) { /* stay if false */
t1 = Nterm(0,TEMPORAL);
Pred(t1) = FAIL_P;
return(equalpred(tt,ee,t1,NULL_ENV));
}
else { /* stay if true */
t1 = Nterm(0,TEMPORAL);
Pred(t1) = TRUE_P;
return(equalpred(tt,ee,t1,NULL_ENV));
}
}
return(SYSFAIL);
}
if (Pred(tt) == TRUE_P)
f->f_mark |= STAY_IF_TRUE_PRED;
else if (Pred(tt) == FAIL_P)
f->f_mark |= STAY_IF_FALSE_PRED;
else error_detail(t,e,"stayflag/3: Illegal Argument as TRUE/FAIL");
return(SYSTRUE);
}
syntax highlighted by Code2HTML, v. 0.9.1