/* ----------------------------------------------------------
% (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
==================================================================== */
/*--------------------------------------------------------------------
* << syspred2.c >>
* (system predicates No.2 : string, number)
* 1994.9.27 atom_to_str
--------------------------------------------------------------------*/
#include "include.h"
int kstrlen(),kpoint();
/* for LtoC(), CtoL() pred */
#define FROM_NAME 1
#define FROM_CONC 0
int sum_pred(t,e)
struct term *t;
struct pair *e;
{
return(calc_pred(t,e,'+'));
}
int multiply_pred(t,e)
struct term *t;
struct pair *e;
{
return(calc_pred(t,e,'*'));
}
int calc_pred(t,e,op)
struct term *t;
struct pair *e;
char op;
{
register struct term *x, *y, *z;
register struct pair *e0, *e1, *e2, *p;
e0 = e1 = e2 = e;
x = Arg(t,0); y = Arg(t,1); z = Arg(t,2);
down(p,x,e0); down(p,y,e1); down(p,z,e2);
if(isvar(x)) return(calc_2(y,z,x,e0,op));
if(isvar(y)) return(calc_2(x,z,y,e1,op));
else return(calc_1(x,y,z,e2,op));
}
int calc_1(x,y,z,e,op)
struct term *x,*y,*z;
struct pair *e;
char op;
{
struct term *result;
register float sum;
/* if (isvar(x) || isvar(y)) return(SYSFAIL); */
if (! (is_num(x))) {
sprintf(nbuf,"%s/3: Illegal argument as 1st argument",
((op == '+') ? "sum" : "multiply") );
error_detail(x,NULL_ENV,nbuf);
}
if (! (is_num(y))) {
sprintf(nbuf,"%s/3: Illegal argument as 2nd argument",
((op == '+') ? "sum" : "multiply") );
error_detail(y,NULL_ENV,nbuf);
}
if (op=='+') sum = num_value(x) + num_value(y);
else if (op=='*') sum = num_value(x) * num_value(y);
else error("system error! at calc_pred");
result = Nnum_val(sum,TEMPORAL);
return(equalpred(z,e,result,NULL_ENV));
}
int calc_2(x,z,y,e,op)
struct term *x,*y,*z;
struct pair *e;
char op;
{
struct term *result;
register float temp;
if (isvar(x) || isvar(z)) return(SYSFAIL);
if (! (is_num(x))) {
sprintf(nbuf,"%s/3: Illegal argument as 1st argument",
((op == '+') ? "sum" : "multiply") );
error_detail(x,NULL_ENV,nbuf);
}
if (! (is_num(z))) {
sprintf(nbuf,"%s/3: Illegal argument as 2nd argument",
((op == '+') ? "sum" : "multiply") );
error_detail(z,NULL_ENV,nbuf);
}
temp = num_value(x);
if ((op=='*') && (temp==0.0)) error("multiply/3: zero division");
if (op=='+') temp = num_value(z) - temp;
else if (op=='*') temp = num_value(z)/temp;
result = Nnum_val(temp,TEMPORAL);
return(equalpred(y,e,result,NULL_ENV));
}
int greater_pred(t,e)
struct term *t;
struct pair *e;
{
return(numcomp_pred(t,e,0));
}
int less_pred(t,e)
struct term *t;
struct pair *e;
{
return(numcomp_pred(t,e,1));
}
int geq_pred(t,e)
struct term *t;
struct pair *e;
{
return(numcomp_pred(t,e,2));
}
int leq_pred(t,e)
struct term *t;
struct pair *e;
{
return(numcomp_pred(t,e,3));
}
static char* compare_predicates[] = {
"greater", "less", "geq", "leq" };
int numcomp_pred(t,e,op)
struct term *t;
struct pair *e;
int op;
{
register struct term *x, *y;
register struct pair *e0, *e1, *p;
int g, l;
e0 = e1 = e;
x = Arg(t,0); y = Arg(t,1);
down(p,x,e0); down(p,y,e1);
if(isvar(x) || (p != NULL))
return(SYSFAIL);
if (! (is_num(x))) {
sprintf(nbuf,"%s/2: Illegal argument as 1st Arg",
compare_predicates[op]);
error_detail(x,e0,nbuf);
}
if (! (is_num(y))) {
sprintf(nbuf,"%s/2: Illegal argument as 2nd Arg",
compare_predicates[op]);
error_detail(y,e1,nbuf);
}
g = (num_value(x) > num_value(y)) ? SYSTRUE : SYSFAIL;
l = (num_value(x) < num_value(y)) ? SYSTRUE : SYSFAIL;
switch (op) {
case 0: return(g);
case 1: return(l);
case 2: return((l==SYSFAIL) ? SYSTRUE : SYSFAIL);
case 3: return((g==SYSFAIL) ? SYSTRUE : SYSFAIL);
}
}
/* concat("ab","cde",X) -> X = "abcde" */
int concat_pred(t,e,n,status)
struct term *t;
struct pair *e;
struct node *n;
int status;
{
register struct term *x, *y, *z;
register struct pair *px, *py, *p;
struct pair *ex, *ey, *ez;
int len;
char *buf;
x = Arg(t,0);
y = Arg(t,1);
z = Arg(t,2);
ex = ey = ez = e;
down(px,x,ex); down(py,y,ey); down(p,z,ez);
if (isvar(x) && isvar(y)) {
if (status ==BACKTRACK) { /* X,Y are Vars, and Z is CONST */
if ((len = (int)n->n_set-1) < 0) return(SYSFAIL);
/* copy status chars from z to nbuf */
len = kpoint(str_value(z),len);
strncpy(nbuf,str_value(z),len);
nbuf[len] = '\0'; /* due to BUG of SUN4 */
upush(&(px->p_body));
upush(&(px->p_env));
px->p_body = Nstr(nbuf,TEMPORAL);
px->p_env = NULL_ENV;
buf = str_value(z);
upush(&(py->p_body));
upush(&(py->p_env));
buf += len;
py->p_body = Nstr(buf,TEMPORAL);
py->p_env = NULL_ENV;
n->n_set = (struct set *)( (int)n->n_set - 1);
return(SYSTRUE);
}
else {
if (isvar(z)) return(SYSFAIL);
if (! is_string(z)) {
error_detail(z,ez,"concat/2: Illegal 3rd argument");
}
len = kstrlen(str_value(z));
upush(&(px->p_body));
upush(&(px->p_env));
px->p_body = z;
px->p_env = ez;
nbuf[0] = '\0';
upush(&(py->p_body));
upush(&(py->p_env));
py->p_body = Nstr(nbuf,TEMPORAL);
py->p_env = NULL_ENV;
n->n_set = (struct set *)len; /* memorize the position */
return(SYSTRUE);
}
}
if(isvar(x)) return(diff_str(y,z,x,ex,0));
if(isvar(y)) return(diff_str(x,z,y,ey,1));
else return(app_str(x,y,z,ez));
}
int app_str(x,y,z,ez)
struct term *x, *y, *z;
struct pair *ez;
{
struct term *result;
if (! (is_string(x) && is_string(y))) error("concat/3: illegal term");
if ((strlen(str_value(x))+strlen(str_value(y))) > NAMELEN_MAX)
error("concat/3: too long string");
strcpy(nbuf,str_value(x));
strcat(nbuf,str_value(y));
result = Nstr(nbuf,TEMPORAL);
return(equalpred(z,ez,result,NULL_ENV));
}
int diff_str(x,z,y,e,first)
struct term *x, *y, *z;
struct pair *e;
int first; /* assuming 0/last_half, 1/first_half is designated */
{
struct term *result;
int lx, lz, dif;
char *cx, *cz;
if (isvar(z)) return(SYSFAIL);
if (! (is_string(z)) && (isvar(x) || is_string(x)))
error("concat/3: illegal term");
cx = str_value(x); cz = str_value(z);
if ((lz = strlen(cz)) < (lx = strlen(cx)))
error("concat/3: not appropriate args");
if (first) /* find last half */
{
register int pos;
for (pos = 0; pos < lx; pos++)
if (cx[pos] != cz[pos]) return(SYSFAIL);
cz += pos;
result = Nstr(cz,TEMPORAL);
}
else /* find first half */
{
register int pos;
dif = lz - lx;
for (pos = dif; pos < lz; pos++)
if (cx[pos-dif] != cz[pos]) return(SYSFAIL);
/* strcpy(nbuf, cz, dif); this mus be bag. */
strncpy(nbuf, cz, dif);
nbuf[dif] = '\0';
result = Nstr(nbuf,TEMPORAL);
}
return(equalpred(y,e,result,NULL_ENV));
}
/* concat2("abcde",X) -> X = ["a","b","c","d","e"] */
int concat2_pred(t,e)
struct term *t;
struct pair *e;
{
struct term *x, *y;
struct pair *ex, *ey, *p;
struct term *tt;
x = Arg(t,0);
y = Arg(t,1);
ex = ey = e;
down(p,x,ex); down(p,y,ey);
*nbuf = '\0';
if (isvar(x)) {
if (isvar(y)) return(SYSFAIL);
LtoC(y,ey,0,FROM_CONC);
tt = Nstr(nbuf, TEMPORAL);
return(equalpred(x,ex,tt,NULL_ENV));
}
if (is_num(x)) {
sprintf(nbuf, "%d",(int)num_value(x));
tt = CtoL(nbuf, FROM_CONC);
}
else if (is_string(x)) tt = CtoL(str_value(x), FROM_CONC);
else tt = CtoL(x->type.t_func->f_name, FROM_CONC);
return(equalpred(y,ey,tt,NULL_ENV));
}
int strlen_pred(t,e)
struct term *t;
struct pair *e;
{
struct term *s, *l;
struct pair *es, *el, *p;
int len;
s = Arg(t,0);
l = Arg(t,1);
es = el = e;
down(p,l,el);
down(p,s,es);
if (p != NULL) return(SYSFAIL);
if (! is_string(s)) {
error_detail(t,e,"strlen/1: 1st arg is not string");
}
if (! (isvar(l) || is_num(l))) {
error_detail(t,e,"strlen/2: 2nd arg is neither Var nor Number");
}
len = kstrlen(str_value(s));
t = Nnum_val((float)len,TEMPORAL);
return(equalpred(l,el,t,NULL_ENV));
}
/* substring("abcde",2,X) -> X = "cde"
substring("abcde",-3,2,X) -> X = "cd" */
int substr_pred(t,e)
struct term *t;
struct pair *e;
{
static char *emsg = "substring/%d: %s arg is not %s";
struct term *s, *tmp;
register struct pair *p, *ee;
int arity,start,numb,len;
char *sr;
arity = t->t_arity;
if (arity < 0) arity = -arity;
s = Arg1(t);
ee = e;
down(p,s,ee);
if (! is_string(s)) {
sprintf(nbuf,emsg,arity, "1st", "string");
error_detail(t,e,nbuf);
}
tmp = Arg2(t);
ee = e;
down(p,tmp,ee);
if (! is_int(tmp)) {
sprintf(nbuf,emsg, arity, "2nd","integer");
error_detail(t,e,nbuf);
}
start = num_value(tmp);
len = kstrlen(str_value(s));
if (start < 0) start += len;
if (arity == 4) {
tmp = Arg3(t);
ee = e;
down(p,tmp,ee);
if (! is_int(tmp)) {
sprintf(nbuf,emsg,4,"3rd","integer");
error_detail(t,e,nbuf);
}
numb = num_value(tmp);
if (numb < 0) numb+=len;
}
else { /* arity == 3 */
numb = len-start;
}
if ( (start > len) || (numb > len) || (start < 0)) {
sprintf(nbuf,"substring/%d: Illegal argument value",arity);
error_detail(t,e,nbuf);
}
sr = str_value(s);
sr += kpoint(sr,start);
numb = kpoint(sr,numb);
strncpy(nbuf,sr,numb);
nbuf[numb] = '\0';
tmp = Nstr(nbuf,TEMPORAL);
return(equalpred(Arg(t,arity-1),e,tmp,NULL_ENV));
}
/* divstr("abcd",2,X,Y) -> X = "ab", Y = "cd" */
/* divstr(+,+,?,?) or divstr(+,-,+,?) */
int divstr_pred(t,e)
struct term *t;
struct pair *e;
{
static char *emesg = "divstr*/4: %s is not %s";
register struct pair *p, *ee, *e1;
struct term *str, *temp, *first;
int n,len, firsthalf();
char *sr, *sf, *divkstr();
str = Arg1(t);
ee = e; down(p,str,ee);
if (! is_string(str)) {
sprintf(nbuf,emesg,"1st","string");
error_detail(t,e,nbuf);
}
sr = str_value(str);
len = kstrlen(sr);
temp = Arg2(t);
ee = e; down(p,temp,ee);
if (p != NULL) { /* 2nd arg is var */
e1 = e;
first = Arg3(t);
down (p,first,e1);
if (! is_string(first)) {
sprintf(nbuf,emesg,"2nd","integer and 3rd arg is var");
error_detail(t,e,nbuf);
}
sf = str_value(first);
n = kstrlen(sf);
if ((n <= len) && (firsthalf(sf,sr)==TRUE) &&
(equalpred(temp,ee,Nnum_val((float)n,TEMPORAL),NULL_ENV)
== SYSTRUE)){
sr += strlen(sf);
return(equalpred(Arg(t,3),e,Nstr(sr,TEMPORAL),NULL_ENV));
}
return(SYSFAIL);
}
else if (! is_int(temp)) {
sprintf(nbuf,emesg,"2nd","integer");
error_detail(t,e,nbuf);
}
n = num_value(temp); /* 2nd arg is num */
if (n < 0) n += len;
if ((n > len) || (n < 0)) {
sprintf(nbuf,emesg,"2nd","appropriate");
error_detail(t,e,nbuf);
}
n = kpoint(sr,n); /* n:kanji point -> n:char point */
strncpy(nbuf,sr,n);
nbuf[n]='\0';
temp = Nstr(nbuf,TEMPORAL);
if (equalpred(Arg(t,2),e,temp,NULL_ENV) == SYSFAIL)
return(SYSFAIL);
temp = Nstr(sr+n,TEMPORAL);
return(equalpred(Arg(t,3),e,temp,NULL_ENV));
}
int firsthalf(h,w)
char h[], w[];
{
register int i;
for (i = 0; h[i] == w[i]; i++);
if (h[i] == '\0') return(TRUE);
else return(FALSE);
}
/* strcmp("ab","abc", X) -> X = '<' */
/* strcmp(+,+,-) */
int strcmp_pred(t,e)
struct term *t;
struct pair *e;
{
static char *emesg = "strcmp*/3: %s is not string";
register struct pair *p, *ee;
struct term *a, *b;
int result;
a = Arg(t,0); b = Arg(t,1);
ee = e; down(p,a,ee);
if (! is_string(a)) {
sprintf(nbuf,emesg,"1st");
error_detail(t,e,nbuf);
}
ee = e; down(p,b,ee);
if (! is_string(b)) {
sprintf(nbuf,emesg,"2nd");
error_detail(t,e,nbuf);
}
result = strcmp(str_value(a),str_value(b));
if (result < 0)
return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV));
else if (result == 0)
return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV));
else /* result > 0 */
return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV));
}
int compare_pred(t,e)
struct term *t;
struct pair *e;
{
register struct pair *p, *ee;
struct term *a, *b;
float j;
int i;
ee = e;
a = Arg(t,0);
down(p,a,ee);
ee = e;
b = Arg(t,1);
down(p,b,ee);
if (is_num(a) && is_num(b)) {
j = num_value(a) - num_value(b);
if (j > 0.0)
return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV));
else if (j == 0.0)
return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV));
return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV));
}
if (is_string(a) && is_string(b)) {
i = strcmp(str_value(a),str_value(b));
if (i > 0)
return(equalpred(Arg(t,2),e,S_GREATER,NULL_ENV));
else if (i == 0)
return(equalpred(Arg(t,2),e,S_EQ,NULL_ENV));
return(equalpred(Arg(t,2),e,S_LESS,NULL_ENV));
}
error_detail(t,e,"compare*/3: Args are mismatched");
}
int atom_to_str_pred(t,e)
struct term *t;
struct pair *e;
{
struct term *t1,*ns;
struct pair *e1,*p1;
t1=Arg1(t);
e1 = e;
down(p1,t1,e1);
if (p1 == NULL_ENV) /* arg1: bound */
{
if (isconst_functor(t1))
{
ns = Nstr(Predname(t1),ETERNAL);
if (tunify(Arg2(t),e,ns,NULL_ENV,0)==TRUE)
return(SYSTRUE);
}
return(SYSFAIL);
}
else error_detail(t,e,"atom_to_pred: 1st arg is free.");
}
/* count() predicate :
count(X) -> X = 0,1,2,...
count(3) -> set COUNTNUMBER in 3
*/
long COUNTNUMBER = 0; /* used for count(gensym) predicate */
int count_pred(t,e)
struct term *t;
struct pair *e;
{
register struct pair *p;
struct term *result;
t = Arg(t,0);
down(p,t,e);
if (p != NULL) {
result = Nnum_val((float)COUNTNUMBER,TEMPORAL);
COUNTNUMBER++;
return(equalpred(t,e,result,NULL_ENV));
}
if (is_int(t)) {
COUNTNUMBER=(long)num_value(t);
return(SYSTRUE);
}
error_detail(t,e,"count/1: illegal argument.");
}
int gensym_pred(t,e)
struct term *t;
struct pair *e;
{
register struct term *tt;
register struct pair *p, *ee;
struct term *result;
char newname[8];
if (t->t_arity == 2) {
tt = Arg(t,0);
ee = e;
down(p,tt,ee);
if (is_functor(tt))
strncpy(newname, tt->type.t_func->f_name,8);
else if (is_string(tt))
strncpy(newname, str_value(tt), 8);
else error_detail(t,e,"gensym/2: 1st Argument should be atom");
tt = Arg(t,1);
ee = e;
}
else { /* gensym/1 */
tt = Arg(t,0);
ee = e;
strcpy(newname,genname);
}
down(p,tt,ee);
if (p != NULL) {
/* new function name is generated in nbuf[] */
while (1) {
sprintf(nbuf,"%s%d", newname, GENSYM++);
if (exist_fname(nbuf) == NULL) break;
}
result = Nterm(0,TEMPORAL);
result->type.t_func = Predicate(nbuf,0);
return(equalpred(tt,ee,result,NULL_ENV));
}
else error_detail(t,e,"gensym/1:Argument should be Variable");
}
int kstrlen(str)
char *str;
{
register unsigned char *c;
register float n;
#if KANJI != 1
return(strlen(str));
#else
for (c=(unsigned char *)str,n=0; *c != '\0'; c++)
{
if (*c > EUCOS) n+=0.5;
else n++;
}
return( (int)n );
#endif
}
int kpoint(s,n) /* return the point after nth Kanji char */
unsigned char *s;
int n;
{
register unsigned char *c;
register int i;
register float l;
#if KANJI != 1
return(n);
#else
for (c=s,l=i=0; *c != '\0'; c++,i++)
{
if (l == (float) n) break;
if (*c > EUCOS) l+=0.5;
else l++;
}
return(i);
#endif
}
syntax highlighted by Code2HTML, v. 0.9.1