/* ---------------------------------------------------------- % (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 #else #if CPUTIME != 0 #include #include #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); }