michael/lean2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(library/elaborator): improve support for dependent pairs in the elaborator

Browse source 
Signed-off-by: Leonardo de Moura <leonardo@microsoft.com>
This commit is contained in:
Leonardo de Moura 2014-02-06 20:22:25 -08:00
parent 5efc60d1f1
commit 363c4dc5c2
3 changed files with 180 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

63
src/library/elaborator/elaborator.cpp
View file

@ -1157,7 +1157,7 @@ class elaborator::imp {
lean_assert(has_local_context(a));
// imitate
push_active(c);
// a <- (fun x : ?h1, ?h2) or (Pi x : ?h1, ?h2)
// a <- (fun x : ?h1, ?h2), or (Pi x : ?h1, ?h2), or (Sigma x : ?h1, ?h2)
// ?h1 is in the same context where 'a' was defined
// ?h2 is in the context of 'a' + domain of b
expr m = mk_metavar(metavar_name(a));
@ -1215,6 +1215,61 @@ class elaborator::imp {
m_case_splits.push_back(std::move(new_cs));
}
}
/**
\brief Solve a constraint of the form
ctx |- a == b
where
a is of the form ?m[...] i.e., metavariable with a non-empty local context.
b is a pair projection.
We solve the constraint by assigning a to an abstraction with fresh metavariables.
*/
void imitate_proj(expr const & a, expr const & b, unification_constraint const & c) {
lean_assert(is_metavar(a));
lean_assert(is_proj(b));
lean_assert(!is_assigned(a));
lean_assert(has_local_context(a));
// imitate
push_active(c);
// a <- (proj1/2 ?h_1)
// ?h_1 is in the same context where 'a' was defined
expr m = mk_metavar(metavar_name(a));
context ctx_m = m_state.m_menv->get_context(m);
expr h_1 = m_state.m_menv->mk_metavar(ctx_m);
expr imitation = update_proj(b, h_1);
justification new_jst(new imitation_justification(c));
push_new_constraint(true, ctx_m, m, imitation, new_jst);
}
/**
\brief Solve a constraint of the form
ctx |- a == b
where
a is of the form ?m[...] i.e., metavariable with a non-empty local context.
b is a dependent pair
We solve the constraint by assigning a to an abstraction with fresh metavariables.
*/
void imitate_pair(expr const & a, expr const & b, unification_constraint const & c) {
lean_assert(is_metavar(a));
lean_assert(is_pair(b));
lean_assert(!is_assigned(a));
lean_assert(has_local_context(a));
// imitate
push_active(c);
// a <- (pair ?h_1 ?h_2 ?h_3)
// ?h_i are in the same context where 'a' was defined
expr m = mk_metavar(metavar_name(a));
context ctx_m = m_state.m_menv->get_context(m);
expr h_1 = m_state.m_menv->mk_metavar(ctx_m);
expr h_2 = m_state.m_menv->mk_metavar(ctx_m);
expr h_3 = m_state.m_menv->mk_metavar(ctx_m);
expr imitation = mk_pair(h_1, h_2, h_3);
justification new_jst(new imitation_justification(c));
push_new_constraint(true, ctx_m, m, imitation, new_jst);
}
/**
\brief Process a constraint <tt>ctx |- a == b</tt> where \c a is of the form <tt>?m[(inst:i t), ...]</tt>.
@ -1274,6 +1329,12 @@ class elaborator::imp {
} else if (is_app(b) && !has_metavar(arg(b, 0))) {
imitate_application(a, b, c);
return true;
} else if (is_proj(b)) {
imitate_proj(a, b, c);
return true;
} else if (is_pair(b)) {
imitate_pair(a, b, c);
return true;
}
}
return false;

87
tests/lean/sum2.lean Normal file
View file

@ -0,0 +1,87 @@
-- Copyright (c) 2014 Microsoft Corporation. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Author: Leonardo de Moura
import macros
import pair
import subtype
import optional
using subtype
using optional
-- We are encoding the (sum A B) as a subtype of (optional A) # (optional B), where
-- (proj1 n = none) ≠ (proj2 n = none)
definition sum_pred (A B : (Type U)) := λ p : (optional A) # (optional B), (proj1 p = none) ≠ (proj2 p = none)
definition sum (A B : (Type U)) := subtype ((optional A) # (optional B)) (sum_pred A B)
namespace sum
theorem inl_pred {A : (Type U)} (a : A) (B : (Type U)) : sum_pred A B (pair (some a) none)
:= not_intro
(assume N : (some a = none) = (none = (@none B)),
have eq : some a = none,
from (symm N) ◂ (refl (@none B)),
show false,
from absurd eq (distinct a))
theorem inr_pred (A : (Type U)) {B : (Type U)} (b : B) : sum_pred A B (pair none (some b))
:= not_intro
(assume N : (none = (@none A)) = (some b = none),
have eq : some b = none,
from N ◂ (refl (@none A)),
show false,
from absurd eq (distinct b))
theorem inhabl {A : (Type U)} (H : inhabited A) (B : (Type U)) : inhabited (sum A B)
:= inhabited_elim H (take w : A,
subtype_inhabited (exists_intro (pair (some w) none) (inl_pred w B)))
theorem inhabr (A : (Type U)) {B : (Type U)} (H : inhabited B) : inhabited (sum A B)
:= inhabited_elim H (take w : B,
subtype_inhabited (exists_intro (pair none (some w)) (inr_pred A w)))
definition inl {A : (Type U)} (a : A) (B : (Type U)) : sum A B
:= abst (pair (some a) none) (inhabl (inhabited_intro a) B)
definition inr (A : (Type U)) {B : (Type U)} (b : B) : sum A B
:= abst (pair none (some b)) (inhabr A (inhabited_intro b))
theorem inl_inj {A B : (Type U)} {a1 a2 : A} : inl a1 B = inl a2 B → a1 = a2
:= assume Heq : inl a1 B = inl a2 B,
have eq1 : inl a1 B = abst (pair (some a1) none) (inhabl (inhabited_intro a1) B),
from refl (inl a1 B),
have eq2 : inl a2 B = abst (pair (some a2) none) (inhabl (inhabited_intro a1) B),
from subst (refl (inl a2 B)) (proof_irrel (inhabl (inhabited_intro a2) B) (inhabl (inhabited_intro a1) B)),
have rep_eq : (pair (some a1) none) = (pair (some a2) none),
from abst_inj (inhabl (inhabited_intro a1) B) (inl_pred a1 B) (inl_pred a2 B) (trans (trans (symm eq1) Heq) eq2),
show a1 = a2,
from optional::injectivity
(calc some a1 = proj1 (pair (some a1) (@none B)) : refl (some a1)
... = proj1 (pair (some a2) (@none B)) : pair_inj1 rep_eq
... = some a2 : refl (some a2))
theorem inr_inj {A B : (Type U)} {b1 b2 : B} : inr A b1 = inr A b2 → b1 = b2
:= assume Heq : inr A b1 = inr A b2,
have eq1 : inr A b1 = abst (pair none (some b1)) (inhabr A (inhabited_intro b1)),
from refl (inr A b1),
have eq2 : inr A b2 = abst (pair none (some b2)) (inhabr A (inhabited_intro b1)),
from subst (refl (inr A b2)) (proof_irrel (inhabr A (inhabited_intro b2)) (inhabr A (inhabited_intro b1))),
have rep_eq : (pair none (some b1)) = (pair none (some b2)),
from abst_inj (inhabr A (inhabited_intro b1)) (inr_pred A b1) (inr_pred A b2) (trans (trans (symm eq1) Heq) eq2),
show b1 = b2,
from optional::injectivity
(calc some b1 = proj2 (pair (@none A) (some b1)) : refl (some b1)
... = proj2 (pair (@none A) (some b2)) : pair_inj2 rep_eq
... = some b2 : refl (some b2))
theorem distinct {A B : (Type U)} (a : A) (b : B) : inl a B ≠ inr A b
:= assume N : inl a B = inr A b,
have eq1 : inl a B = abst (pair (some a) none) (inhabl (inhabited_intro a) B),
from refl (inl a B),
have eq2 : inr A b = abst (pair none (some b)) (inhabl (inhabited_intro a) B),
from subst (refl (inr A b)) (proof_irrel (inhabr A (inhabited_intro b)) (inhabl (inhabited_intro a) B)),
have rep_eq : (pair (some a) none) = (pair none (some b)),
from abst_inj (inhabl (inhabited_intro a) B) (inl_pred a B) (inr_pred A b) (trans (trans (symm eq1) N) eq2),
show false,
from absurd (pair_inj1 rep_eq) (optional::distinct a)
theorem dichotomy {A B : (Type U)} (n : sum A B) : (∃ a, n = inl a B) ∨ (∃ b, n = inr A b)
:= let pred : (proj1 (rep n) = none) ≠ (proj2 (rep n) = none) := P_rep n
in _

31
tests/lean/sum2.lean.expected.out Normal file
View file

@ -0,0 +1,31 @@
Set: pp::colors
Set: pp::unicode
Imported 'macros'
Imported 'pair'
Imported 'subtype'
Imported 'optional'
Using: subtype
Using: optional
Defined: sum_pred
Defined: sum
Proved: sum::inl_pred
Proved: sum::inr_pred
Proved: sum::inhabl
Proved: sum::inhabr
Defined: sum::inl
Defined: sum::inr
Proved: sum::inl_inj
Proved: sum::inr_inj
Proved: sum::distinct
sum2.lean:88:0: error: invalid tactic command, unexpected end of file
Proof state:
A :
(Type U),
B :
(Type U),
n :
sum A B,
pred :
(proj1 (subtype::rep n) = optional::none) ≠ (proj2 (subtype::rep n) = optional::none)
⊢ (∃ a : A, n = subtype::abst (tuple (optional::some a), optional::none) (sum::inhabl (inhabited_intro a) B)) ∨
(∃ b : B, n = subtype::abst (tuple optional::none, (optional::some b)) (sum::inhabr A (inhabited_intro b)))