term* normalize_fuel_elim(context *Sigma, typing_context* Delta, term* t, int fuel) { term* ans = NULL; term* last = normalize_fuel(Sigma, Delta, t->args[t->num_args - 1], fuel-1); if (!last) goto error; if (last->tag == INTRO) { term* c = term_dup(t); free_term(c->args[c->num_args - 1]); c->args[c->num_args - 1] = last; return normalize_and_free_fuel(Sigma, Delta, elim_over_intro(Delta, c), fuel-1); } else { ans = make_elim(variable_dup(t->var), t->num_args, t->num_params, t->num_indices); int i; for (i = 0; i < t->num_indices; i++) { ans->indices[i] = normalize_fuel(Sigma, Delta, t->indices[i], fuel-1); if (!ans->indices[i]) goto error; } for (i = 0; i < t->num_params; i++) { ans->params[i] = normalize_fuel(Sigma, Delta, t->params[i], fuel-1); if (!ans->params[i]) goto error; } for (i = 0; i < t->num_args - 1; i++) { ans->args[i] = normalize_fuel(Sigma, Delta, t->args[i], fuel-1); if (!ans->args[i]) goto error; } ans->args[t->num_args-1] = last; return ans; } error: free_term(last); free_term(ans); return NULL; }
static term* elim_over_intro(typing_context* Delta, term* t) { check(t && t->args && t->args[t->num_args - 1], "ill formed term"); check(t->tag == ELIM && t->args[t->num_args - 1]->tag == INTRO, "elim_over_intro must be called on an eliminator applied to a constructor"); term* last = t->args[t->num_args - 1]; datatype* T = elim_to_datatype(t->var, Delta); int index = datatype_intro_index(last->var, T); check(index != -1, "bad intro index while evaluating %W", t, print_term); term *app = term_dup(t->args[index + 1]); int i; for (i = 0; i < last->num_args; i++) { app = make_app(app, term_dup(last->args[i])); if (constructor_arg_is_inductive(T, last->var, i)) { term *inductive = term_dup(t); free_term(inductive->args[inductive->num_args - 1]); inductive->args[inductive->num_args - 1] = term_dup(last->args[i]); app = make_app(app, inductive); } } free_term(t); t = NULL; return app; error: return NULL; }
term* normalize_no_unfold(typing_context* Delta, term* t) { if (t == NULL) return NULL; switch (t->tag) { case VAR: { return term_dup(t); } case APP: { term* l = normalize_no_unfold(Delta, t->left); term* r = normalize_no_unfold(Delta, t->right); if (l->tag == LAM) { term* subs = substitute(l->var, r, l->right); free_term(l); free_term(r); return normalize_no_unfold_and_free(Delta, subs); } return make_app(l, r); } case IMPLICIT: case HOLE: case TYPE: case LAM: case PI: return term_dup(t); default: sentinel("unexpected tag %d"); } error: return NULL; }
void free_term(term* t) { if (t == NULL) return; free_variable(t->var); t->var = NULL; free_term(t->left); t->left = NULL; free_term(t->right); t->right = NULL; #define FREE_VEC(n, a) do { \ int __i; \ for (__i = 0; __i < n; __i++) { \ free_term(a[__i]); \ a[__i] = NULL; \ } \ free(a); \ a = NULL; \ } while (0) FREE_VEC(t->num_args, t->args); FREE_VEC(t->num_params, t->params); FREE_VEC(t->num_indices, t->indices); free(t); }
void add_stuff(term *t, environment *env) { if(t->kind == DEF){ add_environment(env, t); } if(t->kind == IND){ term **constructors = t->cases; t->cases = 0; int n = t->n; add_environment(env, t); int i; for (i = 0; i < n; ++i) { term *cons = constructors[i]; evaluate_term(cons, env); add_environment(env, cons); } term *elim = make_eliminator(t, constructors, n); elim->annotation = type_infer(elim, 0, 0); printf("Automatically adding %s: ", elim->name); print_term(elim->annotation); printf("\n"); add_environment(env, elim); for (i = 0; i < n; ++i) { free_term(constructors[i]); } free(constructors); free_term(elim); } }
int definitionally_equal(context *Sigma, typing_context* Delta, term* a, term* b) { term* na = normalize(Sigma, Delta, a); term* nb = normalize(Sigma, Delta, b); int ans = syntactically_identical(na, nb); free_term(na); free_term(nb); return ans; }
term* normalize_fuel_pi(context *Sigma, typing_context* Delta, term* t, int fuel) { term* B = NULL; term* A = normalize_fuel(Sigma, Delta, t->left, fuel-1); if (!A) goto error; context* extend = context_add(variable_dup(t->var), NULL, Sigma); B = normalize_fuel(extend, Delta, t->right, fuel-1); context_pop(extend); if (!B) goto error; return make_pi(variable_dup(t->var), A, B); error: free_term(A); free_term(B); return NULL; }
term* normalize_fuel_lambda(context *Sigma, typing_context* Delta, term* t, int fuel) { term* b = NULL; term* A = normalize_fuel(Sigma, Delta, t->left, fuel-1); context* extend = context_add(variable_dup(t->var), NULL, Sigma); b = normalize_fuel(extend, Delta, t->right, fuel-1); context_pop(extend); if (!b) goto error; return make_lambda(variable_dup(t->var), A, b); error: free_term(A); free_term(b); return NULL; }
/* PUBLIC */ void zap_term(Term t) { int i; for (i = 0; i < ARITY(t); i++) zap_term(ARG(t,i)); free_term(t); } /* zap_term */
static void p_binding(int vnum, Context vc, Term t, Context tc) { Term vt, ti; vt = get_variable_term(vnum); ti = apply(vt, vc); printf("["); fprint_term(stdout,vt); printf(",0x%x:%d] -> [", (unsigned) vc, vc->multiplier); fprint_term(stdout,t); printf(",0x%x:%d] (", (unsigned) tc, tc->multiplier); fprint_term(stdout,ti); printf(")\n"); free_term(vt); free_term(ti); } /* p_binding */
static Term vars_to_names(Term t) { if (VARIABLE(t)) { Term a; char *s1 = malloc(25); char *s2 = malloc(25); Variable_style v = variable_style(); s2 = int_to_str(VARNUM(t), s2, 25); switch (v) { case INTEGER_STYLE: s1 = strcpy(s1, ""); break; case STANDARD_STYLE: s1 = strcpy(s1, "var_"); break; case PROLOG_STYLE: s1 = strcpy(s1, "VAR_"); break; } s1 = strcat(s1, s2); a = get_rigid_term(s1, 0); free_term(t); free(s1); free(s2); return a; } else { int i; for (i = 0; i < ARITY(t); i++) ARG(t,i) = vars_to_names(ARG(t,i)); return t; } } /* vars_to_names */
static Term trm_set_vars_recurse(Term t, char **varnames, int max_vars) { if (CONSTANT(t)) { char *name = sn_to_str(SYMNUM(t)); if (variable_name(name)) { int i = 0; while (i < max_vars && varnames[i] != NULL && varnames[i] != name) i++; if (i == max_vars) fatal_error("trm_set_vars_recurse: max_vars"); else { if (varnames[i] == NULL) varnames[i] = name; free_term(t); t = get_variable_term(i); } } } else { int i; for (i = 0; i < ARITY(t); i++) ARG(t,i) = trm_set_vars_recurse(ARG(t,i), varnames, max_vars); } return t; } /* trm_set_vars_recurse */
term* whnf(context *Sigma, typing_context* Delta, term* t) { if (t == NULL) return NULL; switch (t->tag) { case VAR: { term* defn = context_lookup(t->var, Sigma); if (defn == NULL) { return term_dup(t); } return whnf(Sigma, Delta, defn); } case APP: { term* l = whnf(Sigma, Delta, t->left); if (l->tag == LAM) { term* subs = substitute(l->var, t->right, l->right); free_term(l); return whnf_and_free(Sigma, Delta, subs); } return make_app(l, term_dup(t->right)); } case ELIM: { term* last = t->args[t->num_args - 1]; term* nlast = whnf(Sigma, Delta, last); term* c = term_dup(t); free_term(c->args[c->num_args - 1]); c->args[c->num_args - 1] = nlast; if (nlast->tag == INTRO) { return whnf_and_free(Sigma, Delta, elim_over_intro(Delta, c)); } else { return c; } } case HOLE: case DATATYPE: case TYPE: case LAM: case INTRO: case PI: case IMPLICIT: return term_dup(t); } }
static term* normalize_fuel_app(context *Sigma, typing_context* Delta, term* t, int fuel) { term *f = normalize_fuel(Sigma, Delta, t->left, fuel-1); term *x = normalize_fuel(Sigma, Delta, t->right, fuel-1); if (!f || !x) goto error; if (f->tag == LAM) { term* subs = substitute(f->var, x, f->right); free_term(f); free_term(x); term* ans = normalize_fuel(Sigma, Delta, subs, fuel-1); free_term(subs); return ans; } return make_app(f, x); error: free_term(f); free_term(x); return NULL; }
/* PUBLIC */ void listterm_zap(Term t) { if (!cons_term(t)) zap_term(t); else { listterm_zap(ARG(t,1)); free_term(t); } } /* listterm_zap */
void blazeit(FILE *input, environment *env) { while(1){ if(debug){ printf("~ "); fflush(stdout); } char *line = fgetl(input); if(!line){ printf("EOF\n"); break; } term *t = parse_string(line); if (!t) continue; if (debug){ printf("Input: "); print_term(t); printf("\n"); } term *type = type_infer(t, env, 0); if (debug){ printf("Type Check: "); print_term(type); printf("\n"); } if(!type) fprintf(stderr, "Didn't Type Check!\n"); evaluate_term(t, env); add_stuff(t, env); if(debug){ printf("Output: "); print_term(t); printf("\n"); } free_term(type); free_term(t); free(line); } }
static Term distrib(Term t) { if (VARIABLE(t)) return t; else { int i; for (i = 0; i < ARITY(t); i++) ARG(t,i) = distrib(ARG(t,i)); if (SYMNUM(t) != Prod_sn) return t; else { if (SYMNUM(ARG(t,1)) == Sum_sn) { /* a*(b+c) */ Term a = ARG(t,0); Term b = ARG(ARG(t,1),0); Term c = ARG(ARG(t,1),1); free_term(ARG(t,1)); free_term(t); return build_binary_term(Sum_sn, distrib(build_binary_term(Prod_sn, a, b)), distrib(build_binary_term(Prod_sn, copy_term(a), c))); } else if (SYMNUM(ARG(t,0)) == Sum_sn) { /* (b+c)*a */ Term a = ARG(t,1); Term b = ARG(ARG(t,0),0); Term c = ARG(ARG(t,0),1); free_term(ARG(t,0)); free_term(t); return build_binary_term(Sum_sn, distrib(build_binary_term(Prod_sn, b, a)), distrib(build_binary_term(Prod_sn, c, copy_term(a)))); } else return t; } } } /* distrib */
static term* elim_over_intro(typing_context* Delta, term* t) { check(t && t->args && t->args[t->num_args - 1], "ill formed term"); term* last = t->args[t->num_args - 1]; datatype* T = elim_to_datatype(t->var, Delta); int index = datatype_intro_index(last->var, T); term *app = term_dup(t->args[index + 1]); int i; for (i = 0; i < last->num_args; i++) { app = make_app(app, term_dup(last->args[i])); if (constructor_arg_is_inductive(T, last->var, i)) { term *inductive = term_dup(t); free_term(inductive->args[inductive->num_args - 1]); inductive->args[inductive->num_args - 1] = term_dup(last->args[i]); app = make_app(app, inductive); } } free_term(t); t = NULL; return app; error: return NULL; }
void free_term(struct term *t) { struct term *tmp; assert( t != NULL ); for( ; t != NULL; t = t->next ) { switch( t->type ) { case TERM_VALUE: free_variable(t->var); free(t); break; case TERM_UNARY: free_term(t->left); free(t); break; case TERM_BINARY: free_term(t->right); free_term(t->left); free(t); break; case TERM_ARRAY: tmp = t->left; free(t); t = tmp; while (t != NULL) { tmp = t->next; free_term(t); t = tmp; } break; default: error_without_abort("out of cases in exec.c__free_term()\n"); } } }
term* normalize_fuel_intro(context *Sigma, typing_context* Delta, term* t, int fuel) { term* ans = make_intro(variable_dup(t->var), term_dup(t->left), t->num_args, t->num_params); int i; for (i = 0; i < t->num_params; i++) { ans->params[i] = normalize_fuel(Sigma, Delta, t->params[i], fuel-1); } for (i = 0; i < t->num_args; i++) { // FIXME: this leaks on error --jrw ans->args[i] = normalize_fuel(Sigma, Delta, t->args[i], fuel-1); if (!ans->args[i]) goto error; } return ans; error: free_term(ans); return NULL; }
static term * termsum(Static *S, term *L, term *R) { if (!L || !R) return 0; if (L->Qe && (L->Qe->next = R->Q)) L->Qe = R->Qe; else if (R->Q) { L->Q = R->Q; L->Qe = R->Qe; } if (L->Le && (L->Le->next = R->L)) L->Le = R->Le; else if (R->L) { L->L = R->L; L->Le = R->Le; } free_term(S, R); return L; }
// returns the S-polynomial Polynomial *s_poly(Polynomial *p1, Polynomial *p2){ Term *t1, *t2, *m1, *m2; Term *lcm, *f1, *f2; Polynomial *new1, *new2, *res; t1 = leading_term(p1); t2 = leading_term(p2); m1 = leading_monomial(p1); m2 = leading_monomial(p2); lcm = term_lcm(m1, m2, p1->num_vars); f1 = (Term *) malloc(sizeof(Term)); f2 = (Term *) malloc(sizeof(Term)); f1->pow = (int *) malloc(sizeof(int) * p1->num_vars); f2->pow = (int *) malloc(sizeof(int) * p1->num_vars); divide_terms(lcm, m1, f1, p1->num_vars); divide_terms(lcm, m2, f2, p1->num_vars); // mutiply factors by opposite leading coefficients f1->coeff.num = f1->coeff.num * t2->coeff.num; f1->coeff.den = f1->coeff.den * t2->coeff.den; f2->coeff.num = f2->coeff.num * t1->coeff.num; f2->coeff.den = f2->coeff.den * t1->coeff.den; new1 = term_multiply_poly(p1, f1); new2 = term_multiply_poly(p2, f2); res = subtract_polys(new1, new2); // free all this intermediate stuff free_term(t1); free_term(t2); free_term(m1); free_term(m2); free_term(f1); free_term(f2); free_term(lcm); free_polynomial(new1); free_polynomial(new2); sort_polynomial(res); return res; }
/* PUBLIC */ Term renum_vars_recurse(Term t, int vmap[], int max_vars) { if (VARIABLE(t)) { int i = 0; while (i < max_vars && vmap[i] != -1 && vmap[i] != VARNUM(t)) i++; if (i == max_vars) fatal_error("renum_vars_recurse: too many variables"); if (vmap[i] == -1) vmap[i] = VARNUM(t); free_term(t); return get_variable_term(i); } else { int i; for (i = 0; i < ARITY(t); i++) ARG(t,i) = renum_vars_recurse(ARG(t,i), vmap, max_vars); return t; } } /* renum_vars_recurse */
term* whnf_and_free(context *Sigma, typing_context* Delta, term* t) { term* ans = whnf(Sigma, Delta, t); free_term(t); return ans; }
/* invariant: no sharing between returned term and *any* arguments. the caller must free the result. */ term* substitute(variable* from, term* to, term* haystack) { if (haystack == NULL) return NULL; check(from != NULL && to != NULL, "substitute requires non-NULL arguments"); check(term_locally_well_formed(to), "substitute requires %W to be locally well-formed", to, print_term); check(term_locally_well_formed(haystack),"substitute requires %W to be locally well-formed", haystack, print_term); switch(haystack->tag) { case VAR: if (variable_equal(from, haystack->var)) { return term_dup(to); } else { return term_dup(haystack); } case HOLE: return term_dup(haystack); case LAM: if (variable_equal(from, haystack->var)) { return make_lambda(variable_dup(haystack->var), substitute(from, to, haystack->left), term_dup(haystack->right)); } else { if (is_free(haystack->var, to)) { variable *g = gensym(haystack->var->name); term *tg = make_var(g); term* new_haystack = make_lambda(variable_dup(g), term_dup(haystack->left), substitute(haystack->var, tg, haystack->right)); free_term(tg); term* ans = substitute(from, to, new_haystack); free_term(new_haystack); return ans; } return make_lambda(variable_dup(haystack->var), substitute(from, to, haystack->left), substitute(from, to, haystack->right)); } case PI: if (variable_equal(from, haystack->var)) { return make_pi(variable_dup(haystack->var), substitute(from, to, haystack->left), term_dup(haystack->right)); } else { if (is_free(haystack->var, to)) { variable *g = gensym(haystack->var->name); term *tg = make_var(g); term* new_haystack = make_pi(variable_dup(g), term_dup(haystack->left), substitute(haystack->var, tg, haystack->right)); free_term(tg); term* ans = substitute(from, to, new_haystack); free_term(new_haystack); return ans; } return make_pi(variable_dup(haystack->var), substitute(from, to, haystack->left), substitute(from, to, haystack->right)); } case APP: return make_app(substitute(from, to, haystack->left), substitute(from, to, haystack->right)); case TYPE: return term_dup(haystack); case DATATYPE: { term* ans = make_datatype_term(variable_dup(haystack->var), haystack->num_params, haystack->num_indices); #define SUB_VEC(dst, src, n) do { \ int __i; \ for (__i = 0; __i < n; __i++) { \ dst[__i] = substitute(from, to, src[__i]); \ } \ } while(0) SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case INTRO: { term* ans = make_intro(variable_dup(haystack->var), substitute(from, to, haystack->left), haystack->num_args, haystack->num_params, haystack->num_indices); SUB_VEC(ans->args, haystack->args, haystack->num_args); SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case ELIM: { term* ans = make_elim(variable_dup(haystack->var), haystack->num_args, haystack->num_params, haystack->num_indices); SUB_VEC(ans->args, haystack->args, haystack->num_args); SUB_VEC(ans->params, haystack->params, haystack->num_params); SUB_VEC(ans->indices, haystack->indices, haystack->num_indices); return ans; } case IMPLICIT: return term_dup(haystack); default: sentinel("malformed term with tag %d", haystack->tag); } error: return NULL; }
int print_term_and_free(FILE* stream, term* t) { int ans = print_term(stream, t); free_term(t); return ans; }
int syntactically_identical(term* a, term* b) { if (a == NULL || b == NULL) return a == b; check(term_locally_well_formed(a) && term_locally_well_formed(b), "alpha equiv requires well-formed arguments"); if (a->tag == HOLE) { log_info("Hole should unify with %W", b, print_term); return 1; } if (b->tag == HOLE) { log_info("Hole should unify with %W", a, print_term); return 1; } if (a->tag != b-> tag) return 0; switch (a->tag) { case VAR: return variable_equal(a->var, b->var); case LAM: { if (a->left != NULL && b->left != NULL && !syntactically_identical(a->left, b->left)) return 0; if (variable_equal(a->var, b->var)) return syntactically_identical(a->right, b->right); term* va = make_var(variable_dup(a->var)); term* bsubs = substitute(b->var, va, b->right); free_term(va); term* c = make_lambda(variable_dup(a->var), term_dup(b->left), bsubs); int ans = syntactically_identical(a, c); free_term(c); return ans; } case PI: { if (!syntactically_identical(a->left, b->left)) return 0; if (variable_equal(a->var, b->var)) return syntactically_identical(a->right, b->right); term* va = make_var(variable_dup(a->var)); term* bsubs = substitute(b->var, va, b->right); free_term(va); term* c = make_pi(variable_dup(a->var), term_dup(b->left), bsubs); int ans = syntactically_identical(a, c); free_term(c); return ans; } case APP: return syntactically_identical(a->left, b->left) && syntactically_identical(a->right, b->right); case DATATYPE: { if (!variable_equal(a->var, b->var)) { return 0; } #define EQ_VEC(a, an, b, bn) do { \ if (an != bn) return 0; \ int __i; \ for (__i = 0; __i < an; __i++) { \ if (!syntactically_identical(a[__i], b[__i])) return 0; \ } \ } while(0) EQ_VEC(a->params, a->num_params, b->params, b->num_params); EQ_VEC(a->indices, a->num_indices, b->indices, b->num_indices); return 1; } case INTRO: case ELIM: { if (!variable_equal(a->var, b->var)) { return 0; } EQ_VEC(a->args, a->num_args, b->args, b->num_args); EQ_VEC(a->params, a->num_params, b->params, b->num_params); EQ_VEC(a->indices, a->num_indices, b->indices, b->num_indices); return 1; } case TYPE: return 1; case IMPLICIT: return syntactically_identical(a->right, b->right); default: sentinel("malformed term"); } error: return 0; }
term* normalize_no_unfold_and_free(typing_context* Delta, term* t) { term* ans = normalize_no_unfold(Delta, t); free_term(t); return ans; }
static term * ewalk(Static *S, expr *e) { term *L, *R, *T; ograd *o, *oR; expr **ep, **epe; int i; ASL_fg *asl; switch(Intcast e->op) { case OPNUM: return new_term(S, new_og(S, 0, -1 , ((expr_n *)e)->v)); case OPPLUS: return termsum(S, ewalk(S, e->L.e), ewalk(S, e->R.e)); case OPMINUS: return termsum(S, ewalk(S, e->L.e), scale(S, ewalk(S, e->R.e), -1.)); case OPUMINUS: return scale(S, ewalk(S, e->L.e), -1.); case OPMULT: if (!(L = ewalk(S, e->L.e)) || !(R = ewalk(S, e->R.e))) break; if (L->Q) { if (R->Q) break; qscale: o = R->L; if (o->next || o->varno >= 0) break; scale(S, L, o->coef); free_og(S, o); free_term(S, R); return L; } if (R->Q) { T = L; L = R; R = T; goto qscale; } o = L->L; oR = R->L; if (o->next || o->varno >= 0) { if (oR->next || oR->varno >= 0) { L->Q = L->Qe = new_dyad(S, 0,o,oR,1); L->L = L->Le = 0; } else { scale(S, L, oR->coef); free_og(S, oR); } free_term(S, R); return L; } scale(S, R, o->coef); free_og(S, o); free_term(S, L); return R; case OPDIV: /* only allow division by a constant */ if (!(R = ewalk(S, e->R.e))) break; o = R->L; if (R->Q || o->next || o->varno >= 0) break; if (!(L = ewalk(S, e->L.e))) break; if (!o->coef) { zerodiv++; L = 0; } else scale(S, L, 1./o->coef); free_og(S, o); free_term(S, R); return L; case OPSUMLIST: ep = e->L.ep; epe = e->R.ep; L = ewalk(S, *ep); while(L && ++ep < epe) L = termsum(S, L, ewalk(S, *ep)); return L; case OP2POW: L = ewalk(S, e->L.e); if (!L || L->Q) break; o = L->L; if (!o->next && o->varno < 0) { o->coef *= o->coef; return L; } L->Q = L->Qe = new_dyad(S, 0,o,o,1); L->L = L->Le = 0; return L; case OPVARVAL: asl = S->asl; if ((i = (expr_v *)e - var_e) < n_var) return new_term(S, new_og(S, 0, i, 1.)); i -= S->nvinc; if (!(L = cterms[i -= n_var]) && !(L = cterms[i] = comterm(S, i))) return 0; return termdup(S, L); } return 0; /* nonlinear */ }
static term* normalize_and_free_fuel(context *Sigma, typing_context* Delta, term* t, int fuel) { term* ans = normalize_fuel(Sigma, Delta, t, fuel); free_term(t); return ans; }