diff --git a/hott/init/tactic.hlean b/hott/init/tactic.hlean index 42d8b8221..9ee30d92c 100644 --- a/hott/init/tactic.hlean +++ b/hott/init/tactic.hlean @@ -42,6 +42,7 @@ opaque definition id : tactic := builtin opaque definition beta : tactic := builtin opaque definition info : tactic := builtin opaque definition whnf : tactic := builtin +opaque definition contradiction : tactic := builtin opaque definition rotate_left (k : num) := builtin opaque definition rotate_right (k : num) := builtin definition rotate (k : num) := rotate_left k diff --git a/library/init/tactic.lean b/library/init/tactic.lean index de1a049a0..685bfb58f 100644 --- a/library/init/tactic.lean +++ b/library/init/tactic.lean @@ -42,6 +42,7 @@ opaque definition id : tactic := builtin opaque definition beta : tactic := builtin opaque definition info : tactic := builtin opaque definition whnf : tactic := builtin +opaque definition contradiction : tactic := builtin opaque definition rotate_left (k : num) := builtin opaque definition rotate_right (k : num) := builtin definition rotate (k : num) := rotate_left k diff --git a/src/emacs/lean-syntax.el b/src/emacs/lean-syntax.el index a6dc5178a..7a05882d7 100644 --- a/src/emacs/lean-syntax.el +++ b/src/emacs/lean-syntax.el @@ -135,7 +135,7 @@ "apply" "fapply" "rename" "intro" "intros" "all_goals" "fold" "generalize" "generalizes" "clear" "clears" "revert" "reverts" "back" "beta" "done" "exact" "rexact" "refine" "repeat" "whnf" "rotate" "rotate_left" "rotate_right" "inversion" "cases" "rewrite" "esimp" - "unfold" "change" "check_expr")) + "unfold" "change" "check_expr" "contradiction")) word-end) (1 'font-lock-constant-face)) ;; Types diff --git a/src/library/constants.cpp b/src/library/constants.cpp index 0127b3769..4c738bff8 100644 --- a/src/library/constants.cpp +++ b/src/library/constants.cpp @@ -14,6 +14,8 @@ name const * g_bool_tt = nullptr; name const * g_char = nullptr; name const * g_char_mk = nullptr; name const * g_dite = nullptr; +name const * g_empty = nullptr; +name const * g_empty_rec = nullptr; name const * g_eq = nullptr; name const * g_eq_elim_inv_inv = nullptr; name const * g_eq_intro = nullptr; @@ -24,6 +26,7 @@ name const * g_eq_symm = nullptr; name const * g_eq_trans = nullptr; name const * g_exists_elim = nullptr; name const * g_false = nullptr; +name const * g_false_rec = nullptr; name const * g_heq = nullptr; name const * g_heq_refl = nullptr; name const * g_heq_to_eq = nullptr; @@ -133,6 +136,8 @@ void initialize_constants() { g_char = new name{"char"}; g_char_mk = new name{"char", "mk"}; g_dite = new name{"dite"}; + g_empty = new name{"empty"}; + g_empty_rec = new name{"empty", "rec"}; g_eq = new name{"eq"}; g_eq_elim_inv_inv = new name{"eq", "elim_inv_inv"}; g_eq_intro = new name{"eq", "intro"}; @@ -143,6 +148,7 @@ void initialize_constants() { g_eq_trans = new name{"eq", "trans"}; g_exists_elim = new name{"exists", "elim"}; g_false = new name{"false"}; + g_false_rec = new name{"false", "rec"}; g_heq = new name{"heq"}; g_heq_refl = new name{"heq", "refl"}; g_heq_to_eq = new name{"heq", "to_eq"}; @@ -253,6 +259,8 @@ void finalize_constants() { delete g_char; delete g_char_mk; delete g_dite; + delete g_empty; + delete g_empty_rec; delete g_eq; delete g_eq_elim_inv_inv; delete g_eq_intro; @@ -263,6 +271,7 @@ void finalize_constants() { delete g_eq_trans; delete g_exists_elim; delete g_false; + delete g_false_rec; delete g_heq; delete g_heq_refl; delete g_heq_to_eq; @@ -372,6 +381,8 @@ name const & get_bool_tt_name() { return *g_bool_tt; } name const & get_char_name() { return *g_char; } name const & get_char_mk_name() { return *g_char_mk; } name const & get_dite_name() { return *g_dite; } +name const & get_empty_name() { return *g_empty; } +name const & get_empty_rec_name() { return *g_empty_rec; } name const & get_eq_name() { return *g_eq; } name const & get_eq_elim_inv_inv_name() { return *g_eq_elim_inv_inv; } name const & get_eq_intro_name() { return *g_eq_intro; } @@ -382,6 +393,7 @@ name const & get_eq_symm_name() { return *g_eq_symm; } name const & get_eq_trans_name() { return *g_eq_trans; } name const & get_exists_elim_name() { return *g_exists_elim; } name const & get_false_name() { return *g_false; } +name const & get_false_rec_name() { return *g_false_rec; } name const & get_heq_name() { return *g_heq; } name const & get_heq_refl_name() { return *g_heq_refl; } name const & get_heq_to_eq_name() { return *g_heq_to_eq; } diff --git a/src/library/constants.h b/src/library/constants.h index bc1c7a964..842998427 100644 --- a/src/library/constants.h +++ b/src/library/constants.h @@ -16,6 +16,8 @@ name const & get_bool_tt_name(); name const & get_char_name(); name const & get_char_mk_name(); name const & get_dite_name(); +name const & get_empty_name(); +name const & get_empty_rec_name(); name const & get_eq_name(); name const & get_eq_elim_inv_inv_name(); name const & get_eq_intro_name(); @@ -26,6 +28,7 @@ name const & get_eq_symm_name(); name const & get_eq_trans_name(); name const & get_exists_elim_name(); name const & get_false_name(); +name const & get_false_rec_name(); name const & get_heq_name(); name const & get_heq_refl_name(); name const & get_heq_to_eq_name(); diff --git a/src/library/constants.txt b/src/library/constants.txt index b5b2266e6..a5f4703e1 100644 --- a/src/library/constants.txt +++ b/src/library/constants.txt @@ -9,6 +9,8 @@ bool.tt char char.mk dite +empty +empty.rec eq eq.elim_inv_inv eq.intro @@ -19,6 +21,7 @@ eq.symm eq.trans exists.elim false +false.rec heq heq.refl heq.to_eq diff --git a/src/library/tactic/CMakeLists.txt b/src/library/tactic/CMakeLists.txt index 18a024c23..f87ccfc19 100644 --- a/src/library/tactic/CMakeLists.txt +++ b/src/library/tactic/CMakeLists.txt @@ -4,6 +4,6 @@ exact_tactic.cpp generalize_tactic.cpp inversion_tactic.cpp whnf_tactic.cpp revert_tactic.cpp assert_tactic.cpp clear_tactic.cpp expr_to_tactic.cpp location.cpp rewrite_tactic.cpp util.cpp class_instance_synth.cpp init_module.cpp -change_tactic.cpp check_expr_tactic.cpp let_tactic.cpp) +change_tactic.cpp check_expr_tactic.cpp let_tactic.cpp contradiction_tactic.cpp) target_link_libraries(tactic ${LEAN_LIBS}) diff --git a/src/library/tactic/contradiction_tactic.cpp b/src/library/tactic/contradiction_tactic.cpp new file mode 100644 index 000000000..ae215f067 --- /dev/null +++ b/src/library/tactic/contradiction_tactic.cpp @@ -0,0 +1,80 @@ +/* +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura +*/ +#include "kernel/inductive/inductive.h" +#include "library/constants.h" +#include "library/util.h" +#include "library/reducible.h" +#include "library/tactic/intros_tactic.h" +#include "library/tactic/expr_to_tactic.h" +#include "kernel/kernel_exception.h" + +namespace lean { +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(); + } + goal const & g = head(gs); + expr const & t = g.get_type(); + substitution subst = s.get_subst(); + name_generator ngen = s.get_ngen(); + auto tc = mk_type_checker(env, ngen.mk_child(), s.relax_main_opaque()); + buffer 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; + 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, ngen)); + } else if (is_eq(h_type, lhs, rhs)) { + lhs = tc->whnf(lhs).first; + rhs = tc->whnf(rhs).first; + optional lhs_c = is_constructor_app(env, lhs); + optional rhs_c = is_constructor_app(env, rhs); + if (lhs_c && rhs_c && *lhs_c != *rhs_c) { + if (optional 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 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)) { + tc->check_ignore_undefined_universes(*r); + assign(subst, g, *r); + return some_proof_state(proof_state(s, tail(gs), subst, ngen)); + } + } + } catch (kernel_exception & ex) { + regular(env, ios) << ex << "\n"; + } + } + } + } + } + return none_proof_state(); + }; + return tactic01(fn); +} + +void initialize_contradiction_tactic() { + register_tac(name{"tactic", "contradiction"}, + [](type_checker &, elaborate_fn const &, expr const &, pos_info_provider const *) { + list empty; + return then(orelse(intros_tactic(empty), id_tactic()), contradiction_tactic()); + }); +} +void finalize_contradiction_tactic() { +} +} diff --git a/src/library/tactic/contradiction_tactic.h b/src/library/tactic/contradiction_tactic.h new file mode 100644 index 000000000..c21c85cb7 --- /dev/null +++ b/src/library/tactic/contradiction_tactic.h @@ -0,0 +1,11 @@ +/* +Copyright (c) 2015 Microsoft Corporation. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. + +Author: Leonardo de Moura +*/ +#pragma once +namespace lean { +void initialize_contradiction_tactic(); +void finalize_contradiction_tactic(); +} diff --git a/src/library/tactic/init_module.cpp b/src/library/tactic/init_module.cpp index b725f1484..0a47ce937 100644 --- a/src/library/tactic/init_module.cpp +++ b/src/library/tactic/init_module.cpp @@ -23,6 +23,7 @@ Author: Leonardo de Moura #include "library/tactic/change_tactic.h" #include "library/tactic/check_expr_tactic.h" #include "library/tactic/let_tactic.h" +#include "library/tactic/contradiction_tactic.h" namespace lean { void initialize_tactic_module() { @@ -45,9 +46,11 @@ void initialize_tactic_module() { initialize_change_tactic(); initialize_check_expr_tactic(); initialize_let_tactic(); + initialize_contradiction_tactic(); } void finalize_tactic_module() { + finalize_contradiction_tactic(); finalize_let_tactic(); finalize_check_expr_tactic(); finalize_change_tactic(); diff --git a/src/library/tactic/intros_tactic.cpp b/src/library/tactic/intros_tactic.cpp index 3cd0969e6..d09c97fef 100644 --- a/src/library/tactic/intros_tactic.cpp +++ b/src/library/tactic/intros_tactic.cpp @@ -11,7 +11,7 @@ Author: Leonardo de Moura #include "library/tactic/expr_to_tactic.h" namespace lean { -tactic intros_tactic(list _ns, bool relax_main_opaque) { +tactic intros_tactic(list _ns) { auto fn = [=](environment const & env, io_state const &, proof_state const & s) { list ns = _ns; goals const & gs = s.get_goals(); @@ -21,7 +21,7 @@ tactic intros_tactic(list _ns, bool relax_main_opaque) { } goal const & g = head(gs); name_generator ngen = s.get_ngen(); - auto tc = mk_type_checker(env, ngen.mk_child(), relax_main_opaque); + auto tc = mk_type_checker(env, ngen.mk_child(), s.relax_main_opaque()); expr t = g.get_type(); expr m = g.get_meta(); bool gen_names = empty(ns); diff --git a/src/library/tactic/intros_tactic.h b/src/library/tactic/intros_tactic.h index 16b1bbcb5..83d5da17b 100644 --- a/src/library/tactic/intros_tactic.h +++ b/src/library/tactic/intros_tactic.h @@ -7,7 +7,7 @@ Author: Leonardo de Moura #pragma once #include "library/tactic/tactic.h" namespace lean { -tactic intros_tactic(list ns, bool relax_main_opaque = true); +tactic intros_tactic(list ns); void initialize_intros_tactic(); void finalize_intros_tactic(); } diff --git a/src/library/tactic/inversion_tactic.cpp b/src/library/tactic/inversion_tactic.cpp index a2cd0629d..b9dd010d3 100644 --- a/src/library/tactic/inversion_tactic.cpp +++ b/src/library/tactic/inversion_tactic.cpp @@ -507,7 +507,7 @@ class inversion_tac { throw inversion_exception(); } - void throw_lift_down_failure() { + [[ noreturn ]] void throw_lift_down_failure() { if (m_throw_tactic_exception) throw tactic_exception("invalid 'cases' tactic, lift.down failed"); else @@ -664,19 +664,10 @@ class inversion_tac { We must apply lift.down to eliminate the auxiliary lift. */ expr lift_down(expr const & v) { - if (!m_proof_irrel) { - expr v_type = whnf(infer_type(v)); - if (!is_app(v_type)) { - throw_lift_down_failure(); - } - expr const & lift = app_fn(v_type); - if (!is_constant(lift) || const_name(lift) != get_lift_name()) { - throw_lift_down_failure(); - } - return mk_app(mk_constant(get_lift_down_name(), const_levels(lift)), app_arg(v_type), v); - } else { - return v; - } + if (auto r = lift_down_if_hott(m_tc, v)) + return *r; + else + throw_lift_down_failure(); } buffer m_c_args; // current intro/constructor args that may be renamed by unify_eqs diff --git a/src/library/util.cpp b/src/library/util.cpp index 66520dea4..f46939eba 100644 --- a/src/library/util.cpp +++ b/src/library/util.cpp @@ -15,6 +15,10 @@ Author: Leonardo de Moura #include "library/constants.h" namespace lean { +bool is_standard(environment const & env) { + return env.prop_proof_irrel() && env.impredicative(); +} + bool is_def_app(environment const & env, expr const & e) { if (!is_app(e)) return false; @@ -151,8 +155,8 @@ level get_datatype_level(expr ind_type) { } bool is_inductive_predicate(environment const & env, name const & n) { - if (!env.impredicative()) - return false; // environment does not have Prop + if (!is_standard(env)) + return false; if (!inductive::is_inductive_decl(env, n)) return false; // n is not inductive datatype return is_zero(get_datatype_level(env.get(n).get_type())); @@ -240,6 +244,43 @@ expr to_telescope(type_checker & tc, expr type, buffer & telescope, option return to_telescope(tc, type, telescope, binfo, cs); } +bool is_false(expr const & e) { + return is_constant(e) && const_name(e) == get_false_name(); +} + +bool is_empty(expr const & e) { + return is_constant(e) && const_name(e) == get_empty_name(); +} + +bool is_false(environment const & env, expr const & e) { + return is_standard(env) ? is_false(e) : is_empty(e); +} + +expr mk_false_rec(type_checker & tc, expr const & f, expr const & t) { + level t_lvl = sort_level(tc.ensure_type(t).first); + if (is_standard(tc.env())) { + return mk_app(mk_constant(get_false_rec_name(), {t_lvl}), t, f); + } else { + expr f_type = tc.infer(f).first; + level f_lvl = sort_level(tc.ensure_type(f_type).first); + return mk_app(mk_constant(get_empty_rec_name(), {t_lvl, f_lvl}), mk_lambda("e", f_type, t), f); + } +} + +optional lift_down_if_hott(type_checker & tc, expr const & v) { + if (is_standard(tc.env())) { + return some_expr(v); + } else { + expr v_type = tc.whnf(tc.infer(v).first).first; + if (!is_app(v_type)) + return none_expr(); + expr const & lift = app_fn(v_type); + if (!is_constant(lift) || const_name(lift) != get_lift_name()) + return none_expr(); + return some_expr(mk_app(mk_constant(get_lift_down_name(), const_levels(lift)), app_arg(v_type), v)); + } +} + static expr * g_true = nullptr; static expr * g_true_intro = nullptr; static expr * g_and = nullptr; @@ -387,6 +428,14 @@ bool is_eq(expr const & e) { return is_constant(fn) && const_name(fn) == get_eq_name(); } +bool is_eq(expr const & e, expr & lhs, expr & rhs) { + if (!is_eq(e) || !is_app(app_fn(e))) + return false; + lhs = app_arg(app_fn(e)); + rhs = app_arg(e); + return true; +} + bool is_eq_a_a(expr const & e) { if (!is_eq(e)) return false; diff --git a/src/library/util.h b/src/library/util.h index ad97df721..e3e2c370c 100644 --- a/src/library/util.h +++ b/src/library/util.h @@ -26,6 +26,9 @@ optional unfold_app(environment const & env, expr const & e); */ optional dec_level(level const & l); +/** \brief Return true iff \c env has been configured with an impredicative and proof irrelevant Prop. */ +bool is_standard(environment const & env); + bool has_unit_decls(environment const & env); bool has_eq_decls(environment const & env); bool has_heq_decls(environment const & env); @@ -123,11 +126,20 @@ expr mk_pair(type_checker & tc, expr const & a, expr const & b, bool prop); expr mk_pr1(type_checker & tc, expr const & p, bool prop); expr mk_pr2(type_checker & tc, expr const & p, bool prop); + +bool is_false(expr const & e); +bool is_empty(expr const & e); +/** \brief Return true iff \c e is false (in standard mode) or empty (in HoTT) mode */ +bool is_false(environment const & env, expr const & e); +/** \brief Return an element of type t given an element \c f : false (in standard mode) and empty (in HoTT) mode */ +expr mk_false_rec(type_checker & tc, expr const & f, expr const & t); + expr mk_eq(type_checker & tc, expr const & lhs, expr const & rhs); expr mk_refl(type_checker & tc, expr const & a); expr mk_symm(type_checker & tc, expr const & H); bool is_eq_rec(expr const & e); bool is_eq(expr const & e); +bool is_eq(expr const & e, expr & lhs, expr & rhs); /** \brief Return true iff \c e is of the form (eq A a a) */ bool is_eq_a_a(expr const & e); /** \brief Return true iff \c e is of the form (eq A a a') where \c a and \c a' are definitionally equal */ @@ -137,6 +149,12 @@ bool is_iff(expr const & e); expr mk_iff(expr const & lhs, expr const & rhs); expr mk_iff_refl(expr const & a); +/** \brief If in HoTT mode, apply lift.down. + The no_confusion constructions uses lifts in the proof relevant version (aka HoTT mode). + We must apply lift.down to eliminate the auxiliary lift. +*/ +optional lift_down_if_hott(type_checker & tc, expr const & v); + /** \brief Create a telescope equality for HoTT library. This procedure assumes eq supports dependent elimination. For HoTT, we can't use heterogeneous equality. diff --git a/tests/lean/hott/contra1.hlean b/tests/lean/hott/contra1.hlean new file mode 100644 index 000000000..b39aa9a6c --- /dev/null +++ b/tests/lean/hott/contra1.hlean @@ -0,0 +1,16 @@ +example (a b : nat) (h : empty) : a = b := +by contradiction + +example : ∀ (a b : nat), empty → a = b := +by contradiction + +example : ∀ (a b : nat), 0 = 1 → a = b := +by contradiction + +definition id {A : Type} (a : A) := a + +example : ∀ (a b : nat), id empty → a = b := +by contradiction + +example : ∀ (a b : nat), id (0 = 1) → a = b := +by contradiction diff --git a/tests/lean/run/contra1.lean b/tests/lean/run/contra1.lean new file mode 100644 index 000000000..cd22b35f5 --- /dev/null +++ b/tests/lean/run/contra1.lean @@ -0,0 +1,16 @@ +example (a b : nat) (h : false) : a = b := +by contradiction + +example : ∀ (a b : nat), false → a = b := +by contradiction + +example : ∀ (a b : nat), 0 = 1 → a = b := +by contradiction + +definition id {A : Type} (a : A) := a + +example : ∀ (a b : nat), id false → a = b := +by contradiction + +example : ∀ (a b : nat), id (0 = 1) → a = b := +by contradiction