diff --git a/src/frontends/lean/lean_notation.cpp b/src/frontends/lean/lean_notation.cpp
index 272e45d55..f5fdc1a8f 100644
--- a/src/frontends/lean/lean_notation.cpp
+++ b/src/frontends/lean/lean_notation.cpp
@@ -75,12 +75,15 @@ void init_builtin_notation(frontend & f) {
f.add_coercion(mk_nat_to_real_fn());
// implicit arguments for builtin axioms
+ f.mark_implicit_arguments(mk_cast_fn(), {true, true, false, false});
f.mark_implicit_arguments(mk_mp_fn(), {true, true, false, false});
f.mark_implicit_arguments(mk_discharge_fn(), {true, true, false});
f.mark_implicit_arguments(mk_refl_fn(), {true, false});
f.mark_implicit_arguments(mk_subst_fn(), {true, true, true, false, false, false});
f.mark_implicit_arguments(mk_eta_fn(), {true, true, false});
f.mark_implicit_arguments(mk_imp_antisym_fn(), {true, true, false, false});
+ f.mark_implicit_arguments(mk_dom_inj_fn(), {true, true, true, true, false});
+ f.mark_implicit_arguments(mk_ran_inj_fn(), {true, true, true, true, false, false});
// implicit arguments for basic theorems
f.mark_implicit_arguments(mk_absurd_fn(), {true, false, false});
diff --git a/src/frontends/lean/lean_pp.cpp b/src/frontends/lean/lean_pp.cpp
index a283d8660..f2311d9a0 100644
--- a/src/frontends/lean/lean_pp.cpp
+++ b/src/frontends/lean/lean_pp.cpp
@@ -1291,7 +1291,13 @@ formatter mk_pp_formatter(frontend const & fe) {
std::ostream & operator<<(std::ostream & out, frontend const & fe) {
options const & opts = fe.get_state().get_options();
formatter fmt = mk_pp_formatter(fe);
- out << mk_pair(fmt(fe, opts), opts);
+ bool first = true;
+ std::for_each(fe.begin_objects(),
+ fe.end_objects(),
+ [&](object const & obj) {
+ if (first) first = false; else out << "\n";
+ out << mk_pair(fmt(obj, opts), opts);
+ });
return out;
}
}
diff --git a/src/kernel/builtin.cpp b/src/kernel/builtin.cpp
index 3fdec1e74..33faba62a 100644
--- a/src/kernel/builtin.cpp
+++ b/src/kernel/builtin.cpp
@@ -149,6 +149,7 @@ MK_CONSTANT(not_fn, name("not"));
MK_CONSTANT(forall_fn, name("forall"));
MK_CONSTANT(exists_fn, name("exists"));
MK_CONSTANT(homo_eq_fn, name("heq"));
+MK_CONSTANT(cast_fn, name("cast"));
// Axioms
MK_CONSTANT(mp_fn, name("MP"));
@@ -158,6 +159,8 @@ MK_CONSTANT(case_fn, name("Case"));
MK_CONSTANT(subst_fn, name("Subst"));
MK_CONSTANT(eta_fn, name("Eta"));
MK_CONSTANT(imp_antisym_fn, name("ImpAntisym"));
+MK_CONSTANT(dom_inj_fn, name("DomInj"));
+MK_CONSTANT(ran_inj_fn, name("RanInj"));
void add_basic_theory(environment & env) {
env.add_uvar(uvar_name(m_lvl), level() + LEAN_DEFAULT_LEVEL_SEPARATION);
@@ -171,10 +174,13 @@ void add_basic_theory(environment & env) {
expr x = Const("x");
expr y = Const("y");
expr A = Const("A");
+ expr Ap = Const("A'");
expr A_pred = A >> Bool;
expr B = Const("B");
+ expr Bp = Const("B'");
expr q_type = Pi({A, TypeU}, A_pred >> Bool);
expr piABx = Pi({x, A}, B(x));
+ expr piApBpx = Pi({x, Ap}, Bp(x));
expr A_arrow_u = A >> TypeU;
expr P = Const("P");
expr H = Const("H");
@@ -209,6 +215,9 @@ void add_basic_theory(environment & env) {
// homogeneous equality
env.add_definition(homo_eq_fn_name, Pi({{A,TypeU},{x,A},{y,A}}, Bool), Fun({{A,TypeU}, {x,A}, {y,A}}, Eq(x, y)));
+ // Cast: Pi (A : Type u) (B : Type u) (H : A = B) (a : A), B
+ env.add_var(cast_fn_name, Pi({{A, TypeU}, {B, TypeU}, {H, Eq(A,B)}, {a, A}}, B));
+
// MP : Pi (a b : Bool) (H1 : a => b) (H2 : a), b
env.add_axiom(mp_fn_name, Pi({{a, Bool}, {b, Bool}, {H1, Implies(a, b)}, {H2, a}}, b));
@@ -229,5 +238,13 @@ void add_basic_theory(environment & env) {
// ImpliesAntisym : Pi (a b : Bool) (H1 : a => b) (H2 : b => a), a = b
env.add_axiom(imp_antisym_fn_name, Pi({{a, Bool}, {b, Bool}, {H1, Implies(a, b)}, {H2, Implies(b, a)}}, Eq(a, b)));
+
+ // DomInj : Pi (A A': Type u) (B : A -> Type u) (B' : A' -> Type u) (H : (Pi x : A, B x) = (Pi x : A', B' x)), A = A'
+ env.add_axiom(dom_inj_fn_name, Pi({{A, TypeU}, {Ap, TypeU}, {B, A >> TypeU}, {Bp, Ap >> TypeU}, {H, Eq(piABx, piApBpx)}}, Eq(A, Ap)));
+
+ // RanInj : Pi (A A': Type u) (B : A -> Type u) (B' : A' -> Type u) (H : (Pi x : A, B x) = (Pi x : A', B' x)) (a : A),
+ // B a = B' (cast A A' (DomInj A A' B B' H) a)
+ env.add_axiom(ran_inj_fn_name, Pi({{A, TypeU}, {Ap, TypeU}, {B, A >> TypeU}, {Bp, Ap >> TypeU}, {H, Eq(piABx, piApBpx)}, {a, A}},
+ Eq(B(a), Bp(Cast(A, Ap, DomInj(A, Ap, B, Bp, H), a)))));
}
}
diff --git a/src/kernel/builtin.h b/src/kernel/builtin.h
index 0aaf3db3f..afda22779 100644
--- a/src/kernel/builtin.h
+++ b/src/kernel/builtin.h
@@ -113,6 +113,12 @@ expr mk_homo_eq_fn();
inline expr mk_homo_eq(expr const & A, expr const & l, expr const & r) { return mk_app(mk_homo_eq_fn(), A, l, r); }
inline expr hEq(expr const & A, expr const & l, expr const & r) { return mk_homo_eq(A, l, r); }
+/** \brief Type Cast. It has type Pi (A : Type u) (B : Type u) (H : A = B) (a : A), B */
+expr mk_cast_fn();
+/** \brief Return the term (cast A B H a) */
+inline expr mk_cast(expr const & A, expr const & B, expr const & H, expr const & a) { return mk_app(mk_cast_fn(), A, B, H, a); }
+inline expr Cast(expr const & A, expr const & B, expr const & H, expr const & a) { return mk_cast(A, B, H, a); }
+
/** \brief Modus Ponens axiom */
expr mk_mp_fn();
/** \brief (Axiom) {a : Bool}, {b : Bool}, H1 : a => b, H2 : a |- MP(a, b, H1, H2) : b */
@@ -148,6 +154,20 @@ expr mk_imp_antisym_fn();
/** \brief (Axiom) {a : Bool}, {b : Bool}, H1 : a => b, H2 : b => a |- ImpAntisym(a, b, H1, H2) : a = b */
inline expr ImpAntisym(expr const & a, expr const & b, expr const & H1, expr const & H2) { return mk_app(mk_imp_antisym_fn(), a, b, H1, H2); }
+/** \brief Domain Injectivity. It has type Pi (A A': Type u) (B : A -> Type u) (B' : A' -> Type u) (H : (Pi x : A, B x) = (Pi x : A', B' x)), A = A' */
+expr mk_dom_inj_fn();
+/** \brief Return the term (DomInj A A' B B' H) */
+inline expr mk_dom_inj(expr const & A, expr const & Ap, expr const & B, expr const & Bp, expr const & H) { return mk_app({mk_dom_inj_fn(), A, Ap, B, Bp, H}); }
+inline expr DomInj(expr const & A, expr const & Ap, expr const & B, expr const & Bp, expr const & H) { return mk_dom_inj(A, Ap, B, Bp, H); }
+
+/** \brief Range Injectivity. It has type Pi (A A': Type u) (B : A -> Type u) (B' : A' -> Type u) (H : (Pi x : A, B x) = (Pi x : A', B' x)) (a : A),
+ B a = B' (cast A A' (DomInj A A' B B' H) a)
+*/
+expr mk_ran_inj_fn();
+/** \brief Return the term (RanInj A A' B B' H) */
+inline expr mk_ran_inj(expr const & A, expr const & Ap, expr const & B, expr const & Bp, expr const & H, expr const & a) { return mk_app({mk_ran_inj_fn(), A, Ap, B, Bp, H, a}); }
+inline expr RanInj(expr const & A, expr const & Ap, expr const & B, expr const & Bp, expr const & H, expr const & a) { return mk_ran_inj(A, Ap, B, Bp, H, a); }
+
class environment;
/** \brief Initialize the environment with basic builtin declarations and axioms */
void add_basic_theory(environment & env);
diff --git a/tests/lean/cast1.lean b/tests/lean/cast1.lean
new file mode 100644
index 000000000..6d9585546
--- /dev/null
+++ b/tests/lean/cast1.lean
@@ -0,0 +1,20 @@
+Variable vector : Type -> Nat -> Type
+Axiom N0 (n : Nat) : n + 0 = n
+Theorem V0 (T : Type) (n : Nat) : (vector T (n + 0)) = (vector T n) :=
+ Congr (Refl (vector T)) (N0 n)
+Variable f (n : Nat) (v : vector Int n) : Int
+Variable m : Nat
+Variable v1 : vector Int (m + 0)
+(*
+ The following application will fail because (vector Int (m + 0)) and (vector Int m)
+ are not definitionally equal.
+*)
+Check f m v1
+(*
+ The next one succeeds using the "casting" operator.
+ We can do it, because (V0 Int m) is a proof that
+ (vector Int (m + 0)) and (vector Int m) are propositionally equal.
+ That is, they have the same interpretation in the lean set theoretic
+ semantics.
+*)
+Check f m (cast (V0 Int m) v1)
diff --git a/tests/lean/cast1.lean.expected.out b/tests/lean/cast1.lean.expected.out
new file mode 100644
index 000000000..3a117ffad
--- /dev/null
+++ b/tests/lean/cast1.lean.expected.out
@@ -0,0 +1,16 @@
+ Set: pp::colors
+ Set: pp::unicode
+ Assumed: vector
+ Assumed: N0
+ Proved: V0
+ Assumed: f
+ Assumed: m
+ Assumed: v1
+Error (line: 12, pos: 6) type mismatch at application
+ f m v1
+Function type:
+ Π (n : ℕ) (v : vector ℤ n), ℤ
+Arguments types:
+ m : ℕ
+ v1 : vector ℤ (m + 0)
+ℤ
diff --git a/tests/lean/cast2.lean b/tests/lean/cast2.lean
new file mode 100644
index 000000000..4194ca4ac
--- /dev/null
+++ b/tests/lean/cast2.lean
@@ -0,0 +1,11 @@
+Variable A : Type
+Variable B : Type
+Variable A' : Type
+Variable B' : Type
+Axiom H : A -> B = A' -> B'
+Variable a : A
+Check DomInj H
+Theorem BeqB' : B = B' := RanInj H a
+Set pp::implicit true
+Show DomInj H
+Show RanInj H a
diff --git a/tests/lean/cast2.lean.expected.out b/tests/lean/cast2.lean.expected.out
new file mode 100644
index 000000000..0bea3b489
--- /dev/null
+++ b/tests/lean/cast2.lean.expected.out
@@ -0,0 +1,13 @@
+ Set: pp::colors
+ Set: pp::unicode
+ Assumed: A
+ Assumed: B
+ Assumed: A'
+ Assumed: B'
+ Assumed: H
+ Assumed: a
+A = A'
+ Proved: BeqB'
+ Set: lean::pp::implicit
+DomInj::explicit A A' (λ x : A, B) (λ x : A', B') H
+RanInj::explicit A A' (λ x : A, B) (λ x : A', B') H a