/* ----------------------------------------------------------
%   (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);
}