Beispiel #1
0
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);
}
Beispiel #2
0
json serialize_decl(name const & short_name, name const & long_name, environment const & env, options const & o) {
    declaration const & d = env.get(long_name);
    type_context_old tc(env);
    auto fmter = mk_pretty_formatter_factory()(env, o, tc);
    expr type = d.get_type();
    if (LEAN_COMPLETE_CONSUME_IMPLICIT) {
        while (true) {
            if (!is_pi(type))
                break;
            if (!binding_info(type).is_implicit() && !binding_info(type).is_inst_implicit())
                break;
            std::string q("?");
            q += binding_name(type).to_string();
            expr m = mk_constant(name(q.c_str()));
            type   = instantiate(binding_body(type), m);
        }
    }
    json completion;
    completion["text"] = short_name.to_string();
    interactive_report_type(env, o, type, completion);
    add_source_info(env, long_name, completion);
    if (auto doc = get_doc_string(env, long_name))
        completion["doc"] = *doc;
    return completion;
}
static optional<pair<expr, expr>> mk_op(environment const & env, old_local_context & ctx, type_checker_ptr & tc,
                                        name const & op, unsigned nunivs, unsigned nargs, std::initializer_list<expr> const & explicit_args,
                                        constraint_seq & cs, tag g) {
    levels lvls;
    for (unsigned i = 0; i < nunivs; i++)
        lvls = levels(mk_meta_univ(mk_fresh_name()), lvls);
    expr c = mk_constant(op, lvls);
    expr op_type = instantiate_type_univ_params(env.get(op), lvls);
    buffer<expr> args;
    for (unsigned i = 0; i < nargs; i++) {
        if (!is_pi(op_type))
            return optional<pair<expr, expr>>();
        expr arg = ctx.mk_meta(some_expr(binding_domain(op_type)), g);
        args.push_back(arg);
        op_type  = instantiate(binding_body(op_type), arg);
    }
    expr r = mk_app(c, args, g);
    for (expr const & explicit_arg : explicit_args) {
        if (!is_pi(op_type))
            return optional<pair<expr, expr>>();
        r = mk_app(r, explicit_arg);
        expr type = tc->infer(explicit_arg, cs);
        justification j = mk_app_justification(r, op_type, explicit_arg, type);
        if (!tc->is_def_eq(binding_domain(op_type), type, j, cs))
            return optional<pair<expr, expr>>();
        op_type  = instantiate(binding_body(op_type), explicit_arg);
    }
    return some(mk_pair(r, op_type));
}
Beispiel #4
0
 // 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)) {
         // TODO(dhs): keep name?
         expr local = m_tctx.mk_tmp_local(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_app(mk_constant(get_not_name()), c);
         expr Hc    = m_tctx.mk_tmp_local(c);
         expr Hnc   = m_tctx.mk_tmp_local(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) {
         expr new_e = m_tctx.whnf(e);
         if (new_e != e) {
             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()), e, H);
             return mk_singleton(new_e, new_H);
         } else {
             return list<expr_pair>();
         }
     } else {
         return list<expr_pair>();
     }
 }
action_result by_contradiction_action() {
    state &  s  = curr_state();
    expr target = whnf(s.get_target());
    if (!is_prop(target)) return action_result::failed();
    if (blast::is_false(target)) return action_result::failed();
    expr not_target;
    if (is_not(target, not_target)) {
        s.set_target(mk_arrow(not_target, mk_constant(get_false_name())));
        return intros_action(1);
    }
    blast_tmp_type_context tmp_tctx;
    optional<expr> target_decidable = tmp_tctx->mk_class_instance(mk_app(mk_constant(get_decidable_name()), target));
    if (!target_decidable) return action_result::failed();
    expr href = s.mk_hypothesis(get_app_builder().mk_not(target));
    auto pcell = new by_contradiction_proof_step_cell(href);
    s.push_proof_step(pcell);
    s.set_target(mk_constant(get_false_name()));
    trace_action("by_contradiction");
    return action_result::new_branch();
}
Beispiel #6
0
static simp_rule_sets add_core(type_checker & tc, simp_rule_sets const & s, name const & cname) {
    declaration const & d = tc.env().get(cname);
    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 e    = instantiate_type_univ_params(d, ls);
    expr h    = mk_constant(cname, ls);
    return add_core(tc, s, cname, ls, e, h);
}
Beispiel #7
0
void initialize_string() {
    g_string_macro    = new name("string_macro");
    g_string_opcode   = new std::string("Str");
    g_nat             = new expr(Const(get_nat_name()));
    g_char            = new expr(Const(get_char_name()));
    g_char_of_nat     = new expr(Const(get_char_of_nat_name()));
    g_string          = new expr(Const(get_string_name()));
    g_empty           = new expr(Const(get_string_empty_name()));
    g_str             = new expr(Const(get_string_str_name()));
    g_fin_mk          = new expr(Const(get_fin_mk_name()));
    g_list_char       = new expr(mk_app(mk_constant(get_list_name(), {mk_level_one()}), *g_char));
    g_list_cons       = new expr(mk_constant(get_list_cons_name(), {mk_level_one()}));
    g_list_nil_char   = new expr(mk_app(mk_constant(get_list_nil_name(), {mk_level_one()}), *g_char));
    register_macro_deserializer(*g_string_opcode,
    [](deserializer & d, unsigned num, expr const *) {
        if (num != 0)
            throw corrupted_stream_exception();
        std::string v = d.read_string();
        return mk_string_macro(v);
    });
}
Beispiel #8
0
expr gexpr::to_expr(type_context & ctx) const {
    if (m_univ_poly) {
        declaration const & fdecl = ctx.env().get(const_name(m_expr));
        buffer<level> ls_buffer;
        unsigned num_univ_ps = fdecl.get_num_univ_params();
        for (unsigned i = 0; i < num_univ_ps; i++)
            ls_buffer.push_back(ctx.mk_uvar());
        levels ls = to_list(ls_buffer.begin(), ls_buffer.end());
        return mk_constant(const_name(m_expr), ls);
    } else {
        return m_expr;
    }
}
Beispiel #9
0
expr copy(expr const & a) {
    switch (a.kind()) {
    case expr_kind::Var:      return mk_var(var_idx(a));
    case expr_kind::Constant: return mk_constant(const_name(a));
    case expr_kind::Type:     return mk_type(ty_level(a));
    case expr_kind::Value:    return mk_value(static_cast<expr_value*>(a.raw())->m_val);
    case expr_kind::App:      return mk_app(num_args(a), begin_args(a));
    case expr_kind::Eq:       return mk_eq(eq_lhs(a), eq_rhs(a));
    case expr_kind::Lambda:   return mk_lambda(abst_name(a), abst_domain(a), abst_body(a));
    case expr_kind::Pi:       return mk_pi(abst_name(a), abst_domain(a), abst_body(a));
    case expr_kind::Let:      return mk_let(let_name(a), let_type(a), let_value(a), let_body(a));
    case expr_kind::MetaVar:  return mk_metavar(metavar_idx(a), metavar_ctx(a));
    }
    lean_unreachable();
}
Beispiel #10
0
 optional<constraints> try_instance(name const & inst) {
     environment const & env = m_C->env();
     if (auto decl = env.find(inst)) {
         name_generator & ngen = m_C->m_ngen;
         buffer<level> ls_buffer;
         unsigned num_univ_ps = decl->get_num_univ_params();
         for (unsigned i = 0; i < num_univ_ps; i++)
             ls_buffer.push_back(mk_meta_univ(ngen.next()));
         levels ls = to_list(ls_buffer.begin(), ls_buffer.end());
         expr inst_cnst = copy_tag(m_meta, mk_constant(inst, ls));
         expr inst_type = instantiate_type_univ_params(*decl, ls);
         return try_instance(inst_cnst, inst_type);
     } else {
         return optional<constraints>();
     }
 }
Beispiel #11
0
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);
}
Beispiel #12
0
    expr visit_cases_on(name const & fn, buffer<expr> & args) {
        name const & I_name = fn.get_prefix();
        if (is_inductive_predicate(env(), I_name))
            throw exception(sstream() << "code generation failed, inductive predicate '" << I_name << "' is not supported");
        bool is_builtin = is_vm_builtin_function(fn);
        buffer<name> cnames;
        get_intro_rule_names(env(), I_name, cnames);
        lean_assert(args.size() >= cnames.size() + 1);
        if (args.size() > cnames.size() + 1)
            distribute_extra_args_over_minors(I_name, cnames, args);
        lean_assert(args.size() == cnames.size() + 1);
        /* Process major premise */
        args[0] = visit(args[0]);
        unsigned num_reachable = 0;
        optional<expr> reachable_case;
        /* Process minor premises */
        for (unsigned i = 0; i < cnames.size(); i++) {
            buffer<bool> rel_fields;
            get_constructor_info(cnames[i], rel_fields);
            auto p = visit_minor_premise(args[i+1], rel_fields);
            expr new_minor = p.first;
            if (i == 0 && has_trivial_structure(I_name, rel_fields)) {
                /* Optimization for an inductive datatype that has a single constructor with only one relevant field */
                return beta_reduce(mk_app(new_minor, args[0]));
            }
            args[i+1] = new_minor;
            if (!p.second) {
                num_reachable++;
                reachable_case = p.first;
            }
        }

        if (num_reachable == 0) {
            return mk_unreachable_expr();
        } else if (num_reachable == 1 && !is_builtin) {
            /* Use _cases.1 */
            return mk_app(mk_cases(1), args[0], *reachable_case);
        } else if (is_builtin) {
            return mk_app(mk_constant(fn), args);
        } else {
            return mk_app(mk_cases(cnames.size()), args);
        }
    }
Beispiel #13
0
 expr extract(expr const & e) {
     lean_assert(is_nested_declaration(e));
     expr const & d = visit(get_nested_declaration_arg(e));
     name new_name      = mk_name_for(e);
     name new_real_name = get_namespace(m_env) + new_name;
     collected_locals locals;
     collect_locals(d, locals);
     buffer<name> uparams;
     collect_univ_params(d).to_buffer(uparams);
     expr new_value           = Fun(locals.get_collected(), d);
     expr new_type            = m_tc.infer(new_value).first;
     level_param_names new_ps = to_list(uparams);
     levels ls                = param_names_to_levels(new_ps);
     m_env = module::add(m_env, check(m_env, mk_definition(m_env, new_real_name, new_ps,
                                                           new_type, new_value)));
     if (new_name != new_real_name)
         m_env = add_expr_alias_rec(m_env, new_name, new_real_name);
     decl_attributes const & attrs = get_nested_declaration_attributes(e);
     m_env = attrs.apply(m_env, m_ios, new_real_name, get_namespace(m_env));
     return mk_app(mk_constant(new_real_name, ls), locals.get_collected());
 }
Beispiel #14
0
 pair<environment, expr> operator()(name const & c, expr const & type, expr const & value, bool is_lemma, optional<bool> const & is_meta) {
     lean_assert(!is_lemma || is_meta);
     lean_assert(!is_lemma || *is_meta == false);
     expr new_type  = collect(m_ctx.instantiate_mvars(type));
     expr new_value = collect(m_ctx.instantiate_mvars(value));
     buffer<expr> norm_params;
     collect_and_normalize_dependencies(norm_params);
     new_type  = replace_locals(new_type, m_params, norm_params);
     new_value = replace_locals(new_value, m_params, norm_params);
     expr def_type  = m_ctx.mk_pi(norm_params, new_type);
     expr def_value = m_ctx.mk_lambda(norm_params, new_value);
     environment const & env = m_ctx.env();
     declaration d;
     if (is_lemma) {
         d = mk_theorem(c, to_list(m_level_params), def_type, def_value);
     } else if (is_meta) {
         bool use_self_opt = true;
         d = mk_definition(env, c, to_list(m_level_params), def_type, def_value, use_self_opt, !*is_meta);
     } else {
         bool use_self_opt = true;
         d = mk_definition_inferring_trusted(env, c, to_list(m_level_params), def_type, def_value, use_self_opt);
     }
     environment new_env = module::add(env, check(env, d, true));
     buffer<level> ls;
     for (name const & n : m_level_params) {
         if (level const * l = m_univ_meta_to_param_inv.find(n))
             ls.push_back(*l);
         else
             ls.push_back(mk_param_univ(n));
     }
     buffer<expr> ps;
     for (expr const & x : m_params) {
         if (expr const * m = m_meta_to_param_inv.find(mlocal_name(x)))
             ps.push_back(*m);
         else
             ps.push_back(x);
     }
     expr r = mk_app(mk_constant(c, to_list(ls)), ps);
     return mk_pair(new_env, r);
 }
Beispiel #15
0
 expr visit_constructor(name const & fn, buffer<expr> const & args) {
     bool is_builtin  = is_vm_builtin_function(fn);
     name I_name      = *inductive::is_intro_rule(env(), fn);
     unsigned nparams = *inductive::get_num_params(env(), I_name);
     unsigned cidx    = get_constructor_idx(env(), fn);
     buffer<bool> rel_fields;
     get_constructor_info(fn, rel_fields);
     lean_assert(args.size() == nparams + rel_fields.size());
     buffer<expr> new_args;
     for (unsigned i = 0; i < rel_fields.size(); i++) {
         if (rel_fields[i]) {
             new_args.push_back(visit(args[nparams + i]));
         }
     }
     if (has_trivial_structure(I_name, rel_fields)) {
         lean_assert(new_args.size() == 1);
         return new_args[0];
     } else if (is_builtin) {
         return mk_app(mk_constant(fn), new_args);
     } else {
         return mk_app(mk_cnstr(cidx), new_args);
     }
 }
Beispiel #16
0
optional<expr> mk_hset_instance(type_checker & tc, io_state const & ios, list<expr> const & ctx, expr const & type) {
    expr trunc_index = mk_app(mk_constant(get_is_trunc_trunc_index_of_nat_name()), mk_constant(get_nat_zero_name()));
    level lvl        = sort_level(tc.ensure_type(type).first);
    expr is_hset     = mk_app(mk_constant(get_is_trunc_name(), {lvl}), trunc_index, type);
    return mk_class_instance(tc.env(), ios, ctx, tc.mk_fresh_name(), is_hset);
}
Beispiel #17
0
struct pnode *make_constant_list(int value1, int value2)
{
  return mk_list(mk_constant(value1), mk_list(mk_constant(value2), NULL));
}
Beispiel #18
0
void initialize_expr() {
    g_dummy        = new expr(mk_constant("__expr_for_default_constructor__"));
    g_default_name = new name("a");
    g_Type1        = new expr(mk_sort(mk_level_one()));
    g_Prop         = new expr(mk_sort(mk_level_zero()));
}
Beispiel #19
0
static expr mk_proj(unsigned idx) {
    return mk_constant(name(*g_proj, idx));
}
Beispiel #20
0
static expr mk_cases(unsigned n) {
    return mk_constant(name(*g_cases, n));
}
Beispiel #21
0
expr update_constant(expr const & e, levels const & new_levels) {
    if (!is_eqp(const_levels(e), new_levels))
        return mk_constant(const_name(e), new_levels, e.get_tag());
    else
        return e;
}
Beispiel #22
0
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;
}
Beispiel #23
0
tactic contradiction_tactic() {
    auto fn = [=](environment const & env, io_state const & ios, proof_state const & s) {
        goals const & gs = s.get_goals();
        if (empty(gs)) {
            throw_no_goal_if_enabled(s);
            return optional<proof_state>();
        }
        goal const & g      = head(gs);
        expr const & t      = g.get_type();
        substitution subst  = s.get_subst();
        auto tc             = mk_type_checker(env);
        auto conserv_tc     = mk_type_checker(env, UnfoldReducible);
        buffer<expr> hyps;
        g.get_hyps(hyps);
        for (expr const & h : hyps) {
            expr h_type = mlocal_type(h);
            h_type      = tc->whnf(h_type).first;
            expr lhs, rhs, arg;
            if (is_false(env, h_type)) {
                assign(subst, g, mk_false_rec(*tc, h, t));
                return some_proof_state(proof_state(s, tail(gs), subst));
            } else if (is_not(env, h_type, arg)) {
                optional<expr> h_pos;
                for (expr const & h_prime : hyps) {
                    constraint_seq cs;
                    if (conserv_tc->is_def_eq(arg, mlocal_type(h_prime), justification(), cs) && !cs) {
                        h_pos = h_prime;
                        break;
                    }
                }
                if (h_pos) {
                    assign(subst, g, mk_absurd(*tc, t, *h_pos, h));
                    return some_proof_state(proof_state(s, tail(gs), subst));
                }
            } else if (is_eq(h_type, lhs, rhs)) {
                lhs = tc->whnf(lhs).first;
                rhs = tc->whnf(rhs).first;
                optional<name> lhs_c = is_constructor_app(env, lhs);
                optional<name> rhs_c = is_constructor_app(env, rhs);
                if (lhs_c && rhs_c && *lhs_c != *rhs_c) {
                    if (optional<name> I_name = inductive::is_intro_rule(env, *lhs_c)) {
                        name no_confusion(*I_name, "no_confusion");
                        try {
                            expr I      = tc->whnf(tc->infer(lhs).first).first;
                            buffer<expr> args;
                            expr I_fn   = get_app_args(I, args);
                            if (is_constant(I_fn)) {
                                level t_lvl = sort_level(tc->ensure_type(t).first);
                                expr V = mk_app(mk_app(mk_constant(no_confusion, cons(t_lvl, const_levels(I_fn))), args),
                                                t, lhs, rhs, h);
                                if (auto r = lift_down_if_hott(*tc, V)) {
                                    check_term(*tc, *r);
                                    assign(subst, g, *r);
                                    return some_proof_state(proof_state(s, tail(gs), subst));
                                }
                            }
                        } catch (kernel_exception & ex) {
                            regular(env, ios) << ex << "\n";
                        }
                    }
                }
            }
        }
        return none_proof_state();
    };
    return tactic01(fn);
}
Beispiel #24
0
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);
}
Beispiel #25
0
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);
}
Beispiel #26
0
static expr mk_cnstr(unsigned cidx) {
    return mk_constant(name(*g_cnstr, cidx));
}
Beispiel #27
0
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);
}
Beispiel #28
0
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));
}
Beispiel #29
0
static environment mk_below(environment const & env, name const & n, bool ibelow) {
    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));
    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_param_names blvls; // universe level parameters of ibelow/below
    level  rlvl;  // universe level of the resultant type
    // The arguments of below (ibelow) 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;
    expr Type_result;
    if (ibelow) {
        // we are eliminating to Prop
        blvls      = tail(lps);
        rlvl       = mk_level_zero();
        ref_type   = instantiate_univ_param(rec_decl.get_type(), param_id(lvl), mk_level_zero());
    } else if (is_reflexive) {
        blvls = lps;
        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);
        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
        blvls       = lps;
        rlvl        = mk_max(mk_level_one(), lvl);
        ref_type    = rec_decl.get_type();
    }
    Type_result        = mk_sort(rlvl);
    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 below/ibelow 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]));
    }
    // we ignore minor premises in below/ibelow
    for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++)
        args.push_back(ref_args[i]);

    // We define below/ibelow using the recursor for this type
    levels rec_lvls       = cons(mk_succ(rlvl), lvls);
    expr rec              = mk_constant(rec_decl.get_name(), rec_lvls);
    for (unsigned i = 0; i < nparams; i++)
        rec = mk_app(rec, args[i]);
    // add type formers
    for (unsigned i = nparams; i < nparams + ntypeformers; i++) {
        buffer<expr> targs;
        to_telescope(ngen, mlocal_type(args[i]), targs);
        rec = mk_app(rec, Fun(targs, Type_result));
    }
    // add minor premises
    for (unsigned i = nparams + ntypeformers; i < nparams + ntypeformers + nminors; i++) {
        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> prod_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 (is_typeformer_app(typeformer_names, minor_arg_type)) {
                expr fst  = mlocal_type(minor_arg);
                minor_arg = update_mlocal(minor_arg, Pi(minor_arg_args, Type_result));
                expr snd = Pi(minor_arg_args, mk_app(minor_arg, minor_arg_args));
                prod_pairs.push_back(mk_prod(tc, fst, snd, ibelow));
            }
        }
        expr new_arg = foldr([&](expr const & a, expr const & b) { return mk_prod(tc, a, b, ibelow); },
                             [&]() { return mk_unit(rlvl, ibelow); },
                             prod_pairs.size(), prod_pairs.data());
        rec = mk_app(rec, Fun(minor_args, new_arg));
    }

    // add indices and major premise
    for (unsigned i = nparams + ntypeformers; i < args.size(); i++) {
        rec = mk_app(rec, args[i]);
    }

    name below_name  = ibelow ? name{n, "ibelow"} : name{n, "below"};
    expr below_type  = Pi(args, Type_result);
    expr below_value = Fun(args, rec);

    bool use_conv_opt = true;
    declaration new_d = mk_definition(env, below_name, blvls, below_type, below_value,
                                      use_conv_opt);
    environment new_env = module::add(env, check(env, new_d));
    new_env = set_reducible(new_env, below_name, reducible_status::Reducible);
    if (!ibelow)
        new_env = add_unfold_hint(new_env, below_name, nparams + nindices + ntypeformers);
    return add_protected(new_env, below_name);
}
Beispiel #30
0
struct pnode *add_symbol_constant(struct pnode *parms, int value)
{
  return mk_list(HEAD(parms), mk_list(mk_constant(value), NULL));
}