void dpy_writechar(int x, int y, uni_t c)
{
unsigned int id = glyphcache_id(c, defaultattr);
sput(backbuffer, x, y, id);
if (emu_wcwidth(c) == 2)
sput(backbuffer, x+1, y, 0);
}
gen_code (struct pred_list *programme, struct put_fnct *put)
{
sprintf (buf, "/* C program translated from Prolog code */\n");
sput (put, buf);
sput (put, "#include \"coroutin.h\"\n");
sput (put, "#include \"expr.h\"\n");
/* sput (put, "#define MAX_NEW_CONS 50\n");
sput (put, "#define UNDEF 0x7FFD\n");*/
sput (put, "#include \"prolog.h\"\n");
for ( ; programme != NULL; programme = programme->next)
gen_pred (programme, put);
sprintf (buf, "\n/* End of translation */\n");
sput (put, buf);
}
term lambda_1 (term v, term x)
{
term f, a;
type tf;
if (v->k != TERM_VAR)
{
sput ("lambda: 1st arg not variable\n", err);
return UNDEF_TERM;
}
if (x->k == TERM_VAR && !strcmp (x->var.name, v->var.name) &&
equal_type (x->var.typ, v->var.typ))
return I (v->var.typ);
if (!occur (v, x))
return ap (K (type_term (x), v->var.typ), x);
f = x->ap.fnc;
a = x->ap.arg;
if (a->k == TERM_VAR && !strcmp (a->var.name, v->var.name) &&
equal_type (a->var.typ, v->var.typ) &&
!occur (v, f))
return f;
tf = type_term (f);
return ap (ap (S (v->var.typ, type_term (a), tf->fnc.res),
lambda (v, f)),
lambda (v, a));
}
type type_term (term x)
{
type t;
#ifdef TRACE
sput ("Type of ", err);
write_term (x, err);
sput ("...\n", err);
#endif
t = type_term_1 (x);
#ifdef TRACE
sput ("type of ", err);
write_term (x, err);
sput ("is ", err);
write_type (t, err);
sput (".\n", err);
#endif
return t;
}
write_type (type t, struct put_fnct *put)
{
switch (t->k)
{
case TYPE_ORD:
sput ("O", put);
break;
case TYPE_FNC:
if (t->fnc.arg->k == TYPE_FNC)
sput ("(", put);
write_type (t->fnc.arg, put);
if (t->fnc.arg->k == TYPE_FNC)
sput (")", put);
sput ("->", put);
write_type (t->fnc.res, put);
break;
default:
sput ("?", put);
}
}
void dpy_setcursor(int x, int y)
{
if (frontbuffer)
{
for (int xx=(cursorx-1); xx<=(cursorx+1); xx++)
for (int yy=(cursory-1); yy<=(cursory+1); yy++)
sput(frontbuffer, xx, yy, 0);
}
cursorx = x;
cursory = y;
}
gen_expr (plexpr x, struct put_fnct *put)
{
int i;
switch (x->type)
{
case PLTYPE_INT:
sprintf (buf, "%d", x->n);
sput (put, buf);
break;
case PLTYPE_STRING:
sprintf (buf, "%s", x->s);
sput (put, buf);
break;
case PLTYPE_VAR:
sprintf (buf, "var_%s", x->name);
sput (put, buf);
break;
case PLTYPE_SYMB:
sprintf (buf, "nx[pnx++] = cons (symbol(\"%s\"),\n", x->name);
sput (put, buf);
for (i=0; i<x->n; i++)
{
sput (put, "\t\t\tnx[pnx++] = cons (");
gen_expr (x->args[i], put);
sput (put, ",\n");
}
sput (put, "\t\t\t0"); /* nil */
for (i=0; i<x->n; i++)
sput (put, ")");
sput (put, ")");
break;
default:
sprintf (buf, "Error /* Invalid type %d */", x->type);
sput (put, buf);
}
}
type type_term_1 (term x)
{
switch (x->k)
{
case TERM_I: /* a->a */
return fnc (x->I.a, x->I.a);
case TERM_K: /* a->(b->a) */
return fnc (x->K.a, fnc (x->K.b, x->K.a));
case TERM_S: /* (a->b->c) -> (a->b) -> a -> c */
return fnc (fnc (x->S.a, fnc (x->S.b, x->S.c)),
fnc (fnc (x->S.a, x->S.b),
fnc (x->S.a, x->S.c)));
case TERM_Y:
return fnc (fnc (x->Y.a, x->Y.a), x->Y.a);
case TERM_ZERO:
return ORD;
case TERM_SUC:
return fnc (ORD, ORD);
case TERM_LIM:
return fnc (fnc (ORD, ORD), ORD);
case TERM_REP:
return fnc (ORD, fnc (fnc (x->rep.a, x->rep.a),
fnc (x->rep.a, x->rep.a)));
case TERM_AP:
{
type tf;
tf = type_term (x->ap.fnc);
if (tf->k != TYPE_FNC)
{
sput ("type_term: invalid function\n", err);
return UNDEF;
}
return tf->fnc.res;
}
case TERM_VAR:
return x->var.typ;
default:
return UNDEF;
}
}
term lambda (term v, term x)
{
term r;
#ifdef TRACE
sput ("Lambda ", err);
write_term (v, err);
sput (" . ", err);
write_term (x, err);
sput ("...\n", err);
#endif
r = lambda_1 (v, x);
#ifdef TRACE
sput ("lambda ", err);
write_term (v, err);
sput (" . ", err);
write_term (x, err);
sput (" = ", err);
write_term (r, err);
sput (".\n", err);
#endif
return r;
}
term ap (term fnc, term arg)
{
type tf, ta;
tf = type_term (fnc);
if (tf->k != TYPE_FNC)
sput ("ap: invalid function\n", err);
ta = type_term (arg);
if (!equal_type (ta, tf->fnc.arg))
{
sput ("ap: bad type\n\tfunction ", err);
write_term (fnc, err);
sput (" has type ", err);
write_type (tf, err);
sput ("\n\targument ", err);
write_term (arg, err);
sput (" has type ", err);
write_type (ta, err);
sput ("\n", err);
}
return ap1 (fnc, arg);
}
void dpy_cleararea(int x1, int y1, int x2, int y2)
{
for (int y=y1; y<=y2; y++)
for (int x=x1; x<=x2; x++)
sput(backbuffer, x, y, glyphcache_id(' ' , defaultattr));
}
gen_pred (struct pred_list *pred, struct put_fnct *put)
{
int i;
struct clause_list *clause;
sprintf (buf, "pl_%s_%d (struct coroutine *k",
pred->name, pred->n_args);
sput (put, buf);
for (i=0; i<pred->n_args; i++)
{
sprintf (buf, ", expr a%d", i);
sput (put, buf);
}
sput (put, ")\n{\nexpr nx[MAX_NEW_CONS];\n");
sput (put, "int pnx, i;\nstruct process_list *alt_process;\n");
sput (put, "\tpnx = 0;\n\tbegin_decl ();\n");
for (i=0; i<pred->n_args; i++)
{
sprintf (buf, "\tdecl_expr (&a%d);\n", i);
sput (put, buf);
}
/*
sput (put, "\tfor (i=0; i<MAX_NEW_CONS; i++)\n\t{\n");
sput (put, "\t\tnx[i] = 0;\n");
sput (put, "\t\tdle (nx[i]);\n\t}\n");
*/
sput (put, "\tfor (i=0; i<MAX_NEW_CONS; i++)\n");
sput (put, "\t\tdle (nx[i]);\n");
sput (put, "#ifdef TRACE\n");
for (i=0; i<pred->n_args; i++)
{
sprintf (buf, "\tprintf (\"\\n%s: a%d = \"); print_expr (a%d);\n",
pred->name, i, i);
sput (put, buf);
}
sput (put, "#endif\n");
for (clause = pred->clauses;
clause != NULL;
clause = clause->next)
{
sput (put, "\tif (alt (k, 1, 0))\n\t{\n");
/* sput (put, "\talt_process = getpl() -> alt;\n\t{"); */
gen_clause (clause, pred->n_args, put);
/* sput (put, "\t}\n\t} else\n"); */
sput (put, "\t} else\n");
}
sput (put, "\tend (k);\n\tfree_expr ();\n}\n");
}
void p_f_iles(void)
{
print_at(2,2);
printf("3. DEMO: Filehandling\n");
print_at(2,4);
printf(" Fileselectorbox, Alertbox, Auslesen eines Files, RELSEEK, SEEK, LOF, LOC ..\n");
bild_char = sget(bild_char);
chdrive(1);
msprintf(a_char,"*.LST");
msprintf(b_char,"A:\\GFA_TEST\\");
chdir( b_char);
fileselect(mstrcat( b_char,a_char),a_char,c_char);
sput( bild_char);
if(strcmp(c_char,""))
{
if((FP[1] = fopen(c_char,"r")) == NULL)
{
printf("\nFehler beim �ffnen der Datei !");
getchar();
r_aus(-1);
}
c_long=lof(FP[1]);
msprintf(c_char,"%s",mid(c_char,rinstr(c_char,"\\")+1,-1));
print_at(5,6);
printf("L�nge der Datei %c%s%c%s: %ld\n",*chr(34),c_char,*chr(34),space(15-strlen(c_char)),c_long);
relseek(FP[1],10);
print_at(5,7);
printf("Suche Position : %ld\n",loc(FP[1]));
relseek(FP[1],10);
print_at(5,8);
printf("Erh�he den Filepointer um 10 Byte: %ld\n",loc(FP[1]));
seek(FP[1],10);
print_at(5,9);
printf("Stelle den Pointer auf Position : %ld\n",loc(FP[1]));
print_at(5,11);
printf("Auslesen und Anzeigen der Datei >>%s<< (Stop/Abbruch: Taste)\n",c_char);
p_s_top();
printf("\33E");
do
{
printf("%c", *chr(fgetc(FP[1])));
if(strcmp(inkey(),""))
{
a_lert( 2,"Abbruch",2,"JA|NEIN",back_long);
if(back_long==1)
{
goto raus;
}
}
if(feof(FP[1]))
goto M2;
}
while(1);
M2:
raus:
print_at(5,25);
printf("Ausgelesen bis Position: %ld%s\n",loc(FP[1]),space(54-strlen(ltoab(loc(FP[1]),-1,-1))));
fclose(FP[1]);
}
else
{
print_at(5,6);
printf("Sie haben keine Datei ausgew�hlt!\n");
}
p_s_top();
printf("\33E");
}
main ()
{
term x, n;
type t;
term plus_omega, omega_2, plus_omega_2, plus_omega_n, omega_n, omega_omega,
plus_omega_omega;
term f, p;
param_out.fd = stdout;
param_err.fd = stderr;
init ();
/* Exemple : construction de l'ordinal omega * 2 */
x = ap (LIM, ap (ap (S(ORD,ORD,ORD),
ap (ap (S(ORD,fnc(ORD,ORD),fnc(ORD,ORD)),rep(ORD)),
ap(K(fnc(ORD,ORD),ORD),SUC))),
ap(K(ORD,ORD),ap(LIM,I(ORD)))));
sput ("x = ", out);
write_term (x, out);
t = type_term (x);
sput ("\nt = ", out);
write_type (t, out);
sput ("\n", out);
n = var ("n", ORD);
/*
x = ap (LIM, lambda (n,
ap (ap (ap (rep(ORD), n), SUC), ap (LIM, I(ORD)))
));
*/
x = ap (ap (ap (rep(ORD), n), SUC), ap (LIM, I(ORD)));
/* x = ap (rep(ORD), n); */
sput ("x = ", out);
write_term (x, out);
t = type_term (x);
sput ("\nt = ", out);
write_type (t, out);
sput ("\n", out);
x = lambda (n, x);
sput ("x = ", out);
write_term (x, out);
t = type_term (x);
sput ("\nt = ", out);
write_type (t, out);
sput ("\n", out);
x = ap (LIM, x);
sput ("x = ", out);
write_term (x, out);
t = type_term (x);
sput ("\nt = ", out);
write_type (t, out);
sput ("\n", out);
x = var ("x", ORD);
plus_omega = lambda (x, lim (lambda (n,
rpt (ORD, n, SUC, x)
)));
omega_2 = lim (lambda (n, rpt (ORD, n, plus_omega, ZERO)));
t = type_term (omega_2);
sput ("Type of omega_2 = ", out);
write_type (t, out);
sput ("\n", out);
plus_omega_2 = lambda (x, lim (lambda (n,
rpt (ORD, n, plus_omega, x))));
t = type_term (plus_omega_2);
sput ("Type of plus_omega_2 is ", out);
write_type (t, out);
f = var ("f", fnc(ORD,ORD));
p = var ("p", ORD);
plus_omega_n = lambda (n, rpt (fnc(ORD,ORD), n, lambda (f,
lambda (x, lim (lambda (p, rpt (ORD, p, f, x)))) ),
SUC));
/*
next_power = lambda (f,
lambda (x, lim (lambda (p, rpt (ORD, p, f, x)))));
plus_omega_n = lambda (n, rpt (fnc(ORD,ORD), n,
*/
t = type_term (plus_omega_n);
sput ("\nType of plus_omega_n is ", out);
write_type (t, out);
omega_n = lambda (n, ap (ap (plus_omega_n, n), ZERO));
t = type_term (omega_n);
sput ("\nType of omega_n is ", out);
write_type (t, out);
omega_omega = lim (omega_n);
t = type_term (omega_omega);
sput ("\nType of omega_omega is ", out);
write_type (t, out);
plus_omega_omega = lambda (x, lim (lambda (n,
ap (ap (plus_omega_n, n), x) )));
t = type_term (plus_omega_omega);
sput ("\nType of plus_omega_omega is ", out);
write_type (t, out);
sput ("\n", out);
}
void p_grafik(void)
{
deftext( 1,24,0,32);
text( 174,200,-1,"4. DEMO: GRAFIK");
p_s_top();
printf("\33E");
deftext( -1,1,0,13);
for(h_long=1;h_long<=2;h_long++)
{
for(j_long=4;j_long<=24 ;j_long+= 4)
{
for(i_long=0;i_long<=5;i_long++)
{
deftext( -1,pow(2,i_long),-1,-1);
text( 320,50+i_long*(16+j_long*2),-1,"B_NACH_C");
}
pause( 10);
printf("\33E");
deftext( -1,-1,-1,j_long);
}
deftext( -1,-1,h_long*1800,-1);
}
deftext( -1,1,-1,13);
for(h_long=1;h_long<=4;h_long++)
{
for(i_long=2;i_long<=3;i_long++)
{
for(j_long=0;j_long<=2;j_long++)
{
defline( h_long,i_long,j_long,j_long);
draw(100+50*j_long,50+25*j_long , 539-50*j_long,50+25*j_long);
box( 50+50*j_long,150,320-50*j_long,350);
circle( 480,250,20+40*j_long);
}
pause( 10);
printf("\33E");
}
}
defline( 1,2,1,1);
deffill( 1,1,1);
for(i_long=2;i_long<=3;i_long++)
{
for(j_long=1;j_long<=20;j_long++)
{
deffill( 1,i_long,j_long);
pbox( 16*j_long-16,10,655-16*j_long,190);
pcircle( 160,299,105-5*j_long);
pellipse( 480,299,5*j_long,105-5*j_long);
}
if(j_long>20 & i_long==2)
{
bild_char = sget(bild_char);
}
}
pause( 50);
s_adr_long=(long)(bild_char);
d_adr_long=xbios(2);
for(i_long=1;i_long<=1000;i_long++)
{
rc_copy(s_adr_long,(int)((double)rand()*(10)/32767)*64,(int)((double)rand()*(10)/32767)*40,64,40 ,d_adr_long,(int)((double)rand()*(10)/32767)*64,(int)((double)rand()*(10)/32767)*40,
-1);
}
pause( 100);
printf("\33E");
sput( bild_char);
deffill( 1,1,1);
write_term (term x, struct put_fnct *put)
{
switch (x->k)
{
case TERM_I:
sput (" I [", put);
write_type (x->I.a, put);
sput ("] ", put);
break;
case TERM_K:
sput (" K [", put);
write_type (x->K.a, put);
sput (", ", put);
write_type (x->K.b, put);
sput ("] ", put);
break;
case TERM_S:
sput (" S [", put);
write_type (x->S.a, put);
sput (", ", put);
write_type (x->S.b, put);
sput (", ", put);
write_type (x->S.c, put);
sput ("] ", put);
break;
case TERM_Y:
sput (" Y [", put);
write_type (x->Y.a, put);
sput ("] ", put);
break;
case TERM_ZERO:
sput (" 0 ", put);
break;
case TERM_SUC:
sput (" suc ", put);
break;
case TERM_LIM:
sput (" lim ", put);
break;
case TERM_REP:
sput (" rep [", put);
write_type (x->rep.a, put);
sput ("] ", put);
break;
case TERM_AP:
sput ("-", put);
write_term (x->ap.fnc, put);
write_term (x->ap.arg, put);
break;
case TERM_VAR:
sput (" <", put);
sput (x->var.name, put);
sput (":", put);
write_type (x->var.typ, put);
sput ("> ", put);
break;
case TERM_UNDEF:
sput (" U ", put);
break;
default:
sput ("?", put);
}
}
gen_clause (struct clause_list *clause, int n_args, struct put_fnct *put)
{
struct expr_list *l, *vars, *var;
int i;
sput (put, "\t/* clause */\n");
vars = NULL;
for (i=0; i<n_args; i++)
vars = aj_vars (vars, clause->args[i]);
for (l=clause->corps; l!=NULL; l=l->next)
vars = aj_vars (vars, l->first);
for (var=vars; var!=NULL; var=var->next)
{
sprintf (buf, "\texpr val_%s, var_%s;\n",
var->first->name, var->first->name);
sput (put, buf);
}
sput (put, "\t\talt_process = getpl (k) -> alt;\n");
for (var=vars; var!=NULL; var=var->next)
{
sprintf (buf, "\t\tdle(val_%s) dle(var_%s)\n",
var->first->name, var->first->name);
sput (put, buf);
}
for (var=vars; var!=NULL; var=var->next)
{
sprintf (buf, "\t\tval_%s=UNDEF; var_%s=mk_var(&val_%s);\n",
var->first->name, var->first->name,
var->first->name);
sput (put, buf);
}
sput (put, "#ifdef TRACE\n");
for (i=0; i<n_args; i++)
{
sprintf (buf, "\t\tprintf (\"\\n\\ta%d = \"); print_expr (a%d);\n",
i, i);
sput (put, buf);
}
sput (put, "#endif\n");
for (i=0; i<n_args; i++)
{
sput (put, "\t\tunify (k, ");
gen_expr (clause->args[i], put);
sprintf (buf, ", a%d);\n", i);
sput (put, buf);
sput (put, RESET_NX);
}
for (l=clause->corps; l!=NULL; l=l->next)
{
if (!strcmp (l->first->name, "c_code"))
{
sput (put, "\t/* C code inclusion */\n\t");
sput (put, l->first->args[0]->s);
sput (put, "\n\t/* End of C code inclusion */\n");
}
else
{
sprintf (buf, "\t\tpl_%s_%d (k",
l->first->name, l->first->n);
sput (put, buf);
for (i=0; i<l->first->n; i++)
{
sput (put, ", ");
gen_expr (l->first->args[i], put);
}
sput (put, ");\n");
sput (put, RESET_NX);
}
}
for (i=0; i<n_args; i++)
{
sprintf (buf, "\t\tunify (k, a%d, ", i);
sput (put, buf);
gen_expr (clause->args[i], put);
sput (put, ");\n");
sput (put, RESET_NX);
}
sput (put, "#ifdef TRACE\n");
for (i=0; i<n_args; i++)
{
sprintf (buf, "\t\tprintf (\"\\n\\ta%d = \"); print_expr (a%d);\n",
i, i);
sput (put, buf);
}
sput (put, "#endif\n");
}
