Skip to content

Commit

Permalink
Tap
Browse files Browse the repository at this point in the history
  • Loading branch information
imbrem committed Sep 24, 2024
1 parent 471c275 commit 8938228
Show file tree
Hide file tree
Showing 11 changed files with 300 additions and 118 deletions.
29 changes: 23 additions & 6 deletions DeBruijnSSA/BinSyntax/Rewrite/Region/Compose/Completeness.lean
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Elgot
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Functor
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Elgot
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Cast
Expand Down Expand Up @@ -96,7 +97,7 @@ theorem Eqv.packed_let2_den {Γ : Ctx α ε} {R : LCtx α}
Term.Eqv.subst_liftn₂_var_add_2, Term.Eqv.subst_liftn₂_var_one, let2_pair, let1_beta,
↓dreduceIte, let2_seq, vwk1_packed]
congr
simp [<-vsubst_fromWk, vsubst_vsubst, packed, packed_in]
simp only [packed, packed_in, vsubst_vsubst, ← vsubst_fromWk]
congr 1
ext k
apply Term.Eqv.eq_of_term_eq
Expand Down Expand Up @@ -130,12 +131,21 @@ theorem Eqv.packed_case_den {Γ : Ctx α ε} {R : LCtx α}
simp only [Term.Subst.pi_n, Term.pi_n, Term.Subst.comp, Term.subst_pn]
rfl
· rw [distl_inv, ret_seq]
simp [vwk1_let2, vwk3, Nat.liftnWk, let2_pair, let1_beta]
simp only [let1_beta, vwk1_let2, Term.Eqv.wk1_var0, List.length_cons, Fin.zero_eta,
List.get_eq_getElem, Fin.val_zero, List.getElem_cons_zero, vwk3, vwk_case, Term.Eqv.wk_var,
Set.mem_setOf_eq, Ctx.InS.coe_wk3, Nat.liftnWk, Nat.ofNat_pos, ↓reduceIte, vwk_br,
Term.Eqv.wk_inl, Term.Eqv.wk_pair, Ctx.InS.coe_lift, Nat.liftWk_succ, Nat.one_lt_ofNat,
Nat.reduceAdd, Nat.liftWk_zero, Term.Eqv.wk_inr, vsubst_let2, Term.Eqv.var0_subst0,
Term.Eqv.wk_res_self, vsubst_case, ge_iff_le, le_refl, Term.Eqv.subst_liftn₂_var_zero,
vsubst_br, Term.Eqv.subst_inl, Term.Eqv.subst_pair, Term.Eqv.subst_lift_var_succ,
Term.Eqv.subst_liftn₂_var_one, Term.Eqv.wk0_var, Term.Eqv.subst_lift_var_zero,
Term.Eqv.subst_inr, let2_pair, zero_add, Term.Eqv.var_succ_subst0, ↓dreduceIte, Nat.reduceSub,
Nat.succ_eq_add_one]
rw [<-ret, <-ret, case_seq]
simp only [vwk1_coprod, vwk1_packed, ret_inl_coprod, ret_inr_coprod]
simp only [ret_seq, vwk1_packed]
congr 1 <;> {
simp [vwk1, <-vsubst_fromWk, vsubst_vsubst, packed, packed_in]
simp only [vwk1, packed, packed_in, vsubst_vsubst, ← vsubst_fromWk]
congr 1
ext k
apply Term.Eqv.eq_of_term_eq
Expand All @@ -147,13 +157,20 @@ theorem Eqv.packed_case_den {Γ : Ctx α ε} {R : LCtx α}
rfl
}

open Term.Eqv

theorem Eqv.packed_cfg_den {Γ : Ctx α ε} {L R : LCtx α} {β : Eqv φ Γ (R ++ L)} {G}
: (cfg R β G).packed (Δ := Δ)
= ret Term.Eqv.split ;; _ ⋊ β.packed ;; fixpoint (
_ ⋊ ret Term.Eqv.pack_app ;; distl_inv ;; sum pi_r (
ret Term.Eqv.distl_pack ;; pack_coprod
(λi => acast (R.get_dist (i := i)) ;; ret Term.Eqv.split ⋉ _ ;; assoc
;; _ ⋊ (G (i.cast R.length_dist)).packed
)
))
:= sorry
))) := by
rw [
packed_cfg_unpack, letc_to_vwk1, letc_vwk1_den, ret_seq, <-vsubst_packed_out,
<-vwk1_packed_out, <-ret_seq
]
simp only [seq_assoc]
congr 1
sorry
30 changes: 30 additions & 0 deletions DeBruijnSSA/BinSyntax/Rewrite/Region/Compose/Seq.lean
Original file line number Diff line number Diff line change
Expand Up @@ -465,6 +465,18 @@ theorem Eqv.vwk_wrseq {B C : Ty α} {Γ Δ : Ctx α ε} {L : LCtx α}
induction right using Quotient.inductionOn;
simp only [wrseq_quot, vwk_quot, InS.vwk_wrseq]

theorem Eqv.vsubst_wrseq {B C : Ty α} {Γ Δ : Ctx α ε} {L : LCtx α}
{σ : Term.Subst.Eqv φ Γ Δ}
{left : Eqv φ Δ (B::L)}
{right : Eqv φ (⟨B, ⊥⟩::Δ) (C::L)}
: (left.wrseq right).vsubst σ
= (left.vsubst σ).wrseq (right.vsubst (σ.lift (le_refl _))) := by
induction left using Quotient.inductionOn;
induction right using Quotient.inductionOn;
induction σ using Quotient.inductionOn;
simp only [wrseq_quot, vsubst_quot, Term.Subst.Eqv.lift_quot, InS.vsubst_wrseq]
rfl

theorem Eqv.lwk_lift_wrseq {B C : Ty α} {Γ : Ctx α ε} {L K : LCtx α}
{ρ : LCtx.InS L K}
{left : Eqv φ Γ (B::L)}
Expand Down Expand Up @@ -541,6 +553,10 @@ theorem Eqv.wseq_eq_seq {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
rfl
| succ k => simp [Subst.Eqv.get_comp, cfgSubst'_get, get_alpha0, Term.Eqv.nil]

theorem Eqv.seq_eq_wrseq {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
{left : Eqv φ (⟨A, ⊥⟩::Γ) (B::L)} {right : Eqv φ (⟨B, ⊥⟩::Γ) (C::L)}
: left ;; right = left.wrseq right.vwk1 := by rw [<-wseq_eq_seq, wseq_eq_wrseq]

theorem Eqv.lwk_lift_seq {A B C : Ty α} {Γ : Ctx α ε} {L K : LCtx α}
{ρ : LCtx.InS L K}
{left : Eqv φ (⟨A, ⊥⟩::Γ) (B::L)}
Expand Down Expand Up @@ -802,6 +818,20 @@ theorem Eqv.seq_cfg {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
(λi => (G i).vwk1)
:= by simp only [<-wseq_eq_seq, wseq_cfg]

theorem Eqv.wrseq_cont {B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
(f : Eqv φ Γ (B::L)) (g : Eqv φ (⟨B, ⊥⟩::Γ) (C::D::L))
(h : Eqv φ (⟨C, ⊥⟩::Γ) (C::D::L))
: f.wrseq (cfg [C] g (Fin.elim1 h.vwk1))
= cfg [C] (f.lwk1.wrseq g) (Fin.elim1 h)
:= by
convert Eqv.wrseq_cfg (R := [C]) f g (Fin.elim1 h)
· rename Fin 1 => i; cases i using Fin.elim1; rfl
· induction f using Quotient.inductionOn
induction g using Quotient.inductionOn
induction h using Quotient.inductionOn
apply Eqv.eq_of_reg_eq
rfl

theorem Eqv.seq_cont {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
(f : Eqv φ (⟨A, ⊥⟩::Γ) (B::L)) (g : Eqv φ (⟨B, ⊥⟩::Γ) (C::D::L))
(h : Eqv φ (⟨C, ⊥⟩::Γ) (C::D::L))
Expand Down
22 changes: 18 additions & 4 deletions DeBruijnSSA/BinSyntax/Rewrite/Region/Structural.lean
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,8 @@ import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Sum
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Product
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Distrib
import DeBruijnSSA.BinSyntax.Rewrite.Term.Structural
import DeBruijnSSA.BinSyntax.Rewrite.Term.Structural.Distrib
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Cast

namespace BinSyntax

Expand Down Expand Up @@ -121,26 +123,38 @@ theorem Eqv.packed_case {Γ : Ctx α ε} {R : LCtx α}

theorem Eqv.packed_cfg_unpack {Γ : Ctx α ε} {L R : LCtx α} {β : Eqv φ Γ (R ++ L)} {G}
: (cfg R β G).packed (Δ := Δ)
= gloop R.pack
= letc R.pack
β.packed.unpacked_app_out
(unpack.lsubst (Subst.Eqv.fromFCFG (λi =>
(let1 (pair (var 2 (by simp)) (var 0 Ctx.Var.shead)) (G i).packed.unpacked_app_out)))) := by
rw [packed_def', packed_in_cfg, packed_out_cfg_gloop_unpack, <-packed_def']
rw [packed_def', packed_in_cfg, packed_out_cfg_letc_unpack, <-packed_def']
congr; funext i
rw [vwk1_unpacked_app_out, packed_out_let1, <-packed_def', <-unpacked_app_out_let1]
simp

theorem Eqv.packed_cfg {Γ : Ctx α ε} {L R : LCtx α} {β : Eqv φ Γ (R ++ L)} {G}
: (cfg R β G).packed (Δ := Δ)
= gloop R.pack
= letc R.pack
β.packed.unpacked_app_out
(pack_coprod
(λi => (let1 (pair (var 1 (by simp)) (var 0 Ctx.Var.shead)) (G i).packed.unpacked_app_out)))
:= by
rw [packed_def', packed_in_cfg, packed_out_cfg_gloop, <-packed_def']
rw [packed_def', packed_in_cfg, packed_out_cfg_letc, <-packed_def']
congr; funext i
rw [packed_out_let1, <-packed_def', unpacked_app_out_let1]

theorem Eqv.packed_cfg_split {Γ : Ctx α ε} {L R : LCtx α} {β : Eqv φ Γ (R ++ L)} {G}
: (cfg R β G).packed (Δ := Δ)
= letc (Γ.pack.prod R.pack)
(ret Term.Eqv.split ;; _ ⋊ β.packed.unpacked_app_out)
(ret Term.Eqv.split ⋉ _ ;; assoc
;; _ ⋊ (ret Term.Eqv.distl_pack
;; pack_coprod (λi => acast R.get_dist
;; (G (i.cast R.length_dist)).packed.unpacked_app_out))) := by
sorry

-- TODO: unpacked_app_out ltimes dinaturality

end Region

end BinSyntax
18 changes: 17 additions & 1 deletion DeBruijnSSA/BinSyntax/Rewrite/Region/Structural/Elgot.lean
Original file line number Diff line number Diff line change
@@ -1,8 +1,24 @@
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Gloop
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Letc
import DeBruijnSSA.BinSyntax.Rewrite.Region.Structural.Sum
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Elgot

namespace BinSyntax

variable [Φ: EffInstSet φ (Ty α) ε] [PartialOrder α] [SemilatticeSup ε] [OrderBot ε]

namespace Region

def Eqv.fixpoint_def' {A B : Ty α} {Γ : Ctx α ε} {L : LCtx α} (f : Eqv φ (⟨A, ⊥⟩::Γ) ((B.coprod A)::L))
: Eqv φ (⟨A, ⊥⟩::Γ) (B::L) := letc A nil (f.vwk1.lwk1 ;; left_exit)

theorem Eqv.letc_to_vwk1 {Γ : Ctx α ε} {L : LCtx α} {A : Ty α} {β : Eqv φ ((B, ⊥)::Γ) (A::L)} {G}
: letc A β G = letc (B.prod A)
(ret Term.Eqv.split ;; _ ⋊ β)
((ret Term.Eqv.split ⋉ _ ;; assoc ;; _ ⋊ (let2 (Term.Eqv.var 0 Ctx.Var.shead) G.vwk2)).vwk1)
:= by
sorry

theorem Eqv.letc_vwk1_den {Γ : Ctx α ε}
{A B : Ty α} {β : Eqv φ ((X, ⊥)::Γ) [A, B]} {G : Eqv φ ((A, ⊥)::Γ) [A, B]}
: letc A β G.vwk1 = β.packed_out ;; fixpoint (coprod (coprod zero inj_l) (G.packed_out ;; inj_r))
:= sorry
84 changes: 0 additions & 84 deletions DeBruijnSSA/BinSyntax/Rewrite/Region/Structural/Gloop.lean

This file was deleted.

102 changes: 102 additions & 0 deletions DeBruijnSSA/BinSyntax/Rewrite/Region/Structural/Letc.lean
Original file line number Diff line number Diff line change
@@ -0,0 +1,102 @@
import DeBruijnSSA.BinSyntax.Rewrite.Region.Compose.Seq

namespace BinSyntax

variable [Φ: EffInstSet φ (Ty α) ε] [PartialOrder α] [SemilatticeSup ε] [OrderBot ε]

namespace Region

def Eqv.letc {Γ : Ctx α ε} {L : LCtx α}
(A : Ty α) (β : Eqv φ Γ (A::L)) (G : Eqv φ ((A, ⊥)::Γ) (A::L)) : Eqv φ Γ L
:= Eqv.cfg [A] β (Fin.elim1 G)

theorem Eqv.cfg_eq_letc {Γ : Ctx α ε} {L : LCtx α} {A : Ty α} {β : Eqv φ Γ (A::L)} {G}
: Eqv.cfg [A] β G = β.letc A (G (0 : Fin 1)) := rfl

@[simp]
theorem Eqv.vwk_letc {Γ Δ : Ctx α ε} {L : LCtx α}
{A : Ty α} {β : Eqv φ Δ (A::L)} {G : Eqv φ ((A, ⊥)::Δ) (A::L)} {ρ : Γ.InS Δ}
: (β.letc A G).vwk ρ = (β.vwk ρ).letc A (G.vwk ρ.slift)
:= by rw [letc, vwk_cfg]; rfl

@[simp]
theorem Eqv.vsubst_letc {Γ Δ : Ctx α ε} {L : LCtx α}
{A : Ty α} {β : Eqv φ Δ (A::L)} {G : Eqv φ ((A, ⊥)::Δ) (A::L)} {σ : Term.Subst.Eqv φ Γ Δ}
: (β.letc A G).vsubst σ = (β.vsubst σ).letc A (G.vsubst (σ.lift (le_refl _)))
:= by rw [letc, vsubst_cfg]; rfl

@[simp]
theorem Eqv.lwk_letc {Γ : Ctx α ε} {L K : LCtx α}
{A : Ty α} {β : Eqv φ Γ (A::L)} {G : Eqv φ ((A, ⊥)::Γ) (A::L)} {ρ : L.InS K}
: (β.letc A G).lwk ρ = (β.lwk ρ.slift).letc A (G.lwk ρ.slift) := by
rw [letc, lwk_cfg]
congr
· ext k; simp [Nat.liftnWk_one]
· ext i; cases i using Fin.elim1
simp only [Fin.elim1_zero]
congr; ext k; simp [Nat.liftnWk_one]

@[simp]
theorem Eqv.lsubst_letc {Γ : Ctx α ε} {L K : LCtx α}
{A : Ty α} {β : Eqv φ Γ (A::L)} {G : Eqv φ ((A, ⊥)::Γ) (A::L)} {σ : Subst.Eqv φ Γ L K}
: (β.letc A G).lsubst σ = (β.lsubst σ.slift).letc A (G.lsubst σ.slift.vlift)
:= by rw [letc, lsubst_cfg, Subst.Eqv.liftn_append_singleton]; rfl

theorem Eqv.dinaturality_from_letc {Γ : Ctx α ε} {R L : LCtx α}
{σ : Subst.Eqv φ Γ R ([B] ++ L)} {β : Eqv φ Γ (R ++ L)}
{G : Eqv φ (⟨B, ⊥⟩::Γ) (R ++ L)}
: letc B (β.lsubst σ.extend_in) (G.lsubst σ.extend_in.vlift)
= cfg R β (λi => (σ.get i).lsubst (Subst.Eqv.fromFCFG_append (L := [B]) (Fin.elim1 G)).vlift)
:= dinaturality (Γ := Γ) (R := R) (R' := [B]) (L := L) (σ := σ) (β := β) (G := Fin.elim1 G)

theorem Eqv.dinaturality_from_letc_rec {Γ : Ctx α ε} {R L : LCtx α}
{σ : Subst.Eqv φ Γ R [B]} {β : Eqv φ Γ (R ++ L)}
{G : Eqv φ (⟨B, ⊥⟩::Γ) (R ++ L)}
: letc B (β.lsubst σ.extend) (G.lsubst σ.extend.vlift)
= cfg R β (λi => (σ.get i).lsubst (Subst.Eqv.fromFCFG (Fin.elim1 G)).vlift)
:= dinaturality_rec (Γ := Γ) (R := R) (R' := [B]) (L := L) (σ := σ) (β := β) (G := Fin.elim1 G)

theorem Eqv.dinaturality_to_letc {Γ : Ctx α ε} {R' L : LCtx α}
{σ : Subst.Eqv φ Γ [A] (R' ++ L)} {β : Eqv φ Γ (A::L)}
{G : (i : Fin R'.length) → Eqv φ (⟨R'.get i, ⊥⟩::Γ) ([A] ++ L)}
: cfg R' (β.lsubst σ.extend_in) (λi => (G i).lsubst σ.extend_in.vlift)
= letc A β ((σ.get (0 : Fin 1)).lsubst (Subst.Eqv.fromFCFG_append G).vlift)
:= dinaturality (Γ := Γ) (R := [A]) (R' := R') (L := L) (σ := σ) (β := β) (G := G)

theorem Eqv.dinaturality_to_letc_rec {Γ : Ctx α ε} {R' L : LCtx α}
{σ : Subst.Eqv φ Γ [A] R'} {β : Eqv φ Γ (A::L)}
{G : (i : Fin R'.length) → Eqv φ (⟨R'.get i, ⊥⟩::Γ) ([A] ++ L)}
: cfg R' (β.lsubst σ.extend) (λi => (G i).lsubst σ.extend.vlift)
= letc A β ((σ.get (0 : Fin 1)).lsubst (Subst.Eqv.fromFCFG G).vlift)
:= dinaturality_rec (Γ := Γ) (R := [A]) (R' := R') (L := L) (σ := σ) (β := β) (G := G)

theorem Eqv.dinaturality_letc {Γ : Ctx α ε} {L : LCtx α}
{σ : Subst.Eqv φ Γ [A] ([B] ++ L)} {β : Eqv φ Γ (A::L)}
{G : Eqv φ (⟨B, ⊥⟩::Γ) (A::L)}
: letc B (β.lsubst σ.extend_in) (G.lsubst σ.extend_in.vlift)
= letc A β ((σ.get (0 : Fin 1)).lsubst
(Subst.Eqv.fromFCFG_append (K := [A]) (Fin.elim1 G)).vlift)
:= dinaturality (Γ := Γ) (R := [A]) (R' := [B]) (L := L) (σ := σ) (β := β) (G := Fin.elim1 G)

theorem Eqv.uniform_letc {Γ : Ctx α ε} {L : LCtx α}
{β : Eqv φ Γ (A::L)} {e : Term.Eqv φ ((A, ⊥)::Γ) (B, ⊥)}
{r : Eqv φ ((B, ⊥)::Γ) (B::L)} {s : Eqv φ ((A, ⊥)::Γ) (A::L)}
(hrs : (ret e) ;; r = s ;; (ret e)) : letc B (β.wrseq (ret e)) r = letc A β s := Eqv.uniform hrs

theorem Eqv.wrseq_letc_vwk1 {B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
{f : Eqv φ Γ (B::L)} {g : Eqv φ (⟨B, ⊥⟩::Γ) (C::D::L)}
{h : Eqv φ (⟨C, ⊥⟩::Γ) (C::D::L)}
: f.wrseq (letc C g h.vwk1) = letc C (f.lwk1.wrseq g) h
:= wrseq_cont f g h

theorem Eqv.seq_letc_vwk1 {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
{f : Eqv φ (⟨A, ⊥⟩::Γ) (B::L)} {g : Eqv φ (⟨B, ⊥⟩::Γ) (C::D::L)}
{h : Eqv φ (⟨C, ⊥⟩::Γ) (C::D::L)}
: f ;; letc C g h.vwk1 = letc C (f.lwk1 ;; g) h.vwk1
:= seq_cont f g h

theorem Eqv.seq_ret_letc_vwk1 {A B C : Ty α} {Γ : Ctx α ε} {L : LCtx α}
{f : Term.Eqv φ (⟨A, ⊥⟩::Γ) (B, ⊥)} {g : Eqv φ (⟨B, ⊥⟩::Γ) (C::D::L)}
{h : Eqv φ (⟨C, ⊥⟩::Γ) (C::D::L)}
: ret f ;; letc C g h.vwk1 = letc C (ret f ;; g) h.vwk1
:= by rw [seq_letc_vwk1, lwk1_ret]
Loading

0 comments on commit 8938228

Please sign in to comment.