/* ----------------------------------------------------------
% (C)1992 Institute for New Generation Computer Technology
% (Read COPYRIGHT for detailed information.)
----------------------------------------------------------- */
/*=====================================================================
* cu-Prolog III (Constraint Unification Prolog)
* << syspred1.c >>
* (system predicates No.1)
* 1992-Nov-4 bug fix (general_assert: add up_init(),restore_init())
* 1994-July-13 apnd(), neq()
* 1994-Aug-10 CtoL() (name predicate) for Kanji
* 1995-Jan-27 retract() type2->type1
--------------------------------------------------------------------*/
#include "include.h"
/* for LtoC(), CtoL() pred */
#define FROM_NAME 1
#define FROM_CONC 0
int memb_pred(t,e,n,status) /* system 'member' pred */
struct term *t;
struct pair *e;
struct node *n;
int status;
{
register struct term *tt;
struct ustack *usave;
int *hsave;
struct pair *esave;
register struct pair *p,*pp,*ee;
if (status != BACKTRACK)
{
pp = Nenv(1);
n->n_hp = hp;
n->n_ep = ep;
n->n_usp = usp;
tt = Arg2(t);
ee = e;
}
else
{
pp = (struct pair *)n->n_set;
tt = pp->p_body;
ee = pp->p_env;
}
down(p,tt,ee);
usave = usp;
hsave = hp;
esave = ep;
while(tt != NIL)
{
if (! is_list(tt)) return(SYSFAIL);
if (tunify(Arg1(t),e,head_of_list(tt),ee,0) == FALSE)
{
/* undo(usave);
hp = hsave;
ep = esave; */ /* recovered in tunify() */
tt = tail_of_list(tt);
down(p,tt,ee);
continue;
}
pp->p_body = tail_of_list(tt);
pp->p_env = ee;
n->n_set = (struct set *)pp;
return(SYSTRUE);
}
return(SYSFAIL);
}
struct clause *copy_list_half(org,to,flag)
struct clause *org,*to;
int flag;
{
if (org == to) return((struct clause *)NIL);
else return(Nlist(head_of_list(org),
copy_list_half(org->c_link,to,flag),
flag));
}
struct clause *sys_append(cl,t,flag) /* cl+t */
struct clause *cl;
struct term *t;
int flag;
{
if (cl == (struct clause *)NIL) return((struct clause *)t);
else return(Nlist(head_of_list(cl),
sys_append(cl->c_link,t,flag),flag)
);
}
struct clause *concat_list(c1,c2) /* cl+t */
struct clause *c1,*c2;
{
register struct clause *c;
if (c1 == (struct clause *)NIL) return(c2);
for (c = c1; c->c_link != (struct clause *)NIL; c=c->c_link)
;
c->c_link = c2;
return(c1);
}
#define list_or_nil(Term) (is_list(Term)||Term==NIL)
int apnd_pred(t,e,n,status) /* system 'append' pred */
struct term *t;
struct pair *e;
struct node *n;
int status;
{
register struct term *t1,*t2,*t3;
register struct pair *ee,*p3,*e1,*p1;
struct clause *next,*cl;
int vnum;
void up_init0(),up_restore0(); /* modular.c */
t1 = Arg1(t); e1=e; down(p1,t1,e1);
if (p1 == NULL_ENV){ /* arg1: bound */
if (t1 == NIL) /* Arg1=[] */
{
if (tunify(Arg2(t),e,Arg3(t),e,0)==TRUE)
return(SYSTRUE);
else
return(SYSFAIL);
}
else if (status == BACKTRACK || p1 != NULL_ENV ||
!is_list(t1))
return(SYSFAIL);
else
{
up_init0(); /* up without log */
t1 = termset(t1,e1,TEMPORAL); /* copy of Arg1 */
t2 = termset(Arg2(t),e,TEMPORAL); /* copy of Arg2 */
up_restore0();
vnum = v_number + p_number;
if (vnum > 0) /* if there are vars in Arg1 or Arg2 */
{
ee = Nenv(vnum);
if (tunify(Arg1(t),e,t1,ee,0) == FALSE ||
tunify(Arg2(t),e,t2,ee,0) == FALSE)
return(SYSFAIL);
}
else ee = e;
cl= concat_list((struct clause *)t1,(struct clause *)t2);
if (tunify(Arg3(t),e,cl,ee,0)==TRUE)
return(SYSTRUE);
else
return(SYSFAIL);
}
}
else /* arg1:var, arg3: bound */
{
t3 = Arg3(t); ee=e; down(p3,t3,ee);
if (! list_or_nil(t3)) return(SYSFAIL);
if (status != BACKTRACK)
next = (struct clause *)t3;
else
next = (struct clause *)n->n_set;
for (;;)
{
cl = copy_list_half(t3,next,TEMPORAL);
if (tunify(Arg1(t),e,cl,ee,0) == TRUE &&
tunify(Arg2(t),e,next,ee,0) == TRUE)
{
n->n_set = (struct set *)(next->c_link);
return(SYSTRUE);
}
else{
if (next == (struct clause *)NIL) return(SYSFAIL);
next=next->c_link;
}
}
}
}
int or_pred(t,e,n,m,status)
struct term *t;
register struct pair *e;
struct node *n, *m;
int status;
{
register struct term *tt;
register struct pair *e0;
struct pair *p;
struct clause *c0;
struct clause *convert_list_to_clause();
int arity, next = 0;
if (status == BACKTRACK)
next = (int)n->n_set;
tt = Arg(t,next++);
e0 = e; down(p,tt,e0);
if ((arity = t->t_arity) < 0) arity = -arity;
n->n_set = (next < arity) ? (struct set *)next : NULL;
if (p != NULL) {
sprintf(nbuf,"or*/%d: %d-th argument is real VAR",arity,next-1);
error_detail(t,e,nbuf);
}
else if ((tt == NIL) || (tt==NULL)) return(SYSTRUE);
if (is_list(tt)) {
sprintf(nbuf,"or*/%d: %d th argument is not List",arity, (next-1));
c0 = convert_list_to_clause(t,e,tt,e0,&p,nbuf);
}
else {
p = e0;
if (! is_clause(tt))
c0 = Nclause(tt,NULL_CL,TEMPORAL);
else c0 = (struct clause *)tt;
}
m->n_clause = c0;
m->n_env = p;
m->n_usp = usp;
m->n_hp = hp;
m->n_ep = ep;
m->n_set = init_set(m);
return(SYSTRUE);
}
struct clause *convert_list_to_clause(t,e,tt,ee,p,emsg)
struct term *t, *tt;
struct pair *e, *ee, **p;
char *emsg;
{
struct clause *c, *cc;
register struct pair *pp;
v_number = 0; v_list = NULL;
*p = Nenv(0);
c = cc = Nclause(NULL,NULL_CL,TEMPORAL);
while(1) {
if (isconst(head_of_list(tt))) cc->c_form = head_of_list(tt);
else {
pp = Nenv(1);
cc->c_form = Nvar(Anonymous_VarName,TEMPORAL);
pp->p_body = head_of_list(tt);
pp->p_env = ee;
}
tt = tail_of_list(tt);
down(pp,tt,ee);
if ((tt == NIL) || (tt == NULL)) break;
cc->c_link = Nclause(NULL, NULL_CL, TEMPORAL);
cc = cc->c_link;
}
return(c);
}
int read_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *tt, *target;
register struct pair *p, *ee;
FILE *filep;
int arity;
if ((arity = t->t_arity) < 0) arity = -arity;
filep = fp;
if (arity == 2) {
tt = Arg2(t);
ee = e;
down(p,tt,ee);
if (! is_file(tt)) error("read*/2: Illegal file pointer");
fp = filep_value(tt);
if (! is_readable(fp))
{
fp = filep;
error("read*/2: file not open");
}
}
v_number = 0; v_list = NULL;
p_number = 0; reread = 0;
advance;
if (check(EOF)){
target = END_OF_FILE;
fclose(fp);
}
else {
target = Rterm(1200,TEMPORAL);
if (tokentype!=FULLSTOP) {
error_detail(target,NULL_ENV,"Syntax error --- . expected");
}
skipline;
}
fp = filep;
ee = Nenv(v_number+p_number);
return(equalpred(Arg1(t),e,target,ee));
}
#define SPECIFIED 0
#define INPUT 1
#define OUTPUT 2
int open_pred(t,e)
struct term *t;
struct pair *e;
{
return(file_open_pred(t,e,SPECIFIED));
}
int see_pred(t,e)
struct term *t;
struct pair *e;
{
return(file_open_pred(t,e,INPUT));
}
int tell_pred(t,e)
struct term *t;
struct pair *e;
{
return(file_open_pred(t,e,OUTPUT));
}
int file_open_pred(t,e,openmode)
register struct term *t;
register struct pair *e;
int openmode;
{
static char *emsg = "open/3: Illegal argument --- should not be variable";
register struct pair *p, *ee;
register struct term *tt;
char *mode, *fname;
FILE *filep, *fopen();
tt = Arg1(t);
ee = e;
down(p,tt,ee);
if (p != NULL) error_detail(t,e,emsg);
if (is_string(tt)) fname=str_value(tt);
else if (!is_atomic(tt)) fname=tt->type.t_func->f_name;
else error_detail(t,e,"open/3: Illegal file name");
switch (openmode) {
case INPUT:
mode = "r";
break;
case OUTPUT:
mode = "w";
break;
case SPECIFIED:
tt = Arg2(t);
ee = e;
down(p,tt,ee);
if (p != NULL) error_detail(t,e, emsg);
mode = (is_string(tt)) ? str_value(tt) : tt->type.t_func->f_name;
if (((mode[0] != 'r') && (mode[0] != 'w')) || mode[1] != '\0') {
sprintf(nbuf,"open/3: Illegal mode >> %s << shoule be 'r' or 'w'",mode);
error(nbuf);
}
}
if ((filep = fopen(fname, mode)) == NULL)
error("open/3: can't open the file");
switch (openmode) {
case INPUT: fp=filep; return(SYSTRUE);
case OUTPUT: wfp=filep; return(SYSTRUE);
}
tt = Nterm(0,TEMPORAL);
tt->type.ident = FILE_TYPE;
tt->tag.s_value = (char *)filep;
return(equalpred(Arg3(t),e,tt,NULL_ENV));
}
int seen_pred(t,e)
struct term *t;
struct pair *e;
{
FILE *f = wfp;
if (fp != stdin) fclose(fp);
else {
wfp = stderr;
tprint0("Warning: no file is opened for input\n");
wfp = f;
}
fp = stdin;
return(SYSTRUE);
}
int told_pred(t,e)
struct term *t;
struct pair *e;
{
if (wfp != stdout) fclose(wfp);
else {
wfp = stderr;
tprint0("Warning: no file is opened for output\n");
wfp = stdout;
}
wfp = stdout;
return(SYSTRUE);
}
int close_pred(t,e)
register struct term *t;
register struct pair *e;
{
FILE *filep;
register struct pair *p;
t = Arg1(t);
down(p,t,e);
if (! is_file(t)) error("close/1: Illegal argument");
filep = filep_value(t);
if ((filep == stdin) || (filep == stdout))
error("close/1: stdin/stdout cannot be closed!");
fclose(filep);
return(SYSTRUE);
}
struct clause *new_pred_def2(vl,vnum) /* <-- project_pred */
struct term *vl;
int vnum;
{
register struct term *v,*tmp,*t;
register struct func *newfunc;
struct clause *c;
int i,arity=0;
tmp = Nterm(vnum,TEMPORAL);
for (v = vl; v != NULL; v = vlink(v))
if (((struct var *)v)->v_type == (long int)VAR_GLOBAL_TYPE)
Arg(tmp,arity++) = v;
if (arity == 0) return(NULL_CL);
t = Nterm(arity,ETERNAL);
for (i=0; i < arity; i++)
Arg(t,i) = Arg(tmp,arity -1 - i);
while (1) { /* new predicate name */
sprintf(nbuf, "%s%d", genname, GENSYM++);
if (exist_fname(nbuf) == NULL) break;
}
newfunc = Nfunc(USERFUN, nbuf, arity);
newpred(newfunc);
index_func(newfunc);
t->type.t_func = newfunc;
c = Nclause(t,NULL_CL,ETERNAL);
/* recalc_voccurrence(c, vl); */
return(c);
}
int project_pred(t,e,n) /* print constraint */
struct term *t;
struct pair *e;
register struct node *n;
{
struct term *tt, *tnew;
struct clause *nclause, *body;
struct set *s;
struct pair *e0;
int arity;
if ((arity = t->t_arity) < 0) arity = -arity;
if (n->n_constraint == NULL_ECL)
{
if (arity == 2)
{
return(equalpred(NIL,NULL_ENV,Arg2(t),e));
}
tprint0("nil");
return(SYSTRUE); /* need not print */
}
e0 = Nenv(0);
up_init();
tt = Arg1(t);
tnew = termset(tt,e,ETERNAL);
nclause = new_pred_def2(v_list,v_number);
if (nclause == NULL) {
up_restore();
if (arity == 2)
{
return(equalpred(NIL,NULL_ENV,Arg2(t),e));
}
tprint0("no constrained");
return(SYSTRUE); /* need not print */
}
body = up_eclause(n->n_constraint, ETERNAL);
if (nclause == NULL_CL) {
up_restore();
if (arity == 2)
{
return(equalpred(NIL,NULL_ENV,Arg2(t),e));
}
tprint0("no constraint");
return(SYSTRUE); /* need not print */
}
up_restore();
nclause->c_link = body; /* Head:-Body. */
s = snew(set);
s->s_clause = nclause;
s->s_anumber = v_number + p_number;
s->s_vlist = v_list;
s->s_link = (struct set *)NULL;
s->s_constraint = NULL_CL;
s->s_bodynumber = 0; /* set in add_set */
if (p_number != 0) {
renum_pvars((struct pstvar *)pv_list,v_number);
}
add_set(s,'z');
if (arity == 2)
{
return(equalpred(nclause->c_form,e0,Arg2(t),e));
}
Pterm(nclause->c_form,e0);
return(SYSTRUE);
}
int pcon_pred(t,e,n) /* print constraint */
struct term *t;
struct pair *e;
register struct node *n;
{
Peclause(n->n_constraint);
return(SYSTRUE);
}
int attach_pred(t,e,n,m,status) /* attach constraints */
struct term *t;
struct pair *e;
struct node *n,*m;
int status;
{
struct pair *p, *ee;
struct term *tt;
register struct clause *c;
struct eclause *ec;
static char *emesg = "attach_constraint/1: Illegal Argument";
struct clause *convert_list_to_clause();
tt = Arg1(t);
ee = e;
down(p,tt,ee);
if (is_list(tt)) {
c = convert_list_to_clause(t,e,tt,ee,&p,emesg);
}
else if (is_clause(tt)) {
c = (struct clause *)tt;
p = ee;
}
else if (tt==NIL) return(SYSTRUE);
else if (is_functor(tt)) {
c = Nclause(tt, NULL_CL, TEMPORAL);
p = ee;
}
else error_detail(t,e,emesg);
ec = transform(n->n_constraint, c, p);
if (ec == (struct eclause *)MFAIL)
return(SYSFAIL);
upush(&(m->n_constraint));
m->n_constraint=ec;
return(SYSTRUE);
}
int cunify_pred(t,e) /* c.u. unify() */
register struct term *t;
register struct pair *e;
{
if (cu(t,e) != FALSE )
return(SYSTRUE); /* success */
else
return(SYSFAIL); /* fail */
}
int write_pred(t,e)
struct term *t;
struct pair *e;
{
register struct pair *p, *ee;
register struct term *tt;
FILE *filep;
int arity;
if ((arity = t->t_arity) < 0) arity = -arity;
filep = wfp;
if (arity == 2) {
tt = Arg2(t);
ee = e;
down(p,tt,ee);
if (! is_file(tt)) error("write*/2: Illegal file pointer");
wfp = filep_value(tt);
if (! is_writable(wfp))
{
wfp = filep;
error("write*/2: file not open");
}
}
tt = Arg1(t);
down(p,tt,e);
if (is_string(tt)) tprint1("%s",str_value(tt))
else Pterm(tt, e);
wfp = filep;
return(SYSTRUE);
}
int nl_pred(t,e)
register struct term *t;
register struct pair *e;
{
register struct pair *p;
FILE *filep;
int arity;
filep = wfp;
if ((arity = t->t_arity) < 0) arity = -arity;
if (arity != 0) {
t = Arg1(t);
down(p,t,e);
if (! is_file(t)) error("nl*/1: Illegal file pointer");
wfp = filep_value(t);
if (! is_writable(wfp))
{
wfp = filep;
error("nl*/2: file not open");
}
}
NL;
wfp = filep;
return(SYSTRUE);
}
int tab_pred(t,e)
register struct term *t;
register struct pair *e;
{
register struct pair *p;
FILE *filep;
int arity;
filep = wfp;
if ((arity = t->t_arity) < 0) arity = -arity;
if (arity != 0) {
t = Arg1(t);
down(p,t,e);
if (! is_file(t)) error("tab*/1: Illegal file pointer");
wfp = filep_value(t);
if (! is_writable(wfp))
{
wfp = filep;
error("tab*/2: file not open");
}
}
tprint0("\t");
wfp = filep;
return(SYSTRUE);
}
int var_pred(t,e)
struct term *t;
register struct pair *e;
{
register struct pair *p;
register struct term *tt;
tt = Arg1(t);
down(p,tt,e);
if (p != NULL) return(SYSTRUE); /* (t,e) is var */
else return(SYSFAIL); /* (t,e) is not var */
}
/* equal ( = ) predicate :
equal(t1,t2) = SYSTRUE : if t1/e = t2/e
else SYSFAIL
*/
int equal_pred(t,e)
register struct term *t;
struct pair *e;
{
return(equalpred(Arg1(t),e,Arg2(t),e));
}
int eq_pred(t,e)
register struct term *t;
struct pair *e;
{
return(eq_pred_sub(Arg1(t),Arg2(t),e,e));
}
int nequal_pred(t,e) /* not-equal predicate */
register struct term *t;
struct pair *e;
{
int *hsave,res;
struct pair *esave;
struct ustack *usave;
esave = ep;
hsave = hp;
usave = usp;
if (tunify(Arg1(t),e,Arg2(t),e,0) == TRUE)
{
undo(usave);
hp = hsave;
ep = esave;
return(SYSFAIL);
}
else return(SYSTRUE);
}
int eq_pred_sub(x,y,ex,ey)
register struct term *x, *y;
register struct pair *ex, *ey;
{
register struct pair *p;
down(p,x,ex);
down(p,y,ey);
if ((x == y) && (ex == ey)) return(SYSTRUE);
if (isvar(x) || (p != NULL)) return(SYSFAIL);
if (x->type.ident != y->type.ident) return(SYSFAIL);
if (is_atomic(x)) {
if (atomic_equal(x,y)) return(SYSTRUE);
else return(SYSFAIL);
}
if (is_pst(x))
return(eq_pred_sub(((struct pst *)x)->p_var,((struct pst *)y)->p_var,
ex,ey));
if (is_clause(x) || is_list(x)) {
do {
if (eq_pred_sub(head_of_list(x),head_of_list(y),ex,ey) == SYSFAIL)
return(SYSFAIL);
x = tail_of_list(x);
y = tail_of_list(y);
} while ((x != NULL) && (x != NIL) && (y != NULL) && (y != NIL));
return(SYSTRUE);
}
if (is_functor(x) && is_functor(y)) {
register int i, a = x->t_arity;
if (a != y->t_arity) return(SYSFAIL);
if (a < 0) a = -a;
for(i=0;i < a; i++) {
if (eq_pred_sub(Arg(x,i),Arg(y,i),ex,ey) == SYSFAIL)
return(SYSFAIL);
}
}
return(SYSTRUE);
}
int equalpred(t1,e1,t2,e2)
register struct term *t1, *t2;
register struct pair *e1, *e2;
{
int *hsave;
struct pair *esave;
struct ustack *usave;
esave = ep;
hsave = hp;
usave = usp;
if (tunify(t1,e1,t2,e2,0) == FALSE)
{
/* undo(usave);
hp = hsave;
ep = esave; */
return(SYSFAIL);
}
return(SYSTRUE);
}
int assertz_pred(t,e)
struct term *t;
struct pair *e;
{
general_assert(t,e,'z');
return(SYSTRUE);
}
int assert_pred(t,e)
struct term *t;
struct pair *e;
{
general_assert(t,e,'a');
return(SYSTRUE);
}
void general_assert(t,e,flag)
struct term *t;
struct pair *e;
char flag; /* 'a'(first) or 'z'(last) */
{
struct term *pred, *defs, *con;
register struct pair *p, *ee;
struct clause *c_head, *c_con;
struct ustack *usave;
int arity;
pred = Arg1(t);
ee = e;
down(p,pred,ee);
if ((p != NULL) || is_atomic(pred)) {
error_detail(t,e,"assert*/1: Illegal argument");
}
if (issystem(pred->type.t_func)) {
error_detail(t,e,"assert*/1: system function cannot be asserted");
}
v_list = NULL; v_number = 0;
pv_list = NULL; p_number = 0;
usave = usp;
if ((arity = t->t_arity) < 0) arity = -arity;
/* make first clause (head) */
con = (arity == 3) ? Arg3(t) : NULL;
defs = (arity > 1) ? Arg2(t) : NULL;
up_init(); /* BUG FIX 1992-Nov-4 */
c_head = Nclause(termset(pred,ee,ETERNAL),
list_to_clause(defs,e), ETERNAL);
c_con = list_to_clause(con,e);
up_restore();
if (p_number != 0) renum_pvars((struct pstvar *)pv_list,v_number);
index_set(c_head,c_con,flag);
undo(usave);
}
struct clause *list_to_clause(t,e)
register struct term *t;
register struct pair *e;
{
struct clause *croot, *cbefore, *cc;
register struct pair *p;
int *ssave = shp;
if (t != NULL) down(p,t,e);
if ((t == NULL) || (t == NIL)) return(NULL);
croot = snew(clause);
croot->c_type = CLAUSE_TYPE;
cbefore = cc = croot;
while(1)
{
if(! is_list(t)) {
shp = ssave;
error_detail(t,e,
"In assert or execute: Illegal argument ... should be LIST");
}
cc->c_form = termset(head_of_list(t),e,ETERNAL);
t = tail_of_list(t);
down(p,t,e);
if (t == NIL) break;
cbefore = cc;
cc = snew(clause);
cc->c_type = CLAUSE_TYPE;
cbefore->c_link = cc;
}
cc->c_link = NULL;
return(croot);
}
int retract_pred(t,e)
struct term *t;
struct pair *e;
{
register struct set *ss, *foreset;
register struct pair *p, *et;
register struct ustack *usave;
struct term *tt;
struct term *c_defs, *c_con;
struct term *defs, *con;
struct pair *newenv;
int arity;
if ((arity = t->t_arity) < 0) arity = -arity;
tt = Arg1(t);
et = e;
down(p,tt,et);
if (isvar(tt) || is_atomic(tt))
error("retract*/1: Illegal argument");
if (!isuser(tt->type.t_func)) return(SYSFAIL);
foreset = NULL;
ss = Pred(tt)->def.f_set;
usave = usp;
con = (arity == 3) ? Arg3(t) : NIL;
defs = (arity >= 2) ? Arg2(t) : NIL;
while(ss != NULL)
{
newenv = Nenv((int)ss->s_anumber);
if (tunify(tt,et,ss->s_clause->c_form,newenv,0)==FALSE)
{
/* undo(usave); */ foreset = ss; ss = ss->s_link;
continue;
}
c_defs = tolist(ss->s_clause->c_link,TEMPORAL);
if (tunify(defs,e,c_defs,newenv,0) == FALSE)
{
/* undo(usave); */ foreset = ss; ss = ss->s_link;
continue;
}
c_con = tolist(ss->s_constraint,TEMPORAL);
if (tunify(con,e,c_con,newenv,0) == FALSE)
{
/* undo(usave); */ foreset = ss; ss = ss->s_link;
continue;
}
if (foreset == NULL) /* set the next goal */
Pred(tt)->def.f_set = ss->s_link;
else
foreset->s_link = ss->s_link;
((struct func *)tt->type.t_func)->f_setcount--;
if is_unitclause(ss)
((struct func *)tt->type.t_func)->f_unitcount--;
((struct func *)tt->type.t_func)->f_mark |= VACUITY_NOCHECK;
Def_Modified = 1;
return(SYSTRUE);
}
return(SYSFAIL);
}
void clear_predicate(f) /* clear user predicate */
register struct func *f;
{
register int i;
f->def.f_set = NULL;
f->f_setcount = 0;
f->f_unitcount = 0;
for (i = 0; i < f->f_arity; i++) Component(f,i) = NULL;
/* f->f_roles[0] = 0; */
}
int abolish_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *f, *a;
register struct pair *ef, *ea, *p;
struct func *fun;
f = Arg1(t);
a = Arg2(t);
ef = ea = e;
down(p,f,ef); down(p,a,ea);
if ((f->type.ident < CONST_LIST_TYPE) || (! is_int(a))) {
error_detail(t,e,"abolish/2: Illegal argument.");
}
fun = funcsearch(Predname(f),(int)(num_value(a)));
if (fun != NULL)
{
if (issystem(fun)) {
error_detail(t,e,"abolish/2: System predicates cannot be abolished");
}
clear_predicate(fun);
Def_Modified = 1; /* def modified ! */
}
return(SYSTRUE);
}
int makelist_pred(t,e) /* for predicate ' ml(Pred,List) (=..) ' */
struct term *t;
struct pair *e;
{
struct term *t0, *t1, *tt, *tfun;
register struct pair *e0, *e1, *efun, *p;
int nvars, depth = 0;
t0 = Arg1(t);
t1 = Arg2(t);
e0 = e1 = e;
down(p,t0,e0);
down(p,t1,e1);
/* 1st arg is var */
if( isvar(t0) ){
if (isvar(t1)) return(SYSFAIL);
if (! is_list(t1)) {
error_detail(t,e,"ml/2: Illegal argument");
}
tfun = head_of_list(t1); /* tfun : functor name */
efun = e1;
down(p,tfun,efun);
if (isvar(tfun) || (! is_functor(tfun))) {
error_detail(t,e,"ml/2:Illegal term for functor.");
}
t1 = tail_of_list(t1);
depth=Llevel(t1,e1,&nvars);
if (Pred(tfun) == LIST) {
if (depth != 2) {
error_detail(t,e,"ml/2: Illegal argument for LIST");
}
tt = (struct term *)
Nlist(head_of_list(t1),
(struct clause *)tail_of_list(t1),TEMPORAL);
return(equalpred(t0,e0,tt,efun));
}
tt = Nterm(depth,TEMPORAL);
Pred(tt) = Predicate(Predname(tfun), depth);
if (t1 != NIL )
{
efun = Nenv(0);
LtoP(t1,e1,tt,depth);
}
return(equalpred(t0,e0,tt,efun));
}
/* 1st arg is term */
if (is_atomic(t0)) tfun=t0;
else if (is_list(t0)) {
Pred(tfun)=LIST;
tt = (struct term *)Nlist(tfun,(struct clause *)t0,TEMPORAL);
return(equalpred(t1,e1,tt,e0));
}
else if (is_functor(t0))
{
tfun = Nterm(0,TEMPORAL);
tfun->type.t_func = Predicate(Predname(t0),0);
}
else error("ml/2:Illegal argument");
tt = (struct term *)Nlist(tfun,PtoL(t0),TEMPORAL);
return(equalpred(t1,e1,tt,e0));
}
int Llevel(t,e,nv) /* from makelist() : Listlevel -> Depth (int) */
register struct term *t;
register struct pair *e;
int *nv;
{
register struct pair *pp;
int depth=0;
*nv = 0;
if (isvar(t)) down(pp,t,e);
while( t != NIL )
{
if (! is_list(t)) error("ml/2: cdr is real var");
if (! isconst(head_of_list(t))) (*nv)++;
t = tail_of_list(t);
depth++;
if (isvar(t)) down(pp,t,e);
};
return(depth);
}
void LtoP(t,e,tt,depth) /* from makelist() : List -> Predicate */
register struct term *t, *tt;
register struct pair *e;
int depth;
{
register struct pair *p;
register int i;
v_list = NULL; v_number = 0;
for(i = 0; i < depth ; i++)
{
if (isvar(t)) down(p,t,e);
if (isconst(head_of_list(t))) Arg(tt,i)=head_of_list(t);
else {
Nvar(Anonymous_VarName,TEMPORAL);
p = Nenv(1);
p->p_body = head_of_list(t);
p->p_env = e;
Arg(tt,i)=(struct term *)v_list;
}
t = tail_of_list(t);
}
return;
}
struct clause *PtoL(t) /* from makelist() : Predicate -> List */
struct term *t;
{
struct clause *root;
register struct term *tt, *temp;
int pos = 0, arity;
struct term *tt1;
if (is_atomic(t)) return((struct clause *)NIL);
if ((arity = t->t_arity)==0) return((struct clause *)NIL);
if (arity < 0) arity = -arity;
root = Nlist(NIL,(struct clause *)NIL,TEMPORAL);
tt = (struct term *)root;
while(1) {
head_of_list(tt) = Arg(t,pos);
pos++;
if (pos >= arity) break;
tt1 = tail_of_list(tt);
temp = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL);
tt1 = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL);
tt = temp;
}
return(root);
}
int name_pred(t,e) /* for predicate ' name(String,List) ' */
struct term *t;
struct pair *e;
{
register struct term *tt,*arg0,*arg1;
register struct pair *p,*e0,*e1;
arg0 = Arg1(t);
arg1 = Arg2(t);
e0 = e1 = e;
*nbuf = '\0';
down(p,arg0,e0);
down(p,arg1,e1);
/* 1st arg is var */
if (isvar(arg0)){
if (isvar(arg1)) return(SYSFAIL);
LtoC(arg1,e1,0,FROM_NAME); /* List -> (char)nbuf[] */
if (alldigit(nbuf)) tt = Nnum(nbuf,TEMPORAL);
else {
tt = Nterm(0,TEMPORAL);
Pred(tt) = Predicate(nbuf,0);
}
return(equalpred(arg0,e0,tt,NULL_ENV));
}
/* 1st arg is constant */
if (is_num(arg0))
{
sprintf(nbuf,"%d",(int)num_value(arg0));
tt = CtoL(nbuf, FROM_NAME);
}
else if (is_string(arg0))
tt = CtoL( str_value(arg0), FROM_NAME );
else if (isatom(arg0))
tt = CtoL(Predname(arg0), FROM_NAME);
else return(SYSFAIL);
return(equalpred(arg1,e1,tt,NULL_ENV));
}
void LtoC(t,e,pos, flag) /* from name_pred() : List -> Charactar */
struct term *t;
struct pair *e;
int pos, flag; /* flag = 0(FROM_CONC) /char, 1(FROM_NAME) /int */
{
register struct pair *e0, *e1, *p;
register struct term *arg0, *arg1;
if (is_string(t))
{ strcpy(nbuf, str_value(t)); return; }
if (! is_list(t)) error("name/2: 2nd arg is illegal term.");
arg0 = head_of_list(t);
arg1 = tail_of_list(t);
e0 = e1 = e;
down(p,arg0,e0);
down(p,arg1,e1);
if (isvar(arg0) || (! isatom(arg0)) || isvar(arg1)) {
sprintf(nbuf,"%s/2: 2nd arg is real VAR",
((flag) ? "name" : "concat2"));
error_detail(t,e,nbuf);
}
if (flag) {
if (! is_int(arg0))
error("name/2: 2nd arg contains illegal term.");
else nbuf[pos++] = (int)num_value(arg0);
}
else
{
if (is_string(arg0))
strcat(nbuf, str_value(arg0));
else if ((is_functor(arg0)) && (isatom(arg0)))
strcat(nbuf,Predname(arg0));
else if (is_int(arg0)) {
int len = strlen(nbuf);
nbuf[len++]=(int)num_value(arg0);
nbuf[len]='\0';
}
else {
error_detail(arg0,e0,"concat2/2: illegal arg");
}
}
if (arg1 != NIL) LtoC(arg1,e1,pos,flag);
else if (flag) nbuf[pos] = '\0';
return;
}
struct term *CtoL(nbuf, flag)
/* from name_pred() : Charactar -> List */
unsigned char *nbuf;
int flag; /* 0(FROM_CONC) -> char, 1(FROM_NAME) -> int */
{
struct term *root, *t;
unsigned char s[3];
register int pos = 0;
root = t = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL);
while (1)
{
if (flag == FROM_NAME) {
head_of_list(t)=Nnum_val((float)nbuf[pos++],TEMPORAL);
}
else {
s[0] = nbuf[pos++];
s[1] = '\0';
#if KANJI ==1
if (s[0] > EUCOS) {
s[1] = nbuf[pos++];
s[2] = '\0';
}
#endif
head_of_list(t) = Nstr(s, TEMPORAL);
}
if (nbuf[pos] == '\0') return(root);
t = (struct term *)Nlist(NIL,(struct clause *)NIL,TEMPORAL);
}
}
int arg_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *pos, *tt, *var;
register struct pair *p, *ep, *et, *ev;
int i, arity;
pos = Arg(t,0);
tt = Arg(t,1);
var = Arg(t,2);
ep = et = ev = e;
down(p,pos,ep); down(p,tt,et); down(p,var,ev);
if (isvar(pos) || isvar(tt)) return(SYSFAIL);
if (! is_int(pos)) {
error_detail(t,e,"arg/3: illegal argument");
}
i = num_value(pos);
if (is_list(tt))
switch (i) {
case 1: return(equalpred(head_of_list(tt),et,var,ev));
case 2: return(equalpred(tail_of_list(tt),et,var,ev));
default:
error_detail(t,e,"arg/3:Illegal argument for position");
}
else if (! is_functor(tt)) {
error_detail(t,e,"arg/3:Illegal argument for functor");
}
if((arity = tt->t_arity) < 0) arity = -arity;
if ((i <= 0) || (tt->type.ident == 0) || i > arity) {
error_detail(t,e,"arg/3: illegal argument");
}
return(equalpred(Arg(tt,i-1),et,var,ev));
}
int functor_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *tt, *fun, *ari;
register struct pair *p, *et, *ef, *ea;
tt = Arg(t,0); fun = Arg(t,1); ari = Arg(t,2);
ea = ef = et = e;
down(p,tt,et); down(p,fun,ef); down(p,ari, ea);
if (isvar(tt)) return(make_func(fun,ari,tt,et));
if ((! is_functor(tt)) && (! is_list(tt)))
error_detail(t,e,"functor/3: 1st argument is not appropriate");
return(match_func(tt,et,fun,ef,ari,ea));
}
int make_func(f,a,t,e)
struct term *f, *a, *t;
struct pair *e;
{
struct term *temp;
struct pair *env;
int i,arity;
if (isvar(f) || isvar(a)) return(SYSFAIL);
if (! (isatom(f))) {
error_detail(t,e,"functor/3: 2nd argument is not atom");
}
if (! (is_int(a))) {
error_detail(t,e,"functor/3: 3rd argument is not integer");
}
if ((arity = (int)(num_value(a))) < 0) {
error_detail(t,e,"functor/3: 3rd argument is illegal number");
}
if (arity==0) return(equalpred(t,e,f,e));
v_list = NULL; v_number = 0;
env = Nenv(arity);
if ((arity == 2) && (Pred(f)==LIST))
temp = (struct term *)
Nlist(Nvar(Anonymous_VarName,TEMPORAL),
Nvar(Anonymous_VarName,TEMPORAL),TEMPORAL);
else {
temp = Nterm(arity,TEMPORAL);
Pred(temp) = Predicate(Predname(f), arity);
for (i=0; i < arity; i++)
Arg(temp,i)=Nvar(Anonymous_VarName,TEMPORAL);
}
return(equalpred(t,e,temp,env));
}
int match_func(t,e,f,ef,a,ea)
struct term *t, *f, *a;
struct pair *e, *ef, *ea;
{
struct term *temp;
int arity, *hsave;
struct pair *esave;
struct ustack *usave;
hsave = hp;
esave = ep;
usave = usp;
arity = t->t_arity;
if (arity < 0) arity = -arity;
if (is_list(t))
temp =Nnum_val(2.0, TEMPORAL);
else temp = Nnum_val((float)arity,TEMPORAL);
if (tunify(a,ea,temp,NULL_ENV,0) == FALSE)
{
/* undo(usave); */ hp = hsave; ep = esave;
return(SYSFAIL);
}
temp = Nterm(0,TEMPORAL);
if (is_list(t))
Pred(temp)=LIST;
else Pred(temp) = Predicate(Predname(t), 0);
if (tunify(f,ef,temp,NULL_ENV,0) == FALSE) {
/* undo(usave); */ hp = hsave; ep = esave;
return(SYSFAIL);
}
return(SYSTRUE);
}
int clause_pred(t,e,n,status) /* clause(P,B,C) P:nonvar*/
struct term *t;
struct pair *e;
struct node *n;
int status;
{
register struct pair *ee, *p, *newenv;
register struct term *tt;
struct term *t_body, *t_con;
struct ustack *usave;
struct set *s;
int *hsave;
struct pair *esave;
ee = e;
tt = Arg(t,0); /* head */
down(p,tt,ee);
if (isvar(tt)) return(SYSFAIL);
if (status != BACKTRACK)
n->n_set = tt->type.t_func->def.f_set;
if (n->n_set == NULL) return(SYSFAIL);
usave = usp;
hsave = hp;
esave = ep;
for (s = n->n_set; s != NULL; s = s->s_link)
{
newenv = Nenv((int)s->s_anumber);
if (tunify(tt,ee,s->s_clause->c_form,newenv,0) == FALSE)
{
/* undo(usave); */ hp = hsave; ep = esave;continue;
}
t_body = tolist(s->s_clause->c_link,TEMPORAL);
tt = Arg(t,1);
ee = e;
down(p,tt,ee);
if (tunify(tt, ee, t_body, newenv,0)==FALSE)
{
/* undo(usave); */ hp = hsave; ep = esave;continue;
}
t_con = tolist(s->s_constraint,TEMPORAL);
tt = Arg(t,2);
ee = e;
down(p,tt,ee);
if (tunify(tt, ee, t_con, newenv,0) == FALSE)
{
/* undo(usave); */ hp = hsave; ep = esave;continue;
}
n->n_set = s->s_link; /* next goal */
return(SYSTRUE);
}
return(SYSFAIL);
}
syntax highlighted by Code2HTML, v. 0.9.1