// If restricted is true, we don't use (e <-> true) rewrite list<expr_pair> apply(expr const & e, expr const & H, bool restrited) { expr c, Hdec, A, arg1, arg2; if (is_relation(e)) { return mk_singleton(e, H); } else if (is_standard(m_env) && is_not(m_env, e, arg1)) { expr new_e = mk_iff(arg1, mk_false()); expr new_H = mk_app(mk_constant(get_iff_false_intro_name()), arg1, H); return mk_singleton(new_e, new_H); } else if (is_standard(m_env) && is_and(e, arg1, arg2)) { // TODO(Leo): we can extend this trick to any type that has only one constructor expr H1 = mk_app(mk_constant(get_and_elim_left_name()), arg1, arg2, H); expr H2 = mk_app(mk_constant(get_and_elim_right_name()), arg1, arg2, H); auto r1 = apply(arg1, H1, restrited); auto r2 = apply(arg2, H2, restrited); return append(r1, r2); } else if (is_pi(e)) { expr local = mk_local(m_tc.mk_fresh_name(), binding_name(e), binding_domain(e), binding_info(e)); expr new_e = instantiate(binding_body(e), local); expr new_H = mk_app(H, local); auto r = apply(new_e, new_H, restrited); unsigned len = length(r); if (len == 0) { return r; } else if (len == 1 && head(r).first == new_e && head(r).second == new_H) { return mk_singleton(e, H); } else { return lift(local, r); } } else if (is_standard(m_env) && is_ite(e, c, Hdec, A, arg1, arg2) && is_prop(e)) { // TODO(Leo): support HoTT mode if users request expr not_c = mk_not(m_tc, c); expr Hc = mk_local(m_tc.mk_fresh_name(), c); expr Hnc = mk_local(m_tc.mk_fresh_name(), not_c); expr H1 = mk_app({mk_constant(get_implies_of_if_pos_name()), c, arg1, arg2, Hdec, e, Hc}); expr H2 = mk_app({mk_constant(get_implies_of_if_neg_name()), c, arg1, arg2, Hdec, e, Hnc}); auto r1 = lift(Hc, apply(arg1, H1, restrited)); auto r2 = lift(Hnc, apply(arg2, H2, restrited)); return append(r1, r2); } else if (!restrited) { constraint_seq cs; expr new_e = m_tc.whnf(e, cs); if (new_e != e && !cs) { if (auto r = apply(new_e, H, true)) return r; } if (is_standard(m_env) && is_prop(e)) { expr new_e = mk_iff(e, mk_true()); expr new_H = mk_app(mk_constant(get_iff_true_intro_name()), arg1, H); return mk_singleton(new_e, new_H); } else { return list<expr_pair>(); } } else { return list<expr_pair>(); } }
expr mk_expr_placeholder(optional<expr> const & type, expr_placeholder_kind k) { name n(to_prefix(k), next_placeholder_id()); if (type) return mk_local(n, *type); else return mk_constant(n); }
bool match_pattern(type_checker & tc, expr const & pattern, declaration const & d, unsigned max_steps, bool cheap) { name_generator ngen = tc.mk_ngen(); buffer<level> ls; unsigned num_ls = d.get_num_univ_params(); for (unsigned i = 0; i < num_ls; i++) ls.push_back(mk_meta_univ(ngen.next())); expr dt = instantiate_type_univ_params(d, to_list(ls.begin(), ls.end())); unsigned num_e = get_expect_num_args(tc, pattern); unsigned num_d = get_expect_num_args(tc, dt); if (num_e > num_d) return false; for (unsigned i = 0; i < num_d - num_e; i++) { dt = tc.whnf(dt).first; expr local = mk_local(ngen.next(), binding_domain(dt)); dt = instantiate(binding_body(dt), local); } try { unifier_config cfg; cfg.m_max_steps = max_steps; cfg.m_kind = cheap ? unifier_kind::Cheap : unifier_kind::Liberal; cfg.m_ignore_context_check = true; auto r = unify(tc.env(), pattern, dt, tc.mk_ngen(), substitution(), cfg); return static_cast<bool>(r.pull()); } catch (exception&) { return false; } }
expr update_mlocal(expr const & e, expr const & new_type) { if (is_eqp(mlocal_type(e), new_type)) return e; else if (is_metavar(e)) return mk_metavar(mlocal_name(e), new_type, e.get_tag()); else return mk_local(mlocal_name(e), local_pp_name(e), new_type, local_info(e), e.get_tag()); }
list<expr> get_coercions_from_to(type_checker & from_tc, type_checker & to_tc, expr const & from_type, expr const & to_type, constraint_seq & cs, bool lift_coe) { constraint_seq new_cs; environment const & env = to_tc.env(); expr whnf_from_type = from_tc.whnf(from_type, new_cs); expr whnf_to_type = to_tc.whnf(to_type, new_cs); if (lift_coe && is_pi(whnf_from_type)) { // Try to lift coercions. // The idea is to convert a coercion from A to B, into a coercion from D->A to D->B if (!is_pi(whnf_to_type)) return list<expr>(); // failed if (!from_tc.is_def_eq(binding_domain(whnf_from_type), binding_domain(whnf_to_type), justification(), new_cs)) return list<expr>(); // failed, the domains must be definitionally equal expr x = mk_local(mk_fresh_name(), "x", binding_domain(whnf_from_type), binder_info()); expr A = instantiate(binding_body(whnf_from_type), x); expr B = instantiate(binding_body(whnf_to_type), x); list<expr> coe = get_coercions_from_to(from_tc, to_tc, A, B, new_cs, lift_coe); if (coe) { cs += new_cs; // Remark: each coercion c in coe is a function from A to B // We create a new list: (fun (f : D -> A) (x : D), c (f x)) expr f = mk_local(mk_fresh_name(), "f", whnf_from_type, binder_info()); expr fx = mk_app(f, x); return map(coe, [&](expr const & c) { return Fun(f, Fun(x, mk_app(c, fx))); }); } else { return list<expr>(); } } else { expr const & fn = get_app_fn(whnf_to_type); list<expr> r; if (is_constant(fn)) { r = get_coercions(env, whnf_from_type, const_name(fn)); } else if (is_pi(whnf_to_type)) { r = get_coercions_to_fun(env, whnf_from_type); } else if (is_sort(whnf_to_type)) { r = get_coercions_to_sort(env, whnf_from_type); } if (r) cs += new_cs; return r; } }
bool is_ceqv(type_checker & tc, expr e) { if (has_expr_metavar(e)) return false; name_set to_find; // Define a procedure for removing arguments from to_find. auto visitor_fn = [&](expr const & e, unsigned) { if (is_local(e)) { to_find.erase(mlocal_name(e)); return false; } else if (is_metavar(e)) { return false; } else { return true; } }; environment const & env = tc.env(); bool is_std = is_standard(env); buffer<expr> hypotheses; // arguments that are propositions while (is_pi(e)) { if (!to_find.empty()) { // Support for dependent types. // We may find the instantiation for the previous arguments // by matching the type. for_each(binding_domain(e), visitor_fn); } expr local = mk_local(tc.mk_fresh_name(), binding_domain(e)); if (binding_info(e).is_inst_implicit()) { // If the argument can be instantiated by type class resolution, then // we don't need to find it in the lhs } else if (is_std && tc.is_prop(binding_domain(e)).first) { // If the argument is a proposition, we store it in hypotheses. // We check whether the lhs occurs in hypotheses or not. hypotheses.push_back(binding_domain(e)); } else { to_find.insert(mlocal_name(local)); } e = instantiate(binding_body(e), local); } expr lhs, rhs; if (!is_simp_relation(env, e, lhs, rhs)) return false; // traverse lhs, and remove found variables from to_find for_each(lhs, visitor_fn); if (!to_find.empty()) return false; // basic looping ceq detection: the left-hand-side should not occur in the right-hand-side, // nor it should occur in any of the hypothesis if (occurs(lhs, rhs)) return false; if (std::any_of(hypotheses.begin(), hypotheses.end(), [&](expr const & h) { return occurs(lhs, h); })) return false; return true; }
void visit_binding(expr const & _e) { if (should_visit(_e)) { buffer<expr> ls; expr e = _e; while (is_lambda(e) || is_pi(e)) { expr d = instantiate_rev(binding_domain(e), ls.size(), ls.data()); expr l = mk_local(mk_fresh_name(), binding_name(e), d, binding_info(e)); ls.push_back(l); e = binding_body(e); } visit(instantiate_rev(e, ls.size(), ls.data())); } }
tactic intros_tactic(list<name> _ns, bool relax_main_opaque) { auto fn = [=](environment const & env, io_state const &, proof_state const & s) { list<name> ns = _ns; goals const & gs = s.get_goals(); if (empty(gs)) { throw_no_goal_if_enabled(s); return optional<proof_state>(); } goal const & g = head(gs); name_generator ngen = s.get_ngen(); auto tc = mk_type_checker(env, ngen.mk_child(), relax_main_opaque); expr t = g.get_type(); expr m = g.get_meta(); bool gen_names = empty(ns); try { while (true) { if (!gen_names && is_nil(ns)) break; if (!is_pi(t)) { if (!is_nil(ns)) { t = tc->ensure_pi(t).first; } else { expr new_t = tc->whnf(t).first; if (!is_pi(new_t)) break; t = new_t; } } name new_name; if (!is_nil(ns)) { new_name = head(ns); ns = tail(ns); } else { new_name = get_unused_name(binding_name(t), m); } expr new_local = mk_local(ngen.next(), new_name, binding_domain(t), binding_info(t)); t = instantiate(binding_body(t), new_local); m = mk_app(m, new_local); } goal new_g(m, t); return some(proof_state(s, goals(new_g, tail(gs)), ngen)); } catch (exception &) { return optional<proof_state>(); } }; return tactic01(fn); }
optional<constraints> try_instance(expr const & inst, expr const & inst_type) { type_checker & tc = m_C->tc(); name_generator & ngen = m_C->m_ngen; tag g = inst.get_tag(); try { flet<local_context> scope(m_ctx, m_ctx); buffer<expr> locals; expr meta_type = m_meta_type; while (true) { meta_type = tc.whnf(meta_type).first; if (!is_pi(meta_type)) break; expr local = mk_local(ngen.next(), binding_name(meta_type), binding_domain(meta_type), binding_info(meta_type)); m_ctx.add_local(local); locals.push_back(local); meta_type = instantiate(binding_body(meta_type), local); } expr type = inst_type; expr r = inst; buffer<constraint> cs; while (true) { type = tc.whnf(type).first; if (!is_pi(type)) break; expr arg; if (binding_info(type).is_inst_implicit()) { pair<expr, constraint> ac = mk_class_instance_elaborator(m_C, m_ctx, some_expr(binding_domain(type)), g, m_depth+1); arg = ac.first; cs.push_back(ac.second); } else { arg = m_ctx.mk_meta(m_C->m_ngen, some_expr(binding_domain(type)), g); } r = mk_app(r, arg, g); type = instantiate(binding_body(type), arg); } r = Fun(locals, r); trace(meta_type, r); bool relax = m_C->m_relax; constraint c = mk_eq_cnstr(m_meta, r, m_jst, relax); return optional<constraints>(mk_constraints(c, cs)); } catch (exception &) { return optional<constraints>(); } }
environment mk_rec_on(environment const & env, name const & n) { if (!inductive::is_inductive_decl(env, n)) throw exception(sstream() << "error in 'rec_on' generation, '" << n << "' is not an inductive datatype"); name rec_on_name(n, "rec_on"); name_generator ngen; declaration rec_decl = env.get(inductive::get_elim_name(n)); buffer<expr> locals; expr rec_type = rec_decl.get_type(); while (is_pi(rec_type)) { expr local = mk_local(ngen.next(), binding_name(rec_type), binding_domain(rec_type), binding_info(rec_type)); rec_type = instantiate(binding_body(rec_type), local); locals.push_back(local); } // locals order // A C minor_premises indices major-premise // new_locals order // A C indices major-premise minor-premises buffer<expr> new_locals; unsigned idx_major_sz = *inductive::get_num_indices(env, n) + 1; unsigned minor_sz = *inductive::get_num_minor_premises(env, n); unsigned AC_sz = locals.size() - minor_sz - idx_major_sz; for (unsigned i = 0; i < AC_sz; i++) new_locals.push_back(locals[i]); for (unsigned i = 0; i < idx_major_sz; i++) new_locals.push_back(locals[AC_sz + minor_sz + i]); unsigned rec_on_major_idx = new_locals.size() - 1; for (unsigned i = 0; i < minor_sz; i++) new_locals.push_back(locals[AC_sz + i]); expr rec_on_type = Pi(new_locals, rec_type); levels ls = param_names_to_levels(rec_decl.get_univ_params()); expr rec = mk_constant(rec_decl.get_name(), ls); expr rec_on_val = Fun(new_locals, mk_app(rec, locals)); bool use_conv_opt = true; environment new_env = module::add(env, check(env, mk_definition(env, rec_on_name, rec_decl.get_univ_params(), rec_on_type, rec_on_val, use_conv_opt))); new_env = set_reducible(new_env, rec_on_name, reducible_status::Reducible); new_env = add_unfold_hint(new_env, rec_on_name, rec_on_major_idx); new_env = add_aux_recursor(new_env, rec_on_name); return add_protected(new_env, rec_on_name); }
expr visit_binding(expr e) { expr_kind k = e.kind(); buffer<expr> es; buffer<expr> ls; while (e.kind() == k) { expr d = visit(instantiate_rev(binding_domain(e), ls.size(), ls.data())); expr l = mk_local(m_tc.mk_fresh_name(), binding_name(e), d, binding_info(e)); ls.push_back(l); es.push_back(e); e = binding_body(e); } e = visit(instantiate_rev(e, ls.size(), ls.data())); expr r = abstract_locals(e, ls.size(), ls.data()); while (!ls.empty()) { expr d = mlocal_type(ls.back()); ls.pop_back(); d = abstract_locals(d, ls.size(), ls.data()); r = update_binding(es.back(), d, r); es.pop_back(); } return r; }
static environment mk_brec_on(environment const & env, name const & n, bool ind) { if (!is_recursive_datatype(env, n)) return env; if (is_inductive_predicate(env, n)) return env; inductive::inductive_decls decls = *inductive::is_inductive_decl(env, n); type_checker tc(env); name_generator ngen; unsigned nparams = std::get<1>(decls); declaration ind_decl = env.get(n); declaration rec_decl = env.get(inductive::get_elim_name(n)); // declaration below_decl = env.get(name(n, ind ? "ibelow" : "below")); unsigned nindices = *inductive::get_num_indices(env, n); unsigned nminors = *inductive::get_num_minor_premises(env, n); unsigned ntypeformers = length(std::get<2>(decls)); level_param_names lps = rec_decl.get_univ_params(); bool is_reflexive = is_reflexive_datatype(tc, n); level lvl = mk_param_univ(head(lps)); levels lvls = param_names_to_levels(tail(lps)); level rlvl; level_param_names blps; levels blvls; // universe level parameters of brec_on/binduction_on // The arguments of brec_on (binduction_on) are the ones in the recursor - minor premises. // The universe we map to is also different (l+1 for below of reflexive types) and (0 fo ibelow). expr ref_type; if (ind) { // we are eliminating to Prop blps = tail(lps); blvls = lvls; rlvl = mk_level_zero(); ref_type = instantiate_univ_param(rec_decl.get_type(), param_id(lvl), mk_level_zero()); } else if (is_reflexive) { blps = lps; blvls = cons(lvl, lvls); rlvl = get_datatype_level(ind_decl.get_type()); // if rlvl is of the form (max 1 l), then rlvl <- l if (is_max(rlvl) && is_one(max_lhs(rlvl))) rlvl = max_rhs(rlvl); rlvl = mk_max(mk_succ(lvl), rlvl); // inner_prod, inner_prod_intro, pr1, pr2 do not use the same universe levels for // reflective datatypes. ref_type = instantiate_univ_param(rec_decl.get_type(), param_id(lvl), mk_succ(lvl)); } else { // we can simplify the universe levels for non-reflexive datatypes blps = lps; blvls = cons(lvl, lvls); rlvl = mk_max(mk_level_one(), lvl); ref_type = rec_decl.get_type(); } buffer<expr> ref_args; to_telescope(ngen, ref_type, ref_args); if (ref_args.size() != nparams + ntypeformers + nminors + nindices + 1) throw_corrupted(n); // args contains the brec_on/binduction_on arguments buffer<expr> args; buffer<name> typeformer_names; // add parameters and typeformers for (unsigned i = 0; i < nparams; i++) args.push_back(ref_args[i]); for (unsigned i = nparams; i < nparams + ntypeformers; i++) { args.push_back(ref_args[i]); typeformer_names.push_back(mlocal_name(ref_args[i])); } // add indices and major premise for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++) args.push_back(ref_args[i]); // create below terms (one per datatype) // (below.{lvls} params type-formers) // Remark: it also creates the result type buffer<expr> belows; expr result_type; unsigned k = 0; for (auto const & decl : std::get<2>(decls)) { name const & n1 = inductive::inductive_decl_name(decl); if (n1 == n) { result_type = ref_args[nparams + k]; for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++) result_type = mk_app(result_type, ref_args[i]); } k++; name bname = name(n1, ind ? "ibelow" : "below"); expr below = mk_constant(bname, blvls); for (unsigned i = 0; i < nparams; i++) below = mk_app(below, ref_args[i]); for (unsigned i = nparams; i < nparams + ntypeformers; i++) below = mk_app(below, ref_args[i]); belows.push_back(below); } // create functionals (one for each type former) // Pi idxs t, below idxs t -> C idxs t buffer<expr> Fs; name F_name("F"); for (unsigned i = nparams, j = 0; i < nparams + ntypeformers; i++, j++) { expr const & C = ref_args[i]; buffer<expr> F_args; to_telescope(ngen, mlocal_type(C), F_args); expr F_result = mk_app(C, F_args); expr F_below = mk_app(belows[j], F_args); F_args.push_back(mk_local(ngen.next(), "f", F_below, binder_info())); expr F_type = Pi(F_args, F_result); expr F = mk_local(ngen.next(), F_name.append_after(j+1), F_type, binder_info()); Fs.push_back(F); args.push_back(F); } // We define brec_on/binduction_on using the recursor for this type levels rec_lvls = cons(rlvl, lvls); expr rec = mk_constant(rec_decl.get_name(), rec_lvls); // add parameters to rec for (unsigned i = 0; i < nparams; i++) rec = mk_app(rec, ref_args[i]); // add type formers to rec // Pi indices t, prod (C ... t) (below ... t) for (unsigned i = nparams, j = 0; i < nparams + ntypeformers; i++, j++) { expr const & C = ref_args[i]; buffer<expr> C_args; to_telescope(ngen, mlocal_type(C), C_args); expr C_t = mk_app(C, C_args); expr below_t = mk_app(belows[j], C_args); expr prod = mk_prod(tc, C_t, below_t, ind); rec = mk_app(rec, Fun(C_args, prod)); } // add minor premises to rec for (unsigned i = nparams + ntypeformers, j = 0; i < nparams + ntypeformers + nminors; i++, j++) { expr minor = ref_args[i]; expr minor_type = mlocal_type(minor); buffer<expr> minor_args; minor_type = to_telescope(ngen, minor_type, minor_args); buffer<expr> pairs; for (expr & minor_arg : minor_args) { buffer<expr> minor_arg_args; expr minor_arg_type = to_telescope(tc, mlocal_type(minor_arg), minor_arg_args); if (auto k = is_typeformer_app(typeformer_names, minor_arg_type)) { buffer<expr> C_args; get_app_args(minor_arg_type, C_args); expr new_minor_arg_type = mk_prod(tc, minor_arg_type, mk_app(belows[*k], C_args), ind); minor_arg = update_mlocal(minor_arg, Pi(minor_arg_args, new_minor_arg_type)); if (minor_arg_args.empty()) { pairs.push_back(minor_arg); } else { expr r = mk_app(minor_arg, minor_arg_args); expr r_1 = Fun(minor_arg_args, mk_pr1(tc, r, ind)); expr r_2 = Fun(minor_arg_args, mk_pr2(tc, r, ind)); pairs.push_back(mk_pair(tc, r_1, r_2, ind)); } } } expr b = foldr([&](expr const & a, expr const & b) { return mk_pair(tc, a, b, ind); }, [&]() { return mk_unit_mk(rlvl, ind); }, pairs.size(), pairs.data()); unsigned F_idx = *is_typeformer_app(typeformer_names, minor_type); expr F = Fs[F_idx]; buffer<expr> F_args; get_app_args(minor_type, F_args); F_args.push_back(b); expr new_arg = mk_pair(tc, mk_app(F, F_args), b, ind); rec = mk_app(rec, Fun(minor_args, new_arg)); } // add indices and major to rec for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++) rec = mk_app(rec, ref_args[i]); name brec_on_name = name(n, ind ? "binduction_on" : "brec_on"); expr brec_on_type = Pi(args, result_type); expr brec_on_value = Fun(args, mk_pr1(tc, rec, ind)); bool use_conv_opt = true; declaration new_d = mk_definition(env, brec_on_name, blps, brec_on_type, brec_on_value, use_conv_opt); environment new_env = module::add(env, check(env, new_d)); new_env = set_reducible(new_env, brec_on_name, reducible_status::Reducible); if (!ind) new_env = add_unfold_hint(new_env, brec_on_name, nparams + nindices + ntypeformers); return add_protected(new_env, brec_on_name); }
expr normalize_binding(expr const & e) { expr d = normalize(binding_domain(e)); expr l = mk_local(m_ngen.next(), binding_name(e), d, binding_info(e)); expr b = abstract(normalize(instantiate(binding_body(e), l)), l); return update_binding(e, d, b); }
expr abstract_type_context::push_local(name const & pp_name, expr const & type, binder_info const & bi) { return mk_local(mk_fresh_name(), pp_name, type, bi); }
expr update_local(expr const & e, expr const & new_type, binder_info const & bi) { if (is_eqp(mlocal_type(e), new_type) && local_info(e) == bi) return e; else return mk_local(mlocal_name(e), local_pp_name(e), new_type, bi, e.get_tag()); }
expr visit_binding(expr const & b) { expr new_domain = visit(binding_domain(b)); expr l = mk_local(m_tc.mk_fresh_name(), new_domain); expr new_body = abstract(visit(instantiate(binding_body(b), l)), l); return update_binding(b, new_domain, new_body); }
void test_inductive() { // declare list type lean_exception ex = 0; lean_env env = mk_env(); lean_name l_name = mk_name("l"); lean_univ l = mk_uparam("l"); lean_univ one = mk_one(); lean_univ m1l = mk_max(one, l); lean_expr Typel = mk_sort(l); lean_expr Typem1l = mk_sort(m1l); lean_expr list_type = mk_pi("A", Typel, Typem1l); lean_name list_name = mk_name("list"); lean_expr list = mk_const("list", l); lean_expr v0 = mk_var(0); // nil : Pi (A : Type.{l}), list.{l} A lean_expr list_v0 = mk_app(list, v0); lean_expr nil_type = mk_pi("A", Typel, list_v0); lean_expr nil = mk_local("nil", nil_type); // cons : Pi (A : Type.{l}), A -> list.{l} A -> list.{l} A lean_expr v1 = mk_var(1); lean_expr v2 = mk_var(2); lean_expr list_v2 = mk_app(list, v2); lean_expr list_v1 = mk_app(list, v1); lean_expr cons_type1 = mk_pi("tail", list_v1, list_v2); lean_expr cons_type2 = mk_pi("head", v0, cons_type1); lean_expr cons_type = mk_pi("A", Typel, cons_type2); lean_expr cons = mk_local("cons", cons_type); // lean_list_expr cs1, cs2, list_cs; lean_inductive_type list_ind_type; lean_list_inductive_type li1, list_ind_types; lean_list_name ls1, ls; lean_inductive_decl list_decl; lean_env new_env; check(lean_list_name_mk_nil(&ls1, &ex)); check(lean_list_name_mk_cons(l_name, ls1, &ls, &ex)); check(lean_list_expr_mk_nil(&cs1, &ex)); check(lean_list_expr_mk_cons(nil, cs1, &cs2, &ex)); check(lean_list_expr_mk_cons(cons, cs2, &list_cs, &ex)); check(lean_inductive_type_mk(list_name, list_type, list_cs, &list_ind_type, &ex)); check(lean_list_inductive_type_mk_nil(&li1, &ex)); check(lean_list_inductive_type_mk_cons(list_ind_type, li1, &list_ind_types, &ex)); check(lean_inductive_decl_mk(ls, 1, list_ind_types, &list_decl, &ex)); check(lean_env_add_inductive(env, list_decl, &new_env, &ex)); { unsigned n; lean_inductive_decl d; lean_name cons_name = mk_name("cons"); lean_name r_name; lean_list_inductive_type types; check(lean_env_get_inductive_type_num_indices(new_env, list_name, &n, &ex) && n == 0); check(lean_env_get_inductive_type_num_minor_premises(new_env, list_name, &n, &ex) && n == 2); check(!lean_env_is_inductive_type(env, list_name, &d, &ex)); check(lean_env_is_inductive_type(new_env, list_name, &d, &ex)); check(lean_inductive_decl_get_num_params(d, &n, &ex) && n == 1); check(lean_inductive_decl_get_types(d, &types, &ex)); check(lean_list_inductive_type_is_cons(types)); check(lean_env_is_constructor(new_env, cons_name, &r_name, &ex) && lean_name_eq(list_name, r_name)); lean_inductive_decl_del(d); lean_name_del(cons_name); lean_name_del(r_name); } lean_env_del(env); lean_name_del(list_name); lean_name_del(l_name); lean_univ_del(l); lean_univ_del(one); lean_univ_del(m1l); lean_expr_del(Typel); lean_expr_del(Typem1l); lean_expr_del(list_type); lean_expr_del(list); lean_expr_del(v0); lean_expr_del(list_v0); lean_expr_del(nil_type); lean_expr_del(nil); lean_expr_del(v1); lean_expr_del(v2); lean_expr_del(list_v2); lean_expr_del(list_v1); lean_expr_del(cons_type1); lean_expr_del(cons_type2); lean_expr_del(cons_type); lean_expr_del(cons); lean_list_expr_del(cs1); lean_list_expr_del(cs2); lean_list_expr_del(list_cs); lean_inductive_type_del(list_ind_type); lean_list_inductive_type_del(li1); lean_list_inductive_type_del(list_ind_types); lean_list_name_del(ls1); lean_list_name_del(ls); lean_inductive_decl_del(list_decl); lean_env_del(new_env); }
/** \brief Given a term <tt>a : a_type</tt>, and a metavariable \c m, creates a constraint that considers coercions from a_type to the type assigned to \c m. */ constraint mk_coercion_cnstr(type_checker & from_tc, type_checker & to_tc, coercion_info_manager & infom, expr const & m, expr const & a, expr const & a_type, justification const & j, unsigned delay_factor, bool lift_coe) { auto choice_fn = [=, &from_tc, &to_tc, &infom](expr const & meta, expr const & d_type, substitution const & s) { expr new_a_type; justification new_a_type_jst; if (is_meta(a_type)) { auto p = substitution(s).instantiate_metavars(a_type); new_a_type = p.first; new_a_type_jst = p.second; } else { new_a_type = a_type; } if (is_meta(new_a_type)) { if (delay_factor < to_delay_factor(cnstr_group::DelayedChoice)) { // postpone... return lazy_list<constraints>(constraints(mk_coercion_cnstr(from_tc, to_tc, infom, m, a, a_type, justification(), delay_factor+1, lift_coe))); } else { // giveup... return lazy_list<constraints>(constraints(mk_eq_cnstr(meta, a, justification()))); } } constraint_seq cs; new_a_type = from_tc.whnf(new_a_type, cs); if ((lift_coe && is_pi_meta(d_type)) || (!lift_coe && is_meta(d_type))) { // case-split buffer<expr> locals; expr it_from = new_a_type; expr it_to = d_type; while (is_pi(it_from) && is_pi(it_to)) { expr dom_from = binding_domain(it_from); expr dom_to = binding_domain(it_to); if (!from_tc.is_def_eq(dom_from, dom_to, justification(), cs)) return lazy_list<constraints>(); expr local = mk_local(mk_fresh_name(), binding_name(it_from), dom_from, binder_info()); locals.push_back(local); it_from = instantiate(binding_body(it_from), local); it_to = instantiate(binding_body(it_to), local); } buffer<expr> alts; get_coercions_from(from_tc.env(), it_from, alts); expr fn_a; if (!locals.empty()) fn_a = mk_local(mk_fresh_name(), "f", new_a_type, binder_info()); buffer<constraints> choices; buffer<expr> coes; // first alternative: no coercion constraint_seq cs1 = cs + mk_eq_cnstr(meta, a, justification()); choices.push_back(cs1.to_list()); unsigned i = alts.size(); while (i > 0) { --i; expr coe = alts[i]; if (!locals.empty()) coe = Fun(fn_a, Fun(locals, mk_app(coe, mk_app(fn_a, locals)))); expr new_a = copy_tag(a, mk_app(coe, a)); coes.push_back(coe); constraint_seq csi = cs + mk_eq_cnstr(meta, new_a, new_a_type_jst); choices.push_back(csi.to_list()); } return choose(std::make_shared<coercion_elaborator>(infom, meta, to_list(choices.begin(), choices.end()), to_list(coes.begin(), coes.end()))); } else { list<expr> coes = get_coercions_from_to(from_tc, to_tc, new_a_type, d_type, cs, lift_coe); if (is_nil(coes)) { expr new_a = a; infom.erase_coercion_info(a); cs += mk_eq_cnstr(meta, new_a, new_a_type_jst); return lazy_list<constraints>(cs.to_list()); } else if (is_nil(tail(coes))) { expr new_a = copy_tag(a, mk_app(head(coes), a)); infom.save_coercion_info(a, new_a); cs += mk_eq_cnstr(meta, new_a, new_a_type_jst); return lazy_list<constraints>(cs.to_list()); } else { list<constraints> choices = map2<constraints>(coes, [&](expr const & coe) { expr new_a = copy_tag(a, mk_app(coe, a)); constraint c = mk_eq_cnstr(meta, new_a, new_a_type_jst); return (cs + c).to_list(); }); return choose(std::make_shared<coercion_elaborator>(infom, meta, choices, coes, false)); } } }; return mk_choice_cnstr(m, choice_fn, delay_factor, true, j); }
void add_congr_core(environment const & env, simp_rule_sets & s, name const & n) { declaration const & d = env.get(n); type_checker tc(env); buffer<level> us; unsigned num_univs = d.get_num_univ_params(); for (unsigned i = 0; i < num_univs; i++) { us.push_back(mk_meta_univ(name(*g_prefix, i))); } levels ls = to_list(us); expr pr = mk_constant(n, ls); expr e = instantiate_type_univ_params(d, ls); buffer<bool> explicit_args; buffer<expr> metas; unsigned idx = 0; while (is_pi(e)) { expr mvar = mk_metavar(name(*g_prefix, idx), binding_domain(e)); idx++; explicit_args.push_back(is_explicit(binding_info(e))); metas.push_back(mvar); e = instantiate(binding_body(e), mvar); pr = mk_app(pr, mvar); } expr rel, lhs, rhs; if (!is_simp_relation(env, e, rel, lhs, rhs) || !is_constant(rel)) { throw exception(sstream() << "invalid congruence rule, '" << n << "' resulting type is not of the form t ~ s, where '~' is a transitive and reflexive relation"); } name_set found_mvars; buffer<expr> lhs_args, rhs_args; expr const & lhs_fn = get_app_args(lhs, lhs_args); expr const & rhs_fn = get_app_args(rhs, rhs_args); if (is_constant(lhs_fn)) { if (!is_constant(rhs_fn) || const_name(lhs_fn) != const_name(rhs_fn) || lhs_args.size() != rhs_args.size()) { throw exception(sstream() << "invalid congruence rule, '" << n << "' resulting type is not of the form (" << const_name(lhs_fn) << " ...) " << "~ (" << const_name(lhs_fn) << " ...), where ~ is '" << const_name(rel) << "'"); } for (expr const & lhs_arg : lhs_args) { if (is_sort(lhs_arg)) continue; if (!is_metavar(lhs_arg) || found_mvars.contains(mlocal_name(lhs_arg))) { throw exception(sstream() << "invalid congruence rule, '" << n << "' the left-hand-side of the congruence resulting type must be of the form (" << const_name(lhs_fn) << " x_1 ... x_n), where each x_i is a distinct variable or a sort"); } found_mvars.insert(mlocal_name(lhs_arg)); } } else if (is_binding(lhs)) { if (lhs.kind() != rhs.kind()) { throw exception(sstream() << "invalid congruence rule, '" << n << "' kinds of the left-hand-side and right-hand-side of " << "the congruence resulting type do not match"); } if (!is_valid_congr_rule_binding_lhs(lhs, found_mvars)) { throw exception(sstream() << "invalid congruence rule, '" << n << "' left-hand-side of the congruence resulting type must " << "be of the form (fun/Pi (x : A), B x)"); } } else { throw exception(sstream() << "invalid congruence rule, '" << n << "' left-hand-side is not an application nor a binding"); } buffer<expr> congr_hyps; lean_assert(metas.size() == explicit_args.size()); for (unsigned i = 0; i < metas.size(); i++) { expr const & mvar = metas[i]; if (explicit_args[i] && !found_mvars.contains(mlocal_name(mvar))) { buffer<expr> locals; expr type = mlocal_type(mvar); while (is_pi(type)) { expr local = mk_local(tc.mk_fresh_name(), binding_domain(type)); locals.push_back(local); type = instantiate(binding_body(type), local); } expr h_rel, h_lhs, h_rhs; if (!is_simp_relation(env, type, h_rel, h_lhs, h_rhs) || !is_constant(h_rel)) continue; unsigned j = 0; for (expr const & local : locals) { j++; if (!only_found_mvars(mlocal_type(local), found_mvars)) { throw exception(sstream() << "invalid congruence rule, '" << n << "' argument #" << j << " of parameter #" << (i+1) << " contains " << "unresolved parameters"); } } if (!only_found_mvars(h_lhs, found_mvars)) { throw exception(sstream() << "invalid congruence rule, '" << n << "' argument #" << (i+1) << " is not a valid hypothesis, the left-hand-side contains " << "unresolved parameters"); } if (!is_valid_congr_hyp_rhs(h_rhs, found_mvars)) { throw exception(sstream() << "invalid congruence rule, '" << n << "' argument #" << (i+1) << " is not a valid hypothesis, the right-hand-side must be " << "of the form (m l_1 ... l_n) where m is parameter that was not " << "'assigned/resolved' yet and l_i's are locals"); } found_mvars.insert(mlocal_name(mvar)); congr_hyps.push_back(mvar); } } congr_rule rule(n, ls, to_list(metas), lhs, rhs, pr, to_list(congr_hyps)); s.insert(const_name(rel), rule); }
environment mk_projections(environment const & env, name const & n, buffer<name> const & proj_names, implicit_infer_kind infer_k, bool inst_implicit) { // Given an inductive datatype C A (where A represent parameters) // intro : Pi A (x_1 : B_1[A]) (x_2 : B_2[A, x_1]) ..., C A // // we generate projections of the form // proj_i A (c : C A) : B_i[A, (proj_1 A n), ..., (proj_{i-1} A n)] // C.rec A (fun (x : C A), B_i[A, ...]) (fun (x_1 ... x_n), x_i) c auto p = get_nparam_intro_rule(env, n); name_generator ngen; unsigned nparams = p.first; inductive::intro_rule intro = p.second; expr intro_type = inductive::intro_rule_type(intro); name rec_name = inductive::get_elim_name(n); declaration ind_decl = env.get(n); if (env.impredicative() && is_prop(ind_decl.get_type())) throw exception(sstream() << "projection generation, '" << n << "' is a proposition"); declaration rec_decl = env.get(rec_name); level_param_names lvl_params = ind_decl.get_univ_params(); levels lvls = param_names_to_levels(lvl_params); buffer<expr> params; // datatype parameters for (unsigned i = 0; i < nparams; i++) { if (!is_pi(intro_type)) throw_ill_formed(n); expr param = mk_local(ngen.next(), binding_name(intro_type), binding_domain(intro_type), binder_info()); intro_type = instantiate(binding_body(intro_type), param); params.push_back(param); } expr C_A = mk_app(mk_constant(n, lvls), params); binder_info c_bi = inst_implicit ? mk_inst_implicit_binder_info() : binder_info(); expr c = mk_local(ngen.next(), name("c"), C_A, c_bi); buffer<expr> intro_type_args; // arguments that are not parameters expr it = intro_type; while (is_pi(it)) { expr local = mk_local(ngen.next(), binding_name(it), binding_domain(it), binding_info(it)); intro_type_args.push_back(local); it = instantiate(binding_body(it), local); } buffer<expr> projs; // projections generated so far unsigned i = 0; environment new_env = env; for (name const & proj_name : proj_names) { if (!is_pi(intro_type)) throw exception(sstream() << "generating projection '" << proj_name << "', '" << n << "' does not have sufficient data"); expr result_type = binding_domain(intro_type); buffer<expr> proj_args; proj_args.append(params); proj_args.push_back(c); expr type_former = Fun(c, result_type); expr minor_premise = Fun(intro_type_args, mk_var(intro_type_args.size() - i - 1)); expr major_premise = c; type_checker tc(new_env); level l = sort_level(tc.ensure_sort(tc.infer(result_type).first).first); levels rec_lvls = append(to_list(l), lvls); expr rec = mk_constant(rec_name, rec_lvls); buffer<expr> rec_args; rec_args.append(params); rec_args.push_back(type_former); rec_args.push_back(minor_premise); rec_args.push_back(major_premise); expr rec_app = mk_app(rec, rec_args); expr proj_type = Pi(proj_args, result_type); proj_type = infer_implicit_params(proj_type, nparams, infer_k); expr proj_val = Fun(proj_args, rec_app); bool opaque = false; bool use_conv_opt = false; declaration new_d = mk_definition(env, proj_name, lvl_params, proj_type, proj_val, opaque, rec_decl.get_module_idx(), use_conv_opt); new_env = module::add(new_env, check(new_env, new_d)); new_env = set_reducible(new_env, proj_name, reducible_status::Reducible); new_env = add_unfold_c_hint(new_env, proj_name, nparams); new_env = save_projection_info(new_env, proj_name, inductive::intro_rule_name(intro), nparams, i, inst_implicit); expr proj = mk_app(mk_app(mk_constant(proj_name, lvls), params), c); intro_type = instantiate(binding_body(intro_type), proj); i++; } return new_env; }
environment mk_no_confusion(environment const & env, name const & n) { optional<environment> env1 = mk_no_confusion_type(env, n); if (!env1) return env; environment new_env = *env1; type_checker tc(new_env); inductive::inductive_decls decls = *inductive::is_inductive_decl(new_env, n); unsigned nparams = std::get<1>(decls); name_generator ngen; declaration no_confusion_type_decl = new_env.get(name{n, "no_confusion_type"}); declaration cases_decl = new_env.get(name(n, "cases_on")); level_param_names lps = no_confusion_type_decl.get_univ_params(); levels ls = param_names_to_levels(lps); expr no_confusion_type_type = instantiate_type_univ_params(no_confusion_type_decl, ls); name eq_name("eq"); name heq_name("heq"); name eq_refl_name{"eq", "refl"}; name heq_refl_name{"heq", "refl"}; buffer<expr> args; expr type = no_confusion_type_type; type = to_telescope(ngen, type, args, some(mk_implicit_binder_info())); lean_assert(args.size() >= nparams + 3); unsigned nindices = args.size() - nparams - 3; // 3 is for P v1 v2 expr range = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), args); expr P = args[args.size()-3]; expr v1 = args[args.size()-2]; expr v2 = args[args.size()-1]; expr v_type = mlocal_type(v1); level v_lvl = sort_level(tc.ensure_type(v_type).first); expr eq_v = mk_app(mk_constant(eq_name, to_list(v_lvl)), v_type); expr H12 = mk_local(ngen.next(), "H12", mk_app(eq_v, v1, v2), binder_info()); args.push_back(H12); name no_confusion_name{n, "no_confusion"}; expr no_confusion_ty = Pi(args, range); // The gen proof is of the form // (fun H11 : v1 = v1, cases_on Params (fun Indices v1, no_confusion_type Params Indices P v1 v1) Indices v1 // <for-each case> // (fun H : (equations -> P), H (refl) ... (refl)) // ... // ) // H11 is for creating the generalization expr H11 = mk_local(ngen.next(), "H11", mk_app(eq_v, v1, v1), binder_info()); // Create the type former (fun Indices v1, no_confusion_type Params Indices P v1 v1) buffer<expr> type_former_args; for (unsigned i = nparams; i < nparams + nindices; i++) type_former_args.push_back(args[i]); type_former_args.push_back(v1); buffer<expr> no_confusion_type_args; for (unsigned i = 0; i < nparams + nindices; i++) no_confusion_type_args.push_back(args[i]); no_confusion_type_args.push_back(P); no_confusion_type_args.push_back(v1); no_confusion_type_args.push_back(v1); expr no_confusion_type_app = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), no_confusion_type_args); expr type_former = Fun(type_former_args, no_confusion_type_app); // create cases_on levels clvls = ls; expr cases_on = mk_app(mk_app(mk_constant(cases_decl.get_name(), clvls), nparams, args.data()), type_former); cases_on = mk_app(mk_app(cases_on, nindices, args.data() + nparams), v1); expr cot = tc.infer(cases_on).first; while (is_pi(cot)) { buffer<expr> minor_args; expr minor = to_telescope(tc, binding_domain(cot), minor_args); lean_assert(!minor_args.empty()); expr H = minor_args.back(); expr Ht = mlocal_type(H); buffer<expr> refl_args; while (is_pi(Ht)) { buffer<expr> eq_args; expr eq_fn = get_app_args(binding_domain(Ht), eq_args); if (const_name(eq_fn) == eq_name) { refl_args.push_back(mk_app(mk_constant(eq_refl_name, const_levels(eq_fn)), eq_args[0], eq_args[1])); } else { refl_args.push_back(mk_app(mk_constant(heq_refl_name, const_levels(eq_fn)), eq_args[0], eq_args[1])); } Ht = binding_body(Ht); } expr pr = mk_app(H, refl_args); cases_on = mk_app(cases_on, Fun(minor_args, pr)); cot = binding_body(cot); } expr gen = Fun(H11, cases_on); // Now, we use gen to build the final proof using eq.rec // // eq.rec InductiveType v1 (fun (a : InductiveType), v1 = a -> no_confusion_type Params Indices v1 a) gen v2 H12 H12 // name eq_rec_name{"eq", "rec"}; expr eq_rec = mk_app(mk_constant(eq_rec_name, {head(ls), v_lvl}), v_type, v1); // create eq_rec type_former // (fun (a : InductiveType), v1 = a -> no_confusion_type Params Indices v1 a) expr a = mk_local(ngen.next(), "a", v_type, binder_info()); expr H1a = mk_local(ngen.next(), "H1a", mk_app(eq_v, v1, a), binder_info()); // reusing no_confusion_type_args... we just replace the last argument with a no_confusion_type_args.pop_back(); no_confusion_type_args.push_back(a); expr no_confusion_type_app_1a = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), no_confusion_type_args); expr rec_type_former = Fun(a, Pi(H1a, no_confusion_type_app_1a)); // finalize eq_rec eq_rec = mk_app(mk_app(eq_rec, rec_type_former, gen, v2, H12), H12); // expr no_confusion_val = Fun(args, eq_rec); bool opaque = false; bool use_conv_opt = true; declaration new_d = mk_definition(new_env, no_confusion_name, lps, no_confusion_ty, no_confusion_val, opaque, no_confusion_type_decl.get_module_idx(), use_conv_opt); new_env = module::add(new_env, check(new_env, new_d)); return add_protected(new_env, no_confusion_name); }
optional<environment> mk_no_confusion_type(environment const & env, name const & n) { optional<inductive::inductive_decls> decls = inductive::is_inductive_decl(env, n); if (!decls) throw exception(sstream() << "error in 'no_confusion' generation, '" << n << "' is not an inductive datatype"); if (is_inductive_predicate(env, n)) return optional<environment>(); // type is a proposition name_generator ngen; unsigned nparams = std::get<1>(*decls); declaration ind_decl = env.get(n); declaration cases_decl = env.get(name(n, "cases_on")); level_param_names lps = cases_decl.get_univ_params(); level rlvl = mk_param_univ(head(lps)); levels ilvls = param_names_to_levels(tail(lps)); if (length(ilvls) != length(ind_decl.get_univ_params())) return optional<environment>(); // type does not have only a restricted eliminator expr ind_type = instantiate_type_univ_params(ind_decl, ilvls); name eq_name("eq"); name heq_name("heq"); // All inductive datatype parameters and indices are arguments buffer<expr> args; ind_type = to_telescope(ngen, ind_type, args, some(mk_implicit_binder_info())); if (!is_sort(ind_type) || args.size() < nparams) throw_corrupted(n); lean_assert(!(env.impredicative() && is_zero(sort_level(ind_type)))); unsigned nindices = args.size() - nparams; // Create inductive datatype expr I = mk_app(mk_constant(n, ilvls), args); // Add (P : Type) expr P = mk_local(ngen.next(), "P", mk_sort(rlvl), binder_info()); args.push_back(P); // add v1 and v2 elements of the inductive type expr v1 = mk_local(ngen.next(), "v1", I, binder_info()); expr v2 = mk_local(ngen.next(), "v2", I, binder_info()); args.push_back(v1); args.push_back(v2); expr R = mk_sort(rlvl); name no_confusion_type_name{n, "no_confusion_type"}; expr no_confusion_type_type = Pi(args, R); // Create type former buffer<expr> type_former_args; for (unsigned i = nparams; i < nparams + nindices; i++) type_former_args.push_back(args[i]); type_former_args.push_back(v1); expr type_former = Fun(type_former_args, R); // Create cases_on levels clvls = levels(mk_succ(rlvl), ilvls); expr cases_on = mk_app(mk_app(mk_constant(cases_decl.get_name(), clvls), nparams, args.data()), type_former); cases_on = mk_app(cases_on, nindices, args.data() + nparams); expr cases_on1 = mk_app(cases_on, v1); expr cases_on2 = mk_app(cases_on, v2); type_checker tc(env); expr t1 = tc.infer(cases_on1).first; expr t2 = tc.infer(cases_on2).first; buffer<expr> outer_cases_on_args; unsigned idx1 = 0; while (is_pi(t1)) { buffer<expr> minor1_args; expr minor1 = to_telescope(tc, binding_domain(t1), minor1_args); expr curr_t2 = t2; buffer<expr> inner_cases_on_args; unsigned idx2 = 0; while (is_pi(curr_t2)) { buffer<expr> minor2_args; expr minor2 = to_telescope(tc, binding_domain(curr_t2), minor2_args); if (idx1 != idx2) { // infeasible case, constructors do not match inner_cases_on_args.push_back(Fun(minor2_args, P)); } else { if (minor1_args.size() != minor2_args.size()) throw_corrupted(n); buffer<expr> rtype_hyp; // add equalities for (unsigned i = 0; i < minor1_args.size(); i++) { expr lhs = minor1_args[i]; expr rhs = minor2_args[i]; expr lhs_type = mlocal_type(lhs); expr rhs_type = mlocal_type(rhs); level l = sort_level(tc.ensure_type(lhs_type).first); expr h_type; if (tc.is_def_eq(lhs_type, rhs_type).first) { h_type = mk_app(mk_constant(eq_name, to_list(l)), lhs_type, lhs, rhs); } else { h_type = mk_app(mk_constant(heq_name, to_list(l)), lhs_type, lhs, rhs_type, rhs); } rtype_hyp.push_back(mk_local(ngen.next(), local_pp_name(lhs).append_after("_eq"), h_type, binder_info())); } inner_cases_on_args.push_back(Fun(minor2_args, mk_arrow(Pi(rtype_hyp, P), P))); } idx2++; curr_t2 = binding_body(curr_t2); } outer_cases_on_args.push_back(Fun(minor1_args, mk_app(cases_on2, inner_cases_on_args))); idx1++; t1 = binding_body(t1); } expr no_confusion_type_value = Fun(args, mk_app(cases_on1, outer_cases_on_args)); bool opaque = false; bool use_conv_opt = true; declaration new_d = mk_definition(env, no_confusion_type_name, lps, no_confusion_type_type, no_confusion_type_value, opaque, ind_decl.get_module_idx(), use_conv_opt); environment new_env = module::add(env, check(env, new_d)); return some(add_protected(new_env, no_confusion_type_name)); }