(*******************************************************************

 The trivial comprehension bicategory

 If we have a bicategory with products, then we obtain a
 comprehension bicategory. The fibration comes from the trivial
 displayed bicategory and for the comprehension pseudofunctor, we
 use that the bicategory has products.

 Contents
 1. The comprehension pseudofunctor
 2. Preservation of cartesian 1-cells
 3. Preservation of (op)cartesian 2-cells
 4. The comprehension bicategory

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.Bicategories.Morphisms.Properties.Projections.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Trivial.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.TrivialCleaving.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving.
Require Import UniMath.Bicategories.Limits.Products.
Import Products.Notations.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Logic.ComprehensionBicat.

Local Open Scope cat.

Section TrivialCompBicat.
  Context (B : bicat_with_binprod).

  (**
   1. The comprehension pseudofunctor
   *)
  Definition trivial_comprehension_data
    : disp_psfunctor_data
        (trivial_displayed_bicat B B)
        (cod_disp_bicat B)
        (id_psfunctor B).
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - intros x y.
      use make_ar.
      + exact (x ⊗ y).
      + exact π₁.
    - intros x₁ x₂ f y₁ y₂ g.
      use make_disp_1cell_cod.
      + exact (f ⊗₁ g).
      + apply inv_of_invertible_2cell.
        apply pair_1cell_pr1.
    - intros x₁ x₂ f₁ f₂ α y₁ y₂ g₁ g₂ β.
      use make_disp_2cell_cod.
      + exact (α ⊗₂ β).
      + abstract
          (unfold coherent_homot ;
           cbn ;
           use vcomp_move_R_pM ; [ is_iso | ] ;
           cbn ;
           rewrite !vassocr ;
           use vcomp_move_L_Mp ; [ is_iso | ] ;
           cbn ;
           apply prod_2cell_pr1_alt).
    - intro ; intros ; simpl.
      simple refine (_ ,, _).
      + use make_disp_2cell_cod.
        * exact ((pair_1cell_id_id_invertible _ _ _)^-1).
        * abstract
            (unfold coherent_homot ;
             cbn ;
             refine (maponpaths _ (binprod_ump_2cell_pr1 _ _ _) @ _) ;
             rewrite !vassocr ;
             apply maponpaths_2 ;
             rewrite lwhisker_id2 ;
             rewrite !vassocl ;
             rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)) ;
             rewrite linvunitor_lunitor ;
             rewrite id2_left ;
             apply runitor_rinvunitor).
      + use is_disp_invertible_2cell_cod.
        cbn.
        apply binprod_ump_2cell_invertible ; is_iso.
    - intro ; intros ; simpl.
      simple refine (_ ,, _).
      + use make_disp_2cell_cod.
        * apply pair_1cell_comp.
        * abstract
            (unfold coherent_homot ;
             cbn ;
             rewrite !vassocl ;
             etrans ; [ do 5 apply maponpaths ; apply binprod_ump_2cell_pr1 | ] ;
             rewrite !vassocr ;
             apply maponpaths_2 ;
             rewrite !vassocl ;
             etrans ;
             [ do 4 apply maponpaths ;
               rewrite !vassocr ;
               rewrite lassociator_rassociator ;
               rewrite id2_left ;
               apply idpath
             | ] ;
             etrans ;
             [ do 3 apply maponpaths ;
               rewrite !vassocr ;
               rewrite lwhisker_vcomp ;
               rewrite vcomp_linv ;
               rewrite lwhisker_id2 ;
               rewrite id2_left ;
               apply idpath
             | ] ;
             etrans ;
             [ do 2 apply maponpaths ;
               rewrite !vassocr ;
               rewrite rassociator_lassociator ;
               rewrite id2_left ;
               apply idpath
             | ] ;
             etrans ;
             [ apply maponpaths ;
               rewrite !vassocr ;
               rewrite rwhisker_vcomp ;
               rewrite vcomp_linv ;
               rewrite id2_rwhisker ;
               rewrite id2_left ;
               apply idpath
             | ] ;
             rewrite lassociator_rassociator ;
             rewrite lwhisker_id2 ;
             apply idpath).
      + use is_disp_invertible_2cell_cod.
        cbn.
        apply pair_1cell_comp_invertible.
  Defined.

  Definition trivial_comprehension_is_disp_psfunctor
    : is_disp_psfunctor
        (trivial_displayed_bicat B B)
        (cod_disp_bicat B)
        (id_psfunctor B)
        trivial_comprehension_data.
  Proof.
  repeat split ; intro ; intros ;
    (use subtypePath ; [ intro ; apply cellset_property | ]).
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply pair_2cell_id_id.
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply pair_2cell_comp.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)).
    apply binprod_lunitor.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)).
    apply binprod_runitor.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lassociator _ _ _ _) _)).
    apply binprod_lassociator.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lwhisker _ _ _) _)).
    apply binprod_lwhisker.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_rwhisker _ _ _) _)).
    apply binprod_rwhisker.
  Qed.

  Definition trivial_comprehension
    : disp_psfunctor
        (trivial_displayed_bicat B B)
        (cod_disp_bicat B)
        (id_psfunctor B).
  Proof.
    simple refine (_ ,, _).
    - exact trivial_comprehension_data.
    - exact trivial_comprehension_is_disp_psfunctor.
  Defined.

  (**
   2. Preservation of cartesian 1-cells
   *)
  Section GlobalCartesian.
    Context {b₁ b₂ : B}
            (f : b₁ --> b₂)
            {c₁ c₂ : B}
            (l : c₁ --> c₂)
            (Hl : left_adjoint_equivalence l).

    Let cone : pb_cone f π₁
      := make_pb_cone
           (b₁ ⊗ c₁)
           π₁
           (f ⊗₁ l)
           (inv_of_invertible_2cell (pair_1cell_pr1 B f l)).

    Let r : c₂ --> c₁
      := left_adjoint_right_adjoint Hl.
    Let η : invertible_2cell (id₁ c₁) (l · left_adjoint_right_adjoint Hl)
      := left_equivalence_unit_iso Hl.
    Let ε : invertible_2cell (left_adjoint_right_adjoint Hl · l) (id₁ c₂)
      := left_equivalence_counit_iso Hl.

    Section AdjEquivToUMP1.
      Context (q : pb_cone f (π₁ : b₂ ⊗ c₂ --> b₂)).

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_map
        : q --> b₁ ⊗ c₁
        := ⟨ pb_cone_pr1 q , pb_cone_pr2 q · π₂ · r ⟩.

      Local Notation "'φ'" := adj_equiv_to_pb_ump_1_pb_1cell_map.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_π₁
        : invertible_2cell (φ · π₁) (pb_cone_pr1 q)
        := prod_1cell_pr1 _ _ _.

      Local Notation "'φπ₁'" := adj_equiv_to_pb_ump_1_pb_1cell_π₁.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁
        : φ · (f ⊗₁ l) · π₁ ==> pb_cone_pr2 q · π₁
        := rassociator _ _ _
           • (_ ◃ pair_1cell_pr1 _ _ _)
           • lassociator _ _ _
           • (prod_1cell_pr1 _ _ _ ▹ _)
           • pb_cone_cell _.

      Local Notation "'φπ₂_cell_π₁'" := adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂
        : φ · (f ⊗₁ l) · π₂ ==> pb_cone_pr2 q · π₂
        := rassociator _ _ _
           • (_ ◃ pair_1cell_pr2 _ _ _)
           • lassociator _ _ _
           • (prod_1cell_pr2 _ _ _ ▹ _)
           • rassociator _ _ _
           • (_ ◃ ε)
           • runitor _.

      Local Notation "'φπ₂_cell_π₂'" := adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_cell
        : φ · (f ⊗₁ l) ==> pb_cone_pr2 q.
      Proof.
        use binprod_ump_2cell.
        - exact (pr2 (binprod_of B b₂ c₂)).
        - exact φπ₂_cell_π₁.
        - exact φπ₂_cell_π₂.
      Defined.

      Local Notation "'φπ₂_cell'" := adj_equiv_to_pb_ump_1_pb_1cell_cell.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_invcell
        : invertible_2cell (φ · (f ⊗₁ l)) (pb_cone_pr2 q).
      Proof.
        use make_invertible_2cell.
        - exact φπ₂_cell.
        - use binprod_ump_2cell_invertible ;
          unfold adj_equiv_to_pb_ump_1_pb_1cell_cell_π₁ ;
          unfold adj_equiv_to_pb_ump_1_pb_1cell_cell_π₂.
          + is_iso.
            * apply pair_1cell_pr1.
            * apply prod_1cell_pr1.
            * apply pb_cone_cell.
          + is_iso.
            * apply pair_1cell_pr2.
            * apply prod_1cell_pr2.
            * apply ε.
      Defined.

      Local Notation "'φπ₂'" := adj_equiv_to_pb_ump_1_pb_1cell_invcell.

      Local Definition adj_equiv_to_pb_ump_1_pb_1cell_eq
        : φ ◃ pb_cone_cell cone
          =
          lassociator φ (pb_cone_pr1 cone) f
          • (φπ₁ ▹ f)
          • pb_cone_cell q
          • (φπ₂ ^-1 ▹ π₁)
          • rassociator φ (pb_cone_pr2 cone) π₁.
      Proof.
        cbn.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          do 3 apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr1.
        }
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        rewrite id2_right.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_rinv.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          rewrite vcomp_rinv.
          rewrite id2_rwhisker.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      Qed.

      Definition adj_equiv_to_pb_ump_1_pb_1cell
        : pb_1cell q cone.
      Proof.
        use make_pb_1cell.
        - exact φ.
        - exact φπ₁.
        - exact φπ₂.
        - exact adj_equiv_to_pb_ump_1_pb_1cell_eq.
      Defined.
    End AdjEquivToUMP1.

    Definition adj_equiv_to_pb_ump_1
      : pb_ump_1 cone.
    Proof.
      intro q.
      exact (adj_equiv_to_pb_ump_1_pb_1cell q).
    Defined.

    Section AdjEquivToUMP2.
      Context {q : B}
              {φ ψ : q --> cone}
              (α : φ · pb_cone_pr1 cone ==> ψ · pb_cone_pr1 cone)
              (β : φ · pb_cone_pr2 cone ==> ψ · pb_cone_pr2 cone)
              (p : (φ ◃ pb_cone_cell cone)
                   • lassociator φ (pb_cone_pr2 cone) π₁
                   • (β ▹ π₁)
                   • rassociator ψ (pb_cone_pr2 cone) π₁
                   =
                   lassociator φ (pb_cone_pr1 cone) f
                   • (α ▹ f)
                   • rassociator ψ (pb_cone_pr1 cone) f
                   • (ψ ◃ pb_cone_cell cone)).

      Let φπ₂ : φ · π₂ ==> ψ · π₂
        := fully_faithful_1cell_inv_map
             (adj_equiv_fully_faithful Hl)
             (rassociator φ π₂ l
              • (φ ◃ (pair_1cell_pr2 B f l) ^-1)
              • lassociator φ (f ⊗₁ l) π₂
              • (β ▹ π₂)
              • rassociator ψ (f ⊗₁ l) π₂
              • (ψ ◃ pair_1cell_pr2 B f l)
              • lassociator ψ π₂ l).

      Definition adj_equiv_to_pb_ump_2_unique
        : isaprop (∑ (γ : φ ==> ψ),
                   γ ▹ pb_cone_pr1 cone = α
                   ×
                   γ ▹ pb_cone_pr2 cone = β).
      Proof.
        use invproofirrelevance.
        intros ζ₁ ζ₂.
        use subtypePath.
        {
          intro.
          apply isapropdirprod ; apply cellset_property.
        }
        use binprod_ump_2cell_unique.
        - exact (pr2 (binprod_of B b₁ c₁)).
        - exact α.
        - exact φπ₂.
        - exact (pr12 ζ₁).
        - use (fully_faithful_1cell_eq (adj_equiv_fully_faithful Hl)).
          refine (!_).
          etrans.
          {
            apply fully_faithful_1cell_inv_map_eq.
          }
          cbn -[η].
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite rwhisker_rwhisker.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite <- vcomp_whisker.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite <- rwhisker_rwhisker_alt.
          apply maponpaths_2.
          apply maponpaths.
          exact (!(pr22 ζ₁)).
        - exact (pr12 ζ₂).
        - use (fully_faithful_1cell_eq (adj_equiv_fully_faithful Hl)).
          refine (!_).
          etrans.
          {
            apply fully_faithful_1cell_inv_map_eq.
          }
          cbn -[η].
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite rwhisker_rwhisker.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite <- vcomp_whisker.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite !vassocl.
          use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
          rewrite <- rwhisker_rwhisker_alt.
          apply maponpaths_2.
          apply maponpaths.
          exact (!(pr22 ζ₂)).
      Qed.

      Definition adj_equiv_to_pb_ump_2_cell
        : φ ==> ψ.
      Proof.
        use binprod_ump_2cell.
        - exact (pr2 (binprod_of B b₁ c₁)).
        - exact α.
        - exact φπ₂.
      Defined.

      Definition adj_equiv_to_pb_ump_2_cell_pr1
        : adj_equiv_to_pb_ump_2_cell ▹ pb_cone_pr1 cone = α.
      Proof.
        apply binprod_ump_2cell_pr1.
      Qed.

      Definition adj_equiv_to_pb_ump_2_cell_pr2
        : adj_equiv_to_pb_ump_2_cell ▹ pb_cone_pr2 cone = β.
      Proof.
        use binprod_ump_2cell_unique.
        - exact (pr2 (binprod_of B b₂ c₂)).
        - exact (rassociator _ _ _
                 • (_ ◃ pair_1cell_pr1 _ _ _)
                 • lassociator _ _ _
                 • (α ▹ f)
                 • rassociator _ _ _
                 • (_ ◃ (pair_1cell_pr1 _ _ _)^-1)
                 • lassociator _ _ _).
        - exact (β ▹ _).
        - cbn ; cbn in p.
          rewrite !vassocl.
          use vcomp_move_L_pM ; [ is_iso | ].
          cbn.
          rewrite rwhisker_rwhisker.
          rewrite !vassocr.
          apply maponpaths_2.
          use vcomp_move_L_Mp ; [ is_iso | ].
          cbn.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply maponpaths.
          rewrite !vassocr.
          use vcomp_move_L_Mp ; [ is_iso | ].
          cbn.
          rewrite <- rwhisker_rwhisker.
          do 2 apply maponpaths.
          apply binprod_ump_2cell_pr1.
        - cbn.
          use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
          rewrite rwhisker_rwhisker.
          use (vcomp_lcancel (_ ◃ (pair_1cell_pr2 B f l)^-1)) ; [ is_iso | ].
          rewrite !vassocr.
          rewrite <- vcomp_whisker.
          use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
          rewrite !vassocr.
          rewrite <- rwhisker_rwhisker_alt.
          etrans.
          {
            do 3 apply maponpaths_2.
            apply maponpaths.
            apply binprod_ump_2cell_pr2.
          }
          do 3 (use vcomp_move_R_Mp ; [ is_iso | ]).
          apply fully_faithful_1cell_inv_map_eq.
        - rewrite !vassocl.
          use vcomp_move_L_pM ; [ is_iso | ].
          cbn.
          use vcomp_move_L_pM ; [ is_iso ; apply pair_1cell_pr1 | ].
          cbn.
          rewrite !vassocr.
          use vcomp_move_L_Mp ; [ is_iso | ].
          cbn.
          exact p.
        - apply idpath.
      Qed.
    End AdjEquivToUMP2.

    Definition adj_equiv_to_pb_ump_2
      : pb_ump_2 cone.
    Proof.
      intros q φ ψ α β p.
      use iscontraprop1.
      - exact (adj_equiv_to_pb_ump_2_unique α β).
      - exact (adj_equiv_to_pb_ump_2_cell α β
               ,,
               adj_equiv_to_pb_ump_2_cell_pr1 α β
               ,,
               adj_equiv_to_pb_ump_2_cell_pr2 α β p).
    Defined.

    Definition adj_equiv_to_pb
      : has_pb_ump cone.
    Proof.
      split.
      - exact adj_equiv_to_pb_ump_1.
      - exact adj_equiv_to_pb_ump_2.
    Defined.
  End GlobalCartesian.

  Definition global_cartesian_trivial_comprehension
    : global_cartesian_disp_psfunctor trivial_comprehension.
  Proof.
    intros b₁ b₂ f c₁ c₂ g Hg ; cbn in *.
    apply is_pb_to_cartesian_1cell.
    pose (g_equiv := trivial_cartesian_1cell_is_adj_equiv _ _ _ _ Hg).
    apply (adj_equiv_to_pb f g g_equiv).
  Defined.

  (**
   3. Preservation of (op)cartesian 2-cells
   *)
  Definition local_cartesian_trivial_comprehension
    : local_cartesian_disp_psfunctor trivial_comprehension.
  Proof.
    intros b₁ b₂ f₁ f₂ α c₁ c₂ g₁ g₂ β Hβ ; cbn in *.
    apply is_cartesian_2cell_sfib_to_is_cartesian_2cell ; cbn.
    apply invertible_to_cartesian.
    refine (transportb
              is_invertible_2cell
              (pair_2cell_pr2 _ _ _)
              _).
    is_iso.
    - apply prod_1cell_pr2.
    - exact (trivial_cartesian_2cell_is_invertible _ _ _ _ Hβ).
  Defined.

  Definition local_opcartesian_trivial_comprehension
    : local_opcartesian_disp_psfunctor trivial_comprehension.
  Proof.
    intros b₁ b₂ f₁ f₂ α c₁ c₂ g₁ g₂ β Hβ ; cbn in *.
    apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell ; cbn.
    apply invertible_to_opcartesian.
    refine (transportb
              is_invertible_2cell
              (pair_2cell_pr2 _ _ _)
              _).
    is_iso.
    - apply prod_1cell_pr2.
    - exact (trivial_opcartesian_2cell_is_invertible _ _ _ _ Hβ).
  Defined.

  (**
   4. The comprehension bicategory
   *)
  Definition trivial_comprehension_bicat_structure
    : comprehension_bicat_structure B.
  Proof.
    use make_comprehension_bicat_structure.
    - exact (trivial_displayed_bicat B B).
    - exact trivial_comprehension.
    - exact (trivial_global_cleaving B B).
    - exact global_cartesian_trivial_comprehension.
  Defined.

  Definition trivial_comprehension_is_covariant
    : is_covariant trivial_comprehension_bicat_structure.
  Proof.
    repeat split.
    - exact (trivial_local_opcleaving B B).
    - exact (trivial_lwhisker_opcartesian B B).
    - exact (trivial_rwhisker_opcartesian B B).
    - exact local_opcartesian_trivial_comprehension.
  Defined.

  Definition trivial_comprehension_is_contravariant
    : is_contravariant trivial_comprehension_bicat_structure.
  Proof.
    repeat split.
    - exact (trivial_local_cleaving B B).
    - exact (trivial_lwhisker_cartesian B B).
    - exact (trivial_rwhisker_cartesian B B).
    - exact local_cartesian_trivial_comprehension.
  Defined.

  Definition trivial_comprehension_bicat
    : comprehension_bicat
    := _ ,, _ ,, trivial_comprehension_is_covariant.

  Definition trivial_contravariant_comprehension_bicat
    : contravariant_comprehension_bicat
    := _ ,, _ ,, trivial_comprehension_is_contravariant.
End TrivialCompBicat.


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From ShortLogrels Require Import prelude language stlc_cbv.

Fixpoint val_rel (τ : type) (v : expr) : Prop :=
  match τ with
  | TUnit => v = TT
  | TProd τ1 τ2 => ∃ v1 v2, v = Pair v1 v2 ∧ val_rel τ1 v1 ∧ val_rel τ2 v2
  | TFun τ1 τ2 => is_val v ∧ ∀ w, val_rel τ1 w → Safe (val_rel τ2) (App v w)
  end.

Lemma val_rel_is_val τ v : val_rel τ v → is_val v.
Proof.
  revert v; induction τ; intros v; simpl in *; subst.
  - intros ?; subst; constructor.
  - firstorder; subst; constructor; auto.
  - intuition.
Qed.

Definition expr_rel (τ : type) (e : expr) := Safe (val_rel τ) e.

Theorem Fundamental Γ e τ :
  typed Γ e τ → ∀ env, env_rel val_rel Γ env → expr_rel τ e.[env_subst env].
Proof.
  intros Htp.
  induction Htp; intros env Henv; simpl.
  - simpl.
    assert (val_rel tp (env_subst env v)).
    { eapply env_rel_lookup1 in Henv as [? [? ?]]; [|eauto; fail].
      erewrite env_subst_lookup; eauto. }
    apply Safe_val; [eapply val_rel_is_val; eauto|assumption].
  - apply Safe_val; [constructor|simpl; trivial].
  - eapply (Safe_bind _ _ _ (λ e, Pair e _));
      [repeat econstructor; fail|apply IHHtp1; trivial; fail|].
    intros v1 Hv11 Hv12.
    eapply (Safe_bind _ _ _ (λ e, Pair _ e)); [|apply IHHtp2; trivial; fail|].
    { repeat econstructor; trivial. }
    intros v2 Hv21 Hv22.
    apply Safe_val; [constructor; trivial; fail|eexists _, _; eauto].
  - eapply (Safe_bind _ _ _ (λ e, Fst e));
      [repeat econstructor; fail|apply IHHtp; trivial; fail|].
    intros v Hv1 (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply Safe_head_step_back; [solve_det_head_step|].
    apply Safe_val; assumption.
  - eapply (Safe_bind _ _ _ (λ e, Snd e));
      [repeat econstructor; fail|apply IHHtp; trivial; fail|].
    intros v Hv1 (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply Safe_head_step_back; [solve_det_head_step|].
    apply Safe_val; assumption.
  - apply Safe_val; [constructor; fail|].
    split; [constructor; fail|].
    intros w Hw.
    assert (is_val w) by (eapply val_rel_is_val; eauto).
    eapply Safe_head_step_back; [solve_det_head_step|].
    asimpl.
    apply (IHHtp (_ :: _)).
    apply env_rel_cons; assumption.
  - eapply (Safe_bind _ _ _ (λ e, App e _));
      [repeat econstructor; fail|apply IHHtp1; trivial; fail|].
    intros v1 Hv11 Hv12.
    eapply (Safe_bind _ _ _ (λ e, App _ e)); [|apply IHHtp2; trivial; fail|].
    { repeat econstructor; trivial. }
    intros v2 Hv21 Hv22.
    apply Hv12; trivial.
Qed.

Corollary type_safety e τ : typed nil e τ → Safe (λ _, True) e.
Proof.
  intros Htp.
  eapply Safe_mono; [tauto|].
  replace e with e.[env_subst nil] by (asimpl; reflexivity).
  eapply (Fundamental nil); [eassumption|apply env_rel_nil].
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.
From Coq Require Import Vectors.Vector.
From Coq Require Import Reals.Reals. Import RIneq. Import Rdefinitions.
From Coq Require Import Logic.FunctionalExtensionality.
Import ListNotations.

From ATL Require Import ATL Common Tactics Div CommonTactics.

Lemma gp_genr_iverson {X} `{TensorElem X} :
  forall p N K (body : Z -> X),
    (|[ p ]| (GEN [K <= i < N ] body i )) = GEN [ K <= n' < N ] (|[ p ]| body n' ).
Proof.
  unfold iverson. intros.
  destruct p. repeat setoid_rewrite mul_1_id. auto.
  simpl. rewrite <- genr_map. reflexivity.
Qed.

Theorem gp_gen_iverson {X} `{TensorElem X} :
  forall p N (body : Z -> X),
    (|[ p ]| (GEN [i < N ] body i )) = GEN [ n' < N ] (|[ p ]| body n' ).
Proof.
  unfold iverson. simpl. auto with crunch.
Qed.
Theorem gp_gen_iverson' {X} `{TensorElem X} :
  forall p N (body : Z -> X),
    GEN [ n' < N ] (|[ p ]| body n' ) = (|[ p ]| (GEN [i < N ] body i )).
Proof.
  unfold iverson. simpl. auto with crunch.
Qed.

Goal forall X (H: TensorElem X) (f : Z -> Z -> (list X)) n m (l: list (list X)),
GEN [ i < Z.of_nat (n + 1) ]
  GEN [ n' < Z.of_nat m ]
  (|[ i <? Z.of_nat n ]| (|[ 0 <=? n' - 1 ]| l _[ i; n' - 1]) <+>
                         l _[ i; n'] <+>
                         (|[ n' + 1 <? Z.of_nat m ]| l _[ i;
                                                     n' + 1])) = [].
Proof.
  intros.
  rw<- @gp_gen_iverson.
Abort.

Theorem gp_double_iverson {X} `{TensorElem X} :
  forall p0 p1 e,
    (|[ p0 ]| (|[ p1 ]| e)) = |[ andb p0 p1 ]| e.
Proof.
  intros p0 p1 ?.
  destruct p0; destruct p1; unfold iverson; try (rewrite mul_1_id; reflexivity).
  simpl. now rewrite mul_0_idemp.
Qed.

Theorem collapse_iverson_same {X} `{TensorElem X} :
  forall (p : bool) (e : R),
    (|[ p ]| (|[ p ]| e)) = (|[ p ]| e).
Proof.
  intros.
  rewrite gp_double_iverson.
  rewrite Bool.andb_diag.
  reflexivity.
Qed.

Theorem iverson_comm {X} `{TensorElem X} :
  forall p1 p2 e,
    (|[ p1 ]| (|[ p2 ]| e)) = (|[ p2 ]| (|[ p1 ]| e)).
Proof.
  intros.
  rewrite gp_double_iverson.
  rewrite gp_double_iverson.
  rewrite Bool.andb_comm.
  reflexivity.
Qed.

Theorem gp_flatten_trunc_iverson {X} `{TensorElem X} :
  forall p k v,
    (|[ p ]| flatten_trunc k v) = flatten_trunc k (|[ p ]| v).
Proof.
  intros.
  unfold flatten_trunc.
  rewrite gp_gen_iverson.
  rw sum_iverson_lift.
  rw sum_iverson_lift.
  apply gen_eq_bound; intros.
  rewrite iverson_length.
  apply sum_eq_bound; intros.
  autorewrite with crunch reds.
  apply sum_eq_bound; intros.
  autorewrite with crunch reds.
  rewrite Bool.andb_comm.
  reflexivity.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearbetween.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NChelper.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCorder.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_parallelcollinear1 :
   forall A B C c d,
   TP A B c d -> BetS C c d ->
   TP A B C d.
Proof.
intros.
assert (Col C c d) by (conclude_def Col ).
assert (neq C c) by (forward_using lemma_betweennotequal).
assert (neq c d) by (forward_using lemma_betweennotequal).
assert (neq C d) by (forward_using lemma_betweennotequal).
assert ((neq A B /\ neq c d /\ ~ Meet A B c d /\ OS c d A B)) by (conclude_def TP ).
let Tf:=fresh in
assert (Tf:exists p q r, (Col A B p /\ Col A B r /\ BetS c p q /\ BetS d r q /\ nCol A B c /\ nCol A B d)) by (conclude_def OS );destruct Tf as [p[q[r]]];spliter.
assert (BetS q r d) by (conclude axiom_betweennesssymmetry).
assert (Col C c d) by (conclude_def Col ).
assert (Col c d C) by (forward_using lemma_collinearorder).
assert (BetS d c C) by (conclude axiom_betweennesssymmetry).
assert (BetS q p c) by (conclude axiom_betweennesssymmetry).
assert (~ eq p r).
 {
 intro.
 assert (Col q r d) by (conclude_def Col ).
 assert (Col q p c) by (conclude_def Col ).
 assert (Col q p d) by (conclude cn_equalitysub).
 assert (neq q p) by (forward_using lemma_betweennotequal).
 assert (Col p c d) by (conclude lemma_collinear4).
 assert (Col c d p) by (forward_using lemma_collinearorder).
 assert (Meet A B c d) by (conclude_def Meet ).
 contradict.
 }
assert (Col q p c) by (conclude_def Col ).
assert (~ Col q d C).
 {
 intro.
 assert (Col d c C) by (conclude_def Col ).
 assert (Col C d c) by (forward_using lemma_collinearorder).
 assert (Col C d q) by (forward_using lemma_collinearorder).
 assert (neq C d) by (forward_using lemma_betweennotequal).
 assert (Col d c q) by (conclude lemma_collinear4).
 assert (Col c q d) by (forward_using lemma_collinearorder).
 assert (Col c q p) by (forward_using lemma_collinearorder).
 assert (neq q c) by (forward_using lemma_betweennotequal).
 assert (neq c q) by (conclude lemma_inequalitysymmetric).
 assert (Col q d p) by (conclude lemma_collinear4).
 assert (Col q r d) by (conclude_def Col ).
 assert (Col q d r) by (forward_using lemma_collinearorder).
 assert (neq q d) by (forward_using lemma_betweennotequal).
 assert (Col d p r) by (conclude lemma_collinear4).
 assert (Col B p r) by (conclude lemma_collinear4).
 assert (Col B A p) by (forward_using lemma_collinearorder).
 assert (Col B p A) by (forward_using lemma_collinearorder).
 assert (Col B A r) by (forward_using lemma_collinearorder).
 assert (neq B A) by (conclude lemma_inequalitysymmetric).
 assert (Col A p r) by (conclude lemma_collinear4).
 assert (~ neq B p).
  {
  intro.
  assert (Col p r A) by (conclude lemma_collinear4).
  assert (Col p r d) by (forward_using lemma_collinearorder).
  assert (Col r A d) by (conclude lemma_collinear4).
  assert (Col r A B) by (forward_using lemma_collinearorder).
  assert (~ neq r A).
   {
   intro.
   assert (Col A d B) by (conclude lemma_collinear4).
   assert (Col A B d) by (forward_using lemma_collinearorder).
   contradict.
   }
  assert (Col p A d) by (conclude cn_equalitysub).
  assert (Col p A B) by (forward_using lemma_collinearorder).
  assert (~ neq p A).
   {
   intro.
   assert (Col A d B) by (conclude lemma_collinear4).
   assert (Col A B d) by (forward_using lemma_collinearorder).
   contradict.
   }
  assert (eq A p) by (conclude lemma_equalitysymmetric).
  assert (eq r p) by (conclude cn_equalitytransitive).
  assert (Col q p d) by (conclude cn_equalitysub).
  assert (neq q p) by (forward_using lemma_betweennotequal).
  assert (Col p c d) by (conclude lemma_collinear4).
  assert (Col c d p) by (forward_using lemma_collinearorder).
  assert (Meet A B c d) by (conclude_def Meet ).
  contradict.
  }
 assert (neq A p) by (conclude cn_equalitysub).
 assert (Col A p B) by (forward_using lemma_collinearorder).
 assert (~ eq r A).
  {
  intro.
  assert (Col d p A) by (conclude cn_equalitysub).
  assert (Col d B A) by (conclude cn_equalitysub).
  assert (Col A B d) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (Col r A B) by (forward_using lemma_collinearorder).
 assert (Col d B r) by (conclude cn_equalitysub).
 assert (Col r B d) by (forward_using lemma_collinearorder).
 assert (Col r B A) by (forward_using lemma_collinearorder).
 assert (~ neq r B).
  {
  intro.
  assert (Col B d A) by (conclude lemma_collinear4).
  assert (Col A B d) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (eq B r) by (conclude lemma_equalitysymmetric).
 assert (eq p B) by (conclude lemma_equalitysymmetric).
 assert (eq p r) by (conclude cn_equalitytransitive).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists E, (BetS q E c /\ BetS C E r)) by (conclude postulate_Pasch_inner);destruct Tf as [E];spliter.
assert (BetS r E C) by (conclude axiom_betweennesssymmetry).
assert (Col q E c) by (conclude_def Col ).
assert (Col q c p) by (forward_using lemma_collinearorder).
assert (Col q c E) by (forward_using lemma_collinearorder).
assert (neq q c) by (forward_using lemma_betweennotequal).
assert (Col c p E) by (conclude lemma_collinear4).
assert (Col c E p) by (forward_using lemma_collinearorder).
assert (neq r p) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists J, (BetS r p J /\ Cong p J r p)) by (conclude lemma_extension);destruct Tf as [J];spliter.
assert (BetS J p r) by (conclude axiom_betweennesssymmetry).
assert (Col J p r) by (conclude_def Col ).
assert (neq J r) by (forward_using lemma_betweennotequal).
assert (neq p r) by (forward_using lemma_betweennotequal).
assert (neq J p) by (forward_using lemma_betweennotequal).
assert (Col B p r) by (conclude lemma_collinear4).
assert (Col B A p) by (forward_using lemma_collinearorder).
assert (Col B A r) by (forward_using lemma_collinearorder).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (Col A p r) by (conclude lemma_collinear4).
assert (Col p r A) by (forward_using lemma_collinearorder).
assert (Col p r B) by (forward_using lemma_collinearorder).
assert (~ Meet C d J r).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists K, (neq C d /\ neq J r /\ Col C d K /\ Col J r K)) by (conclude_def Meet );destruct Tf as [K];spliter.
 assert (Col C c d) by (conclude_def Col ).
 assert (Col C d c) by (forward_using lemma_collinearorder).
 assert (neq c d) by (forward_using lemma_betweennotequal).
 assert (neq d c) by (conclude lemma_inequalitysymmetric).
 assert (Col d c K) by (conclude lemma_collinear4).
 assert (Col c d K) by (forward_using lemma_collinearorder).
 assert (Col r p J) by (conclude_def Col ).
 assert (Col r J p) by (forward_using lemma_collinearorder).
 assert (neq r J) by (forward_using lemma_betweennotequal).
 assert (Col r J K) by (forward_using lemma_collinearorder).
 assert (Col J p K) by (conclude lemma_collinear4).
 assert (Col J p r) by (forward_using lemma_collinearorder).
 assert (neq p J) by (forward_using lemma_betweennotequal).
 assert (neq J p) by (conclude lemma_inequalitysymmetric).
 assert (Col p K r) by (conclude lemma_collinear4).
 assert (Col p r K) by (forward_using lemma_collinearorder).
 assert (Col A B K) by (conclude lemma_collinear5).
 assert (Meet A B c d) by (conclude_def Meet ).
 contradict.
 }
assert (BetS c E p) by (conclude lemma_collinearbetween).
assert (BetS p E c) by (conclude axiom_betweennesssymmetry).
assert (BetS q p E) by (conclude axiom_innertransitivity).
assert (nCol p r c) by (conclude lemma_NChelper).
assert (nCol p c r) by (forward_using lemma_NCorder).
assert (Col q p c) by (conclude_def Col ).
assert (Col p c q) by (forward_using lemma_collinearorder).
assert (eq c c) by (conclude cn_equalityreflexive).
assert (Col p c c) by (conclude_def Col ).
assert (neq q c) by (forward_using lemma_betweennotequal).
assert (nCol q c r) by (conclude lemma_NChelper).
assert (nCol q r c) by (forward_using lemma_NCorder).
assert (neq q d) by (forward_using lemma_betweennotequal).
assert (Col q r d) by (conclude_def Col ).
assert (eq q q) by (conclude cn_equalityreflexive).
assert (Col q r q) by (conclude_def Col ).
assert (nCol q d c) by (conclude lemma_NChelper).
assert (nCol d c q) by (forward_using lemma_NCorder).
assert (Col C c d) by (conclude_def Col ).
assert (Col d c C) by (forward_using lemma_collinearorder).
assert (eq d d) by (conclude cn_equalityreflexive).
assert (Col d c d) by (conclude_def Col ).
assert (neq C d) by (forward_using lemma_betweennotequal).
assert (neq d C) by (conclude lemma_inequalitysymmetric).
assert (nCol d C q) by (conclude lemma_NChelper).
assert (nCol d q C) by (forward_using lemma_NCorder).
assert (Col q r d) by (conclude_def Col ).
assert (Col d q r) by (forward_using lemma_collinearorder).
assert (Col d q q) by (conclude_def Col ).
assert (~ eq r C).
 {
 intro.
 assert (Col A B C) by (conclude cn_equalitysub).
 assert (Meet A B c d) by (conclude_def Meet ).
 contradict.
 }
assert (~ eq r q).
 {
 intro.
 assert (Col r q c) by (conclude_def Col ).
 assert (Col q r c) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (nCol r q C) by (conclude lemma_NChelper).
assert (nCol r C q) by (forward_using lemma_NCorder).
assert (BetS r E C) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists F, (BetS q F C /\ BetS r p F)) by (conclude postulate_Pasch_outer);destruct Tf as [F];spliter.
assert (BetS C F q) by (conclude axiom_betweennesssymmetry).
assert (Col r p F) by (conclude_def Col ).
assert (Col r p A) by (forward_using lemma_collinearorder).
assert (Col r p B) by (forward_using lemma_collinearorder).
assert (Col A B F) by (conclude lemma_collinear5).
assert (eq r r) by (conclude cn_equalityreflexive).
assert (Col d q r) by (conclude_def Col ).
assert (neq q r) by (forward_using lemma_betweennotequal).
assert (nCol q r C) by (conclude lemma_NChelper).
assert (nCol q C r) by (forward_using lemma_NCorder).
assert (Col q F C) by (conclude_def Col ).
assert (Col q C F) by (forward_using lemma_collinearorder).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col q C C) by (conclude_def Col ).
assert (neq F C) by (forward_using lemma_betweennotequal).
assert (nCol F C r) by (conclude lemma_NChelper).
assert (nCol F r C) by (forward_using lemma_NCorder).
assert (Col B r p) by (conclude lemma_collinear4).
assert (Col B p r) by (forward_using lemma_collinearorder).
assert (Col B p A) by (forward_using lemma_collinearorder).
assert (Col B A r) by (forward_using lemma_collinearorder).
assert (Col B A p) by (forward_using lemma_collinearorder).
assert (Col A r p) by (conclude lemma_collinear4).
assert (Col p r A) by (forward_using lemma_collinearorder).
assert (Col p r F) by (forward_using lemma_collinearorder).
assert (neq p r) by (forward_using lemma_betweennotequal).
assert (Col r A F) by (conclude lemma_collinear4).
assert (Col F r A) by (forward_using lemma_collinearorder).
assert (Col B A r) by (forward_using lemma_collinearorder).
assert (Col B A p) by (forward_using lemma_collinearorder).
assert (Col A r p) by (conclude lemma_collinear4).
assert (Col A p r) by (forward_using lemma_collinearorder).
assert (Col A p B) by (forward_using lemma_collinearorder).
assert (Col A B r) by (forward_using lemma_collinearorder).
assert (Col A B p) by (forward_using lemma_collinearorder).
assert (Col B r p) by (conclude lemma_collinear4).
assert (Col p r B) by (forward_using lemma_collinearorder).
assert (Col r B F) by (conclude lemma_collinear4).
assert (Col F r B) by (forward_using lemma_collinearorder).
assert (nCol A B C) by (conclude lemma_NChelper).
assert (TS C A B q) by (conclude_def TS ).
assert (OS C d A B) by (conclude_def OS ).
assert (~ Meet A B C d).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists K, (neq A B /\ neq C d /\ Col A B K /\ Col C d K)) by (conclude_def Meet );destruct Tf as [K];spliter.
 assert (Col C c d) by (conclude_def Col ).
 assert (Col C d c) by (forward_using lemma_collinearorder).
 assert (neq C d) by (forward_using lemma_betweennotequal).
 assert (Col d c K) by (conclude lemma_collinear4).
 assert (Col c d K) by (forward_using lemma_collinearorder).
 assert (Meet A B c d) by (conclude_def Meet ).
 contradict.
 }
assert (neq C d) by (forward_using lemma_betweennotequal).
assert (TP A B C d) by (conclude_def TP ).
close.
Qed.

End Euclid.


(* In this file we explain how to do the stack example from Section 4.3 of
   the Iris Lecture Notes *)

From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export notation lang.
From iris.proofmode Require Export proofmode.
From iris.heap_lang Require Import proofmode.
From iris.prelude Require Import options.

(*  ---------------------------------------------------------------------- *)

Section stack_code.
  (* This section contains the code of the stack functions we specify *)

  Definition new_stack : val := λ: <>, ref NONEV.

  Definition push : val := λ: "s", λ: "x",
                           let: "hd" := !"s" in
                           let: "p" := ("x", "hd") in
                           "s" <- SOME (ref "p").

  Definition pop : val := (λ: "s",
                           let: "hd" := !"s" in
                           match: "hd" with
                             NONE => NONE
                           | SOME "l" =>
                             let: "p" := !"l" in
                             let: "x" := Fst "p" in
                             "s" <- Snd "p" ;; SOME "x"
                           end).
End stack_code.

(*  ---------------------------------------------------------------------- *)

Section stack_model.

  Context `{!heapGS Σ}.
  Notation iProp := (iProp Σ).
  Implicit Types ℓ : loc.
  (* Here is the basic is_stack representation predicate.
     A stack is a pointer to the head of a linked list.
     Thus we first specify what a linked list is. One option is the following.
   *)
  Fixpoint is_list (hd : val) (xs : list val) : iProp :=
    match xs with
    | [] => ⌜hd = NONEV⌝
    | x :: xs => ∃ ℓ hd', ⌜hd = SOMEV #ℓ⌝ ∗ ℓ ↦ (x,hd') ∗ is_list hd' xs
  end%I.

  Definition is_stack (s : val) (xs : list val): iProp :=
    (∃ (ℓ : loc) (hd : val), ⌜s = #ℓ⌝ ∗ ℓ ↦ hd ∗ is_list hd xs)%I.
End stack_model.

(*  ---------------------------------------------------------------------- *)
Section stack_spec.
  (* This section contains the specifications and proofs for the stack functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)
  Context `{!heapGS Σ}.

  Lemma new_stack_spec:
    {{{ True }}}
      new_stack #()
      {{{ s, RET s; is_stack s [] }}}.
  Proof.
    iIntros (ϕ) "_ HΦ".
    wp_lam.
    wp_alloc ℓ as "Hpt".
    iApply "HΦ".
    iExists ℓ, NONEV.
    iFrame; done.
  Qed.

  Lemma push_spec s xs (x : val):
    {{{ is_stack s xs }}}
      push s x
      {{{ RET #(); is_stack s (x :: xs) }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
    wp_lam. wp_let.
    wp_load.
    wp_let.
    wp_pair.
    wp_let.
    wp_alloc ℓ' as "Hptℓ'".
    wp_store.
    iApply "HΦ".
    iExists ℓ, (SOMEV #ℓ'); iFrame.
    iSplitR; first done.
    iExists ℓ', hd; by iFrame.
  Qed.

  Lemma pop_spec_nonempty s (x : val) xs:
    {{{ is_stack s (x :: xs) }}}
      pop s
      {{{ RET (SOMEV x); is_stack s xs }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
    iDestruct "Hlist" as (ℓ' hd' ->) "[Hptℓ' Hlist]".
    wp_lam.
    wp_load.
    wp_let.
    wp_match.
    wp_load.
    wp_let.
    wp_proj.
    wp_let.
    wp_proj.
    wp_store.
    wp_pures.
    iApply "HΦ".
    iExists ℓ, hd'; by iFrame.
  Qed.

  Lemma pop_spec_empty s:
    {{{ is_stack s [] }}}
      pop s
      {{{ RET NONEV; is_stack s [] }}}.
  Proof.
    iIntros (ϕ) "Hstack HΦ".
    iDestruct "Hstack" as (ℓ hd ->) "[Hpt %]"; subst.
    wp_lam.
    wp_load.
    wp_pures.
    iApply "HΦ".
    iExists ℓ, NONEV; by iFrame.
  Qed.

End stack_spec.

Section stack_model_ownership.
  Context `{!heapGS Σ}.
  Notation iProp := (iProp Σ).
  Implicit Types ℓ : loc.
  (* Here is the basic is_stack representation predicate.
     A stack is a pointer to the head of a linked list.
     Thus we first specify what a linked list is. One option is the following.
   *)
  Fixpoint is_list_own (hd : val) (Φs : list (val → iProp)) : iProp :=
    match Φs with
    | [] => ⌜hd = NONEV⌝
    | Φ :: Φs => ∃ ℓ x hd', ⌜hd = SOMEV #ℓ⌝ ∗ ℓ ↦ (x,hd') ∗ Φ x ∗ is_list_own hd' Φs
  end%I.

  Definition is_stack_own (s : val) (Φs : list (val → iProp)): iProp :=
    (∃ (ℓ : loc) (hd : val), ⌜s = #ℓ⌝ ∗ ℓ ↦ hd ∗ is_list_own hd Φs)%I.
End stack_model_ownership.

(*  ---------------------------------------------------------------------- *)
Section stack_ownership_spec.
  (* This section contains the specifications and proofs for the stack functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)
  Context `{!heapGS Σ}.

Lemma newstack_ownership_spec:
  {{{ True }}}
    new_stack #()
  {{{ s, RET s; is_stack s [] }}}.
Proof.
  iIntros (ϕ) "_ HΦ".
  wp_lam.
  wp_alloc ℓ as "Hpt".
  iApply "HΦ".
  iExists ℓ, NONEV.
  iFrame; done.
Qed.

Lemma push_ownership_spec s Φ Φs (x : val):
  {{{ is_stack_own s Φs ∗ Φ x }}}
    push s x
  {{{ RET #(); is_stack_own s (Φ :: Φs) }}}.
Proof.
  iIntros (Ψ) "[Hstack HΦx] HΨ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
  wp_lam; wp_let.
  wp_load.
  wp_alloc ℓ' as "Hptℓ'".
  wp_store.
  iApply "HΨ".
  iExists ℓ, (SOMEV #ℓ'); iFrame.
  iSplitR; first done.
  iExists ℓ', x, hd; by iFrame.
Qed.

Lemma pop_ownership_spec_nonempty s Φ Φs:
  {{{ is_stack_own s (Φ :: Φs) }}}
    pop s
  {{{x, RET (SOMEV x); Φ x ∗ is_stack_own s Φs }}}.
Proof.
  iIntros (Ψ) "Hstack HΨ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt Hlist]".
  iDestruct "Hlist" as (ℓ' x hd' ->) "[Hptℓ' [HΦ Hlist]]".
  wp_lam.
  wp_load.
  wp_let.
  wp_match.
  wp_load.
  wp_let.
  wp_proj.
  wp_let.
  wp_proj.
  wp_store.
  wp_inj.
  iApply "HΨ".
  iFrame "HΦ".
  iExists ℓ, hd'; by iFrame.
Qed.

Lemma pop_ownership_spec_empty s:
  {{{ is_stack s [] }}}
    pop s
  {{{ RET NONEV; is_stack s [] }}}.
Proof.
  iIntros (ϕ) "Hstack HΦ".
  iDestruct "Hstack" as (ℓ hd ->) "[Hpt %]"; subst.
  wp_lam.
  wp_load.
  wp_pures.
  iApply "HΦ".
  iExists ℓ, NONEV; by iFrame.
Qed.

End stack_ownership_spec.

(* Exercise 1: Derive the other specifications from the lecture notes.
   Exercise 2: Derive the first specification from the second. That is, from is_stack_own define is_stack, and reprove all the methods in section stack_spec from the specifications in stack_ownership_spec.
 *)


(* Jacques Garrigue, 2018 年 11 月 7 日 *)

(*** 帰納的な定義と多相性 ***)

(** * 1 前回の課題 **)
(** ** 練習問題 1.1 *)
Section Coq3.
  Variable A : Set.
  Variable R : A -> A -> Prop.
  Variable P Q : A -> Prop.

  Theorem exists_postpone :
    (exists x, forall y, R x y) -> (forall y, exists x, R x y).
  Proof. intros [x r] y. exists x. apply r. Qed.
  Theorem or_exists : (ex P) \/ (ex Q) -> exists x, P x \/ Q x.
  Proof.
    intros [[x p]|[x q]].
    exists x; left; assumption.
    exists x; right; assumption.
  Qed.

  Hypothesis classic : forall P, ~~P -> P.
  Theorem remove_c : forall (a : A),
      (forall x y, Q x -> Q y) ->
      (forall c, ((exists x, P x) -> P c) -> Q c) -> Q a.
  Proof.
    intros a HQ HPPQ.
    apply classic; intros qa.
    apply qa, HPPQ.
    intros [x px]. elim qa.
    apply (HQ x), HPPQ. auto.
  Qed.
End Coq3.

(** ** 練習問題 2.1 *)
Lemma plus_0 : forall n, plus n 0 = n.
Proof.
  intros n. induction n. reflexivity.
  simpl. rewrite IHn. reflexivity.
Qed.

Lemma plus_m_Sn : forall m n, plus m (S n) = S (plus m n).
Proof.
  intros m n. induction m. reflexivity.
  simpl. rewrite IHm. reflexivity.
Qed.

Lemma plus_comm : forall m n, plus m n = plus n m.
Proof.
  intros. induction m.
  simpl. rewrite plus_0. reflexivity.
  simpl. rewrite IHm. rewrite plus_m_Sn. reflexivity.
Qed.

(** * 2 帰納的な定義 *)
(** ** Coq の帰納的データ型 *)
Module IndType.

(**
前回は自然数の定義を見た．
 *)
Inductive nat : Set := O : nat | S : nat -> nat.
(**
実は，Coq の全てのデータは帰納的データ型として定義される． 1
 *)
Inductive prod (A B : Set) : Set := pair : A -> B -> prod A B.

Inductive sum (A B : Set) : Set := inl : A -> sum A B | inr : B -> sum A B.

End IndType.

(**
帰納的データ型の値を作るのは構成を適用するだけでいい．しかし，分解するのに OCaml と
同様にパターンマッチングを使わなければならない．その型付け規則が複雑になる．以下のよう
なデータ型を考える．
 *)

(**
<<
Inductive t(a1 ... an : Set) : Set :=
  | c1 : τ11 → ... → τ1k1 → t a1 ... an
    ...
  | cm : τm1 → ... → τmkm → t a1 ... an.
>>

マッチング

<<
Γ ⊢ M : t b1 ... bn
Γ, xi1 : τi1[b1/a1,..., bn/an],..., xiki:τiki[...] ⊢ Mi : τ[ci xi1...xiki/x] (1 ≤ i ≤ m)
---------------------------------------------------------------------------------------------------
Γ ⊢ match M as x return τ with c1 x11...x1k1 ⇒ M1 |...|cm xm1...xmkm ⇒ Mm end : τ[M/x]
>>

[as] と [return] によって，返り値の型の中に入力を含めることができ，場合によって型が違うよう
な関数が作れる．それを手でやるのは難しいが，作戦 [destruct] はこのパターンマッチングを構築してくれる．
帰納的データ型を定義すると，帰納法のための補題が自動的に定義されるが，定義は [match] を使う．
定義が再帰的でないとき，パターンマッチングだけで済む．
再帰的なデータ型について [Fixpoint] が使われる．
 *)

(**
_注釈1_
実際の定義を見ると，Set ではなく Type になっている．Type は Set より一般的なので，Set として使うことができる．
さらに，prod A B は A*B として表示され，pair a b は (a,b) として表示される．
Coq の Notation という機能によって，帰納的データ型の表示方法を変えることができる．
 *)

Definition prod_ind (A B:Set) (P:prod A B -> Prop) :=
  fun (f : forall a b, P (pair a b)) =>
  fun p => match p as x return P x with pair a b => f a b end.
Check prod_ind.
(**
<<
  : forall (A B : Set) (P : A * B -> Prop),
    (forall (a : A) (b : B), P (a, b)) -> forall p : A * B, P p
>>
 *)

Definition sum_ind (A B:Set) (P:sum A B -> Prop) :=
  fun (fl : forall a, P (inl _ a)) (fr : forall b, P (inr _ b)) =>
  fun p => match p as x return P x
        with inl a => fl a | inr b => fr b end.
Check sum_ind.
(**
<<
  : forall (A B : Set) (P : A + B -> Prop),
    (forall a : A, P (inl a)) -> (forall b : B, P (inr b)) ->
    forall p : A + B, P p
>>
 *)

Fixpoint nat_ind (P:nat -> Prop) (f0:P O) (fn:forall n, P n -> P (S n))
         (n : nat) {struct n} :=
  match n as x return P x
  with O => f0 | S m => fn m (nat_ind P f0 fn m) end.
Check nat_ind.
(**
<<
  : forall P : nat -> Prop, P 0 -> (forall n : nat, P n -> P (S n)) ->
    forall n : nat, P n
>>
 *)

(**
前回ならった [induction n] という作戦はこの補題を利用するが，作業がかなり複雑である．

- 1. n を含む全ての仮定をゴールに戻す．(作戦 revert H1 ... Hn でも手動でできる)
- 2. n の型を見て，型が t a1 . . . an ならば，apply (t ind a1 . . . an) を行う．(このステップは作戦 elim n でもできる) 厳密には，ゴールのソートによって t rec, t ind, t rect のいずれかが使われる．
- 3. 新しくできた各ゴールに対して，仮定をおく．(intros にあたる)
 *)

(**
[destruct] と [induction]/[elim] はよく似ているが，後者が生成された補題を利用しているので，
効果が違ったりする．
 *)
Lemma plus_0' : forall n, plus n 0 = n.
Proof.
  apply nat_ind. reflexivity.
  intros n IHn.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

(** ** 帰納的述語 *)
(**
Coq では帰納的な定義は [Set] だけでなく [Prop] でもできる．この場合、パラメータは場合によっ
て変わることが多い。
 *)

(**
<<
Inductive t : τ1 ⇒ ... ⇒ τn ⇒ Prop :=
        | c1 : ∀ (x1 : τ11) ... (xk1 : τ1k1), t θ11 ... θ1n
          ...
        | cm : ∀ (x1 : τm1) ... (xk1 : τmkm), t θm1 ... θmn
>>

マッチング
<<
Γ ⊢ M:t b1...bn  Γ,xi1:τi1,...,xiki:τiki ⊢ Mi:τ[θi1...θin/x1...xn] (1 ≤ i ≤ m)
------------------------------------------------------------------------------
Γ ⊢ match M in t x1...xn return τ with c1 x11...x1k1 ⇒ M1|...| cm xm1...xmkm ⇒ Mm end
: τ[b1, ... , bn/x1 ... xn]
>>
 *)

(** *** 偶数の定義 *)
Inductive even : nat -> Prop :=
  | even_O : even O
  | even_SS : forall n, even n -> even (S (S n)).

(** *** 帰納的述語を証明する定理 *)
Theorem even_double : forall n, even (n + n).
Proof.
  induction n.
  apply even_O.
  simpl.
  rewrite <- plus_n_Sm.
  apply even_SS.
  assumption.
Qed.

(** *** 帰納的述語に対する帰納法もできる *)
Theorem even_plus : forall m n, even m -> even n -> even (m + n).
Proof.
  intros m n Hm Hn.
  induction Hm.
  apply Hn.
  simpl.
  apply even_SS.
  assumption.
Qed.

(**
実は Coq の論理結合子のほとんどが帰納的述語として定義されている．

<<
Inductive and (A B : Prop) : Prop := conj : A -> B -> A /\ B.

Inductive or (A B : Prop) : Prop :=
    or_introl : A -> A n / B | or_intror : B -> A \/ B.

Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> exists x, P x.

Inductive False : Prop := .
>>

[and]、[or] や [ex] について [destruct] が使えた理由がこの定義方法である．
しかも，[False] は最初からあるものではなく，構成子のない述語として定義されている．生成
される帰納法の補題をみると面白い．
 *)
Print False_rect.
(**
<<
 False_rect = fun (P : Type) (f : False) => match f return P with
                                            end
      : forall P : Type, False -> P
>>
 *)

(**
ちょうど，矛盾の規則に対応している．作戦 [elim] でそれが使える．
 *)
Theorem contradict : forall (P Q : Prop),
    P -> ~P -> Q.
Proof.
  intros P Q p np.
  elim np.
  assumption.
Qed.

(** ** 便利な作戦 *)
(**
役に立つ作戦を紹介する．

- [assert (H : prop)]. 命題 [prop] を新しいゴールとして定め，証明が完成したら名前 [H] で仮定に加える．

- [auto]. [Hint] で与えられた定理を使ってゴールを解こうとする． [apply] を 5 回までやってくれるので，証明がとても短くなることもある．

  - [Hint Resolve lemma]. [lemma] を自動的に使う.
  - [Hint Constructors inductive]. [inductive] の全ての構成子を自動的に呼ぶ。

<<
      Hint Constructors even.
      Theorem even_plus’ : forall m n,
        even m -> even n -> even (m + n).
      Proof.
        intros m n Hm Hn.
        induction Hm; simpl; info auto.
      Qed.
>>

- [constructor]. ゴールの先頭の構成子を [apply] する．

<<
  Goal even 0.
    constructor.
>>

- [discriminate]. 仮定の中で構成子の異なる値同士の方程式を見つけ，枝狩りをする．

<<
  Goal 1 <> 2.
    intros eq.
    discriminate.
>>

- [inversion H]. 帰納的述語で表現される仮定 H に対して場合分けを行う．それによって引 数が定まったり，ゴールが解決されたりする．

<<
  Goal ~even 1.
    intros ne.
    inversion ne.

  Goal forall n, even (S (S n)) -> even n.
    intros n H.
    inversion H.
    assumption.
>>

- [repeat] 作戦. 同じ作戦を可能な限り繰り返す．例えば，[repeat split] で連言をばらばらにできる．

- [pattern expr]. 式 expr を含む現在のゴールを述語として見なす。さらに at pos を付けると、特定の位置の出現のみが対象となる。

<<
  Goal (1 + 0 = 1).
    intros.   (* ??? *)
    pattern 1.
      (fun n : nat => n + 0 = n) 1
    apply plus_0.
>>
 *)

(** ** 練習問題 2.1 以下の定理を証明せよ． *)
Module Ex4_1.

Inductive odd : nat -> Prop :=
  | odd_1 : odd 1
  | odd_SS : forall n, odd n -> odd (S (S n)).

Theorem even_odd : forall n, even n -> odd (S n).
Proof.
  intros n Hev.
  induction Hev.
  - apply odd_1.
  - apply odd_SS.
    assumption.
Qed.

Theorem odd_even : forall n, odd n -> even (S n).
Proof.
  intros n Hod.
  induction Hod.
  - apply even_SS. apply even_O.
  - apply even_SS.
    assumption.
Qed.

Theorem even_not_odd : forall n, even n -> ~odd n.
Proof.
  intros n Hev Hcontra.
  induction Hev.
  - inversion Hcontra.
  - apply IHHev.
    inversion Hcontra.
    assumption.
Qed.

Theorem even_or_odd : forall m, even m \/ odd m.
Proof.
  intros m.
  induction m as [|m'].
  - left.
    apply even_O.
  - destruct IHm' as [Hev|Hod].
    + (* even m' *)
      right.
      apply even_odd.
      assumption.
    + (* odd m' *)
      left.
      apply odd_even.
      assumption.
Qed.

Theorem odd_odd_even : forall m n, odd m -> odd n -> even (m+n).
Proof.
  intros m n Hoddm.
  induction Hoddm.
  - intros Hoddn.
    apply odd_even.
    assumption.
  - intros Hoddn.
    simpl.
    apply even_SS.
    apply IHHoddm.
    assumption.
Qed.

End Ex4_1.

(** * 3 多相性 *)
(**
前回は全称 ∀ X:S,T には様々なパターンがあると説明した。
今回はそれを具体的に見る。もしも ⊢ v : ∀ X:S,T ならば

- [S : Set] かつ [T : Prop] のとき
  [v] は命題の証明: [S] の任意の項について [T] が成り立つ
  例: [∀ n : nat, 2 * n = n + n]

- [S : Set] かつ [T = Prop] のとき
  [v] は命題文を返す関数
  例: [fun n : nat => 2 * n = n + n]

- [S = Prop] かつ [T : Prop] のとき
  [v] は任意の命題について成り立つ命題の証明
  例: [∀ P : Prop, P → P]

- [S = Prop] かつ [T = Prop] のとき
  命題引数を取る述語の定義
  例: [and : ∀ P Q : Prop, Prop]

- [S = Set] かつ [T : Set] のとき
  [v] は普通の関数
  例: [fun x ⇒ x + 1 : nat → nat]

- [S = Set] かつ [T : Set] のとき
  [v] は多相的な値: 任意のデータ型 [X] について、[v] は型 [T] をもつ
  例: [fun (X : Set) (x : X) ⇒ x : ∀ X : Set, X → X]

- [S = Set] かつ [T = Set] のとき
  型引数を取るデータ型の定義
  例: [prod : ∀ X Y : Set, Set]

- [S : Set] かつ [T = Set] のとき
  値から型を作る関数
  例:
<<
    Fixpoint vec (n:nat) (T:Set) :=
      match n with
      | 0 => unit
      | S m => (vec m T * T)%type
    end.
    Check ((tt, 1, 2, 3) : vec 3 nat).
>>

この中で特に [S = Set] または [S = Prop] の場合を多相的という。関数や定理が任意のデータ型
または任意の命題について定義される。
 *)

(** ** 標準ライブラリのリスト *)

(**
典型的な多相的なデータ構造として、リストが挙げられる。
 *)
Require Import List.

Module Lists.
Print list.
(**
<<
Inductive list (A : Type) : Type := (* 型引数がある *)
  nil : list A | cons : A -> list A -> list A
>>
 *)
Definition l1 := 1 :: 2 :: 3 :: 4 :: nil. (** cons は :: と書ける *)
Print l1.
(**
<<
  l1 = 1 :: 2 :: 3 :: 4 :: nil
       : list nat
>>
 *)

(**
<<
Definition hd {A:Set} (l:list A) := (* { } で A が省略可能になる *)
  match l with
  | cons a _ => a
  end.
>>
*)
(** Error: Non exhaustive pattern-matching: no clause found for pattern nil *)

Definition hd {A:Set} (d:A) (l:list A) :=
  match l with
  | cons a _ => a
  | nil => d (** nil のときは d を返す *)
  end.

Eval compute in hd 0 l1.
(**
<<
  = 1
  : nat
>>
 *)

Fixpoint length {A:Set} (l : list A) := (** 長さ *)
  match l with
  | nil => 0
  | cons _ l' => 1 + length l'
end.
Eval compute in length l1.
(**
<<
  = 4
  : nat
>>
 *)

Fixpoint append {A:Set} (l1 l2:list A) : list A := (** 結合 *)
  match l1 with
  | nil => l2
  | a :: l' => a :: append l' l2
end.

Eval compute in append (1 :: 2 :: nil) (3 :: 4 :: nil).
(**
<<
  = 1 :: 2 :: 3 :: 4 :: nil
  : list nat
>>
 *)

Fixpoint fold_right {A B:Set} (f : A -> B -> B) (z : B) (l : list A) :=
  match l with
  | nil => z
  | a :: l' => f a (fold_right f z l')
end.
(** fold_right ⊕ b (a1 :: ... :: an) = a1 ⊕ ... ⊕ an ⊕ b *)

Definition sum := fold_right plus 0.
Eval compute in sum l1.
(**
>>
  = 10
  : nat
 *)

Eval compute in fold_right mult 1 l1.
(**
<<
  = 24
  : nat
>>
 *)

End Lists.

(** ** 練習問題 3.1 多項式を係数のリストとして定義する。Z 上の多項式をある点 x で計算する関数を定義せよ。*)
Module Ex4_2.
  Require Import ZArith.
  Open Scope Z_scope.

  Fixpoint eval_poly' (p : list Z) (x : Z) (c : Z) :=
    match p with
    | nil => 0
    | p :: ps => p * Z.pow x c + eval_poly' ps x (c + 1)
    end.

  Fixpoint eval_poly (p : list Z) (x : Z) :=
    eval_poly' p x 0.

  Eval compute in eval_poly (1 :: 2 :: 3 :: nil) 5. (** = 1 + 2*5 + 3*5*5 *)
End Ex4_2.

(** ** 多相性と論理 *)
(**
Coq の論理演算子は Inductive で定義されているが、実は多相的な論理式として定義できる。
 *)

Definition and' (P Q : Prop) := forall (X : Prop), (P -> Q -> X) -> X.
Definition or' (P Q : Prop) := forall (X : Prop), (P -> X) -> (Q -> X) -> X.
Definition False' := forall (X : Prop), X.
Definition Equal' (T : Type) (x y : T) := forall (P : T -> Prop), P x <-> P y.

Theorem and'_ok : forall P Q, and' P Q <-> P /\ Q.
Proof.
  split.
  intros.
  apply H.
  split; assumption.
  intros pq X pqx.
  destruct pq as [p q].
  apply pqx; assumption.
Qed.

Theorem or'_ok : forall P Q, or' P Q <-> P \/ Q.
Proof.
  split.
  - (* -> *)
    intros Hpq.
    apply Hpq.
    + (* P -> P \/ Q *)
      intro Hp.
      left. assumption.
    + (* Q -> P \/ Q *)
      intros Hp.
      right. assumption.
  - (* <- *)
    intros Hpq X Hpx Hqx.
    destruct Hpq as [Hp|Hq].
    + (* P *)
      apply Hpx.
      assumption.
    + (* Q *)
      apply Hqx.
      assumption.
Qed.

Theorem False'_ok : False' <-> False.
Proof.
  split.
  - (* -> *)
    intros Hcontra.
    apply Hcontra.
  - (* <- *)
    intros Hcontra.
    elim Hcontra.
Qed.

Theorem Equal'_ok : forall T x y, Equal' T x y <-> x = y.
Proof.
  split.
  - (* -> *)
    intros Heq.
    apply Heq.
    reflexivity.
  - (* <- *)
    intros Hxy Htp.
    rewrite Hxy.
    split; intro; assumption.
Qed.

(** ** 練習問題 3.2 or'_ok、False'_ok および Equal'_ok を証明せよ。*)


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime binomial.
From mathcomp Require Import ssralg finset fingroup finalg perm zmodp matrix.
Require Import ssr_ext ssralg_ext num_occ f2 ssrR hamming tanner linearcode.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope num_occ_scope.
Local Open Scope ring_scope.
Import GRing.Theory.

Local Open Scope vec_ext_scope.

(** * Sum-Product Decoder over the BEC *)

(** OUTLINE
- Section letter.
- Section Sum_Prod_def.
- Section Sum_prop.
- Section Prod_prop.
- Section starletter_prop
- Section SumProd_algo_mxStar.
- Section mat_approx.
- Section mxSumProd_def : contains the definitions of rowVnextD1, etc.
- Section SumProdBEC_algo.
*)

Section letter.

Inductive letter := Bit of 'F_2 | Star | Blank.

Definition eql (a b : letter) :=
  match a, b with
  | Bit a', Bit b' => a' == b'
  | Star, Star => true
  | Blank, Blank => true
  | _, _ => false
  end.

Lemma eqlP : Equality.axiom eql.
Proof.
move=> a b; apply: (iffP idP) => [|<-]; last first.
  case: a => // a'; by rewrite /= eqxx.
case: a b; [|by case|by case].
by move=> a'; case => //= b' /eqP ->.
Qed.

Canonical letter_eqMixin := EqMixin eqlP.
Canonical letter_eqType := Eval hnf in EqType letter letter_eqMixin.

CoInductive letter_spec : letter -> bool -> bool -> bool -> bool -> Prop :=
| letter_spec0 : letter_spec (Bit 0) true false false false
| letter_spec1 : letter_spec (Bit 1) false true false false
| letter_specstar : letter_spec Blank false false true  false
| letter_specblank : letter_spec Star false false false true.

Lemma letterP l : letter_spec l (l == Bit 0) (l == Bit 1) (l == Blank) (l == Star).
Proof.
case: l; [|by constructor|by constructor].
case/F2P; by constructor.
Qed.

Definition letter_pickle (l : letter) :=
  match l with
  | Bit a => if a == (Zp0 : 'F_2) then O else 1%N
  | Star => 2
  | Blank => 3%N
  end.

Definition letter_unpickle (n : nat) :=
  match n with
  | O => Some (Bit 0)
  | 1 => Some (Bit 1)
  | 2 => Some Star
  | 3 => Some Blank
  | _ => None
  end.

Lemma letter_count : pcancel letter_pickle letter_unpickle.
Proof. by case/letterP. Qed.

Definition letter_choiceMixin := PcanChoiceMixin letter_count.
Canonical letter_choiceType := Eval hnf in ChoiceType letter letter_choiceMixin.

Definition letter_countMixin := PcanCountMixin letter_count.
Canonical letter_countType := Eval hnf in CountType letter letter_countMixin.

Lemma letter_enumP : Finite.axiom [::Bit 0; Bit 1; Star; Blank].
Proof. by case => //; case/F2P. Qed.

Definition letter_finMixin := Eval hnf in FinMixin letter_enumP.
Canonical letter_finType := Eval hnf in FinType letter letter_finMixin.

Definition F2_of_letter (l : letter) : 'F_2 := if l is Bit a then a else 0.

Definition lel (a b : letter) :=
  (a == b) || if a is Bit _ then b == Star else false.

Local Notation "A '<=l' B" := (lel A B) (at level 20).

Lemma lell x : x <=l x.
Proof. by rewrite /lel eqxx orTb. Qed.

Lemma lel_Bit a b : (a <=l Bit b) = (a == Bit b).
Proof.
apply/idP/idP => [|/eqP ->]; last by rewrite lell.
case/letterP : a b => //; by case/F2P.
Qed.

Lemma lel_Star l : Star <=l l -> l = Star.
Proof. by case/letterP : l. Qed.

Lemma lel_Blank l : Blank <=l l -> l = Blank.
Proof. by case/letterP : l. Qed.

Lemma lel_trans : transitive lel.
Proof. by do 3 case/letterP. Qed.

(* lel lifted to matrices *)
Definition mxlel m n (A B : 'M[letter]_(m, n)) := [forall m, [forall n, A m n <=l B m n]].

Local Notation "A '<=m' B" := (mxlel A B) (at level 20).

Lemma lell_mat m0 n0 (A : 'M[letter]_(m0, n0)) : A <=m A.
Proof. rewrite /mxlel; apply/'forall_forallP => i j; exact: lell. Qed.

Lemma lel_trans_mat m0 n0 : transitive (@mxlel m0 n0).
Proof.
move=> A B C /'forall_forallP /= H1 /'forall_forallP H2.
apply/'forall_forallP => m1 n1; by apply: (lel_trans (H1 _ _) (H2 _ _)).
Qed.

Definition sum_letter (t : seq letter) := \sum_(l <- t) F2_of_letter l.

Definition is_Bit (l : letter) := if l is Bit _ then true else false.

Definition starblank l := ~~ is_Bit l.

Lemma starblankP x : reflect (starblank x) ((x == Star) || (x == Blank)).
Proof. apply/(iffP idP); by [case/orP => /eqP -> | case/letterP : x]. Qed.

Lemma letter_split (l : letter) : [exists b, l == Bit b] || (starblank l).
Proof.
case/letterP : l; rewrite ?orbT //.
by apply/orP; left; apply/existsP; exists 0.
by apply/orP; left; apply/existsP; exists 1.
Qed.

End letter.

Notation "A '<=l' B" := (lel A B) (at level 20) : letter_scope.
Notation "A '<=m' B" := (mxlel A B) (at level 20) : letter_scope.
Local Open Scope letter_scope.
Local Open Scope num_occ_scope.

Section Sum_Prod_def.

Definition Sum (s : seq letter) :=
  if has starblank s then Star
  else Bit (sum_letter (filter is_Bit s)).

Definition Prod (s : seq letter) :=
  if N(Bit 0 | s) > N(Bit 1 | s) then Bit 0
  else if N(Bit 0 | s) < N(Bit 1 | s) then Bit 1
  else Star.

End Sum_Prod_def.

Section Sum_prop.

Lemma Sum_blank_inv s : Sum s != Blank.
Proof. rewrite /Sum; by case: ifP. Qed.

Lemma le_Sum_Star s : Sum s <=l Star.
Proof. rewrite /Sum; by case: ifPn. Qed.

End Sum_prop.

Section Prod_prop.

Lemma Prod_filter_Star m n (A : 'M[letter]_(m, n)) n0 (s : {set 'I_m}) :
  Prod [seq A m0 n0 | m0 in s]  =
  Prod [seq A m0 n0 | m0 <- enum s & A m0 n0 != Star].
Proof.
rewrite /Prod; case: ifPn => [H|];
  do 2 rewrite (num_occ_map_filter [pred x | x != Star]) //.
- by rewrite H.
- rewrite -leqNgt leq_eqVlt => /orP[/eqP|] H;
    by [rewrite H ltnn | rewrite H ltnNge (ltnW H)].
Qed.

Lemma Prod1 l : l != Blank -> Prod [:: l] = l.
Proof. by case/letterP : l. Qed.

Lemma Prod_cons_Star s : Prod (Star :: s) = Prod s.
Proof. by []. Qed.

Lemma Prod_starblank_is_Star s : all starblank s -> Prod s = Star.
Proof.
move=> K.
rewrite /Prod.
suff : forall x : 'F_2, N(Bit x | s) = O by move=> X; rewrite 2!X.
move=> x.
apply/eqP; rewrite -notin_num_occ_0.
move/allP : K => /(_ (Bit x))/contra; exact.
Qed.

Lemma Prod_nseq_not_blank n x : n != O -> x != Blank -> Prod (nseq n x) = x.
Proof.
elim: n x => //= n IH x _ xblank; rewrite /Prod /=.
case/letterP : x xblank => //= _.
- rewrite add0n add1n (_ : N(Bit 1 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
- rewrite (_ : N(Bit 0 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
- rewrite !add0n (_ : N(Bit 1 | _) = O); last first.
    apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
  rewrite (_ : N(Bit 0 | _) = O) //.
  apply/eqP; rewrite -notin_num_occ_0; apply/nseqP; by case.
Qed.

Lemma Prod_Bit (b : 'F_2) s : Prod s = Bit b -> Bit b \in s.
Proof.
rewrite /Prod.
case: ifPn => [H [<-] | H]; first by rewrite mem_num_occ_gt0 (leq_trans _ H).
case: ifPn => // H' [<-]; by rewrite mem_num_occ_gt0 (leq_trans _ H').
Qed.

Lemma Prod_cons (x : letter) h t :
  Prod [:: h] = x /\ (Prod t = x \/ Prod t = Star) ->
  Prod (h :: t) = x.
Proof.
case=> H1 H2.
rewrite /Prod /=.
case/letterP : h H1 => /=; rewrite {1}/Prod /= => ?; subst x; rewrite ?(addn0,addn1,add0n).
- case: H2; rewrite {1}/Prod.
    case: ifPn => [H3 _|].
      by rewrite ltnS leq_eqVlt H3 orbT.
    rewrite -leqNgt leq_eqVlt.
    case/orP => [/eqP ->|->//].
    by rewrite ltnn.
  case: ifPn => //; rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP|] -> //.
  rewrite ltnn => _ /=; by rewrite ltnS leqnn.
- case: H2; rewrite {1}/Prod.
    case: ifPn => [//|].
    rewrite -leqNgt leq_eqVlt.
    case/orP => [/eqP ->|H3].
      by rewrite ltnn.
    rewrite H3 => _.
    rewrite {1}add1n (leq_trans _ (leqnSn _)) // ltnNge ltnW //.
    by apply/leq_trans: H3.
  case: ifPn => //.
  rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP|] -> //.
  rewrite ltnn => _.
  by rewrite add1n ltnSn /= ltnNge leqnSn.
- by case: H2.
- by case: H2.
Qed.

Lemma Prod_StarE (s : seq letter) :
  (Prod s == Star) = [forall b, N(Bit (F2_of_bool b) | s) == N(Bit (F2_of_bool (~~ b)) | s)].
Proof.
apply/idP/idP => [| /forallP H0].
  rewrite /Prod.
  case: ifP => //.
  move/negbT.
  rewrite -leqNgt leq_eqVlt.
  case/orP => [/eqP H1|H1].
    rewrite H1 ltnn => _; apply/forallP; case; by apply/eqP.
  by rewrite H1.
by rewrite /Prod (eqP (H0 true)) ltnn.
Qed.

Lemma Prod_map_not_Star m n (A : 'M_(m, n)) n0 (s : {set 'I_m}) :
  Prod [seq A m1 n0 | m1 in s] != Star ->
  exists b m1, m1 \in s /\ A m1 n0 = Bit b.
Proof.
rewrite Prod_StarE negb_forall => /existsP[b Hb].
case/boolP : (N(Bit (F2_of_bool (b : bool)) | [seq A m1 n0 | m1 in s]) == O) => [H0|].
  have : 0 < N(Bit (F2_of_bool (~~ b)) | [seq A m1 n0 | m1 in s]).
    by rewrite lt0n; apply: contra Hb => /eqP ->.
  rewrite lt0n -notin_num_occ_0 negbK => /mapP[i Hi].
  exists (F2_of_bool (~~ b)), i; by rewrite mem_enum in Hi.
rewrite -notin_num_occ_0 negbK => /mapP[i Hi] H1.
exists (F2_of_bool b), i; by rewrite mem_enum in Hi.
Qed.

End Prod_prop.

Section starletter_prop.

Definition starletter x y := (x == Star) || (x == Bit y).

Lemma starletter_letter x : starletter (Bit x) x.
Proof. by rewrite /starletter eqxx orbC. Qed.

Lemma Prod_starletter m n (A : 'M_(m, n)) n0 (b : 'F_2) (s : {set 'I_m}):
  all [pred i | starletter (A i n0) b] (enum s) ->
  (exists2 i, i \in s & A i n0 != Star) ->
  Prod [seq A i n0 | i <- enum s] = Bit b.
Proof.
move=> H0 IH.
rewrite (Prod_filter_Star A n0 s).
set tmp := [seq _ | _ <- _ & _].
rewrite (_ : tmp = nseq (size tmp) (Bit b)); last first.
  apply: all_pred1P.
  apply/allP => /= x0.
  case/mapP => /= m1 Hm1 x0m1.
  rewrite x0m1.
  rewrite mem_filter in Hm1.
  case/andP : Hm1 => m1star Hm1.
  move/allP : H0 => /(_ m1); rewrite mem_enum => H0.
  have /H0 : m1 \in s by move: Hm1; rewrite mem_enum.
  by rewrite /= /starletter (negbTE m1star).
rewrite Prod_nseq_not_blank // /tmp size_map size_filter -lt0n -has_count.
apply/hasP.
case: IH => i H1 H2.
exists i => //; by rewrite mem_enum.
Qed.

Lemma Prod_cons_starletter m n (b : 'F_2) n0 (s : {set 'I_m}) (M : 'M[letter]_(m, n)):
  all [pred i | starletter (M i n0) b] (enum s) ->
  Prod (Bit b :: [seq M i n0 | i in s]) = Bit b.
Proof.
move=> /= H1.
apply/Prod_cons.
rewrite Prod1 //; split => //.
set l := [seq _ | _ in _].
case/boolP : (Bit b \in l) => Hl.
  left.
  transitivity (Prod [seq M m0 n0 | m0 <- (enum s)]) => //.
  apply (Prod_starletter H1).
  case/mapP : Hl => m1 H2 H3.
  exists m1; rewrite -?H3 //; by rewrite mem_enum in H2.
right.
rewrite (_ : l = nseq (size l) Star); last first.
  apply/all_pred1P/allP => /= x.
  case/mapP => m1 Hm1 Hx.
  move: H1 => /allP H1.
  case/orP: (H1 _ Hm1) => [|abs].
    by rewrite Hx.
  exfalso.
  move/negP : Hl; apply.
  apply/mapP; exists m1 => //.
  by rewrite (eqP abs).
apply/Prod_starblank_is_Star; by rewrite all_nseq orbT.
Qed.

Lemma Kop_proof x1 x2 x3 y1 y2 y3 :
  (x3 <= x2) && ((x3 == x2) ==> x1) ->
  (y3 <= y2) && ((y3 == y2) ==> y1) ->
  (x3 + y3 <= x2 + y2) && ((x3 + y3 == x2 + y2)%nat ==> x1 && y1).
Proof.
move=> /andP [Hx Hx1] /andP [Hy Hy1].
rewrite (@leq_trans (x3+y2)) ?leq_add2r //=.
  apply/implyP=> H3.
  move/implyP: Hx1 => ->.
    move/implyP: Hy1 => -> //.
    rewrite -(leq_add2r y3) (eqP H3) leq_add2l in Hx.
    by rewrite eqn_leq Hy Hx.
  rewrite -(leq_add2l x3) (eqP H3) leq_add2r in Hy.
  by rewrite eqn_leq Hx Hy.
by rewrite leq_add2l Hy.
Qed.

Definition num_stars m n (A : 'M[letter]_(m, n)) : nat :=
  \sum_(m0 < m) \sum_(n0 < n) (A m0 n0 == Star).

Lemma lmat_le_decr m n (A B : 'M_(m, n)) :
  A <=m B -> (A == B) || (num_stars A < num_stars B).
Proof.
move=> Hle.
suff : (num_stars A <= num_stars B) && ((num_stars A == num_stars B) ==>
       \big[andb/true]_(i < m) (row i A == row i B)).
  case/andP => A_le_B.
  case/boolP : (_ == _) => [A_eq_B|A_not_B _] /=.
    rewrite big_all => Hall.
    apply/orP; left.
    apply/eqP/row_matrixP => i.
    move/allP/(_ i) : Hall.
    by rewrite mem_index_enum => /(_ isT)/eqP.
  by rewrite ltn_neqAle A_le_B A_not_B orbT.
rewrite /num_stars.
elim/big_ind3 : _ => //.
  by apply Kop_proof.
move=> i _.
set lft := (_ <= _).
set rgt := (_ == _).
suff : lft && (rgt ==> \big[andb/true]_(j < n) (A i j == B i j)).
  rewrite /lft /rgt.
  case/andP => ->.
  case/boolP : (_ == _) => ? //=.
  rewrite big_all => Hall.
  apply/eqP/rowP => j.
  move/allP/(_ j): Hall.
  by rewrite mem_index_enum !mxE => /(_ isT)/eqP.
rewrite /lft /rgt.
elim/big_ind3 : _ => //.
  apply Kop_proof.
move=> j _.
move/'forall_forallP : Hle => /(_ i j).
by case/letterP : (A i j); case/letterP : (B i j).
Qed.

End starletter_prop.

Section SumProd_algo_mxStar.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''F'" := (Fnext H).

Definition mxStar := \matrix_(i < m, j < n) if i \in 'F j then Star else Blank.

Lemma mxStarE i j : i \in 'F j -> mxStar i j = Star.
Proof. rewrite /mxStar => ij; by rewrite mxE ij. Qed.

Lemma all_mxStar n0 : all [pred i | mxStar i n0 == Star] (enum ('F n0)).
Proof.
apply/allP => m0 Hm0; by rewrite inE mxStarE // -mem_enum.
Qed.

Lemma Prod_mxStar_col_Star n0 (s : {set 'I_m}) : Prod [seq (col n0 mxStar) m0 ord0 | m0 in s] = Star.
Proof.
rewrite Prod_starblank_is_Star //=; apply/allP => y' /mapP [x Hx ->].
rewrite 2!mxE; by case: ifPn.
Qed.

End SumProd_algo_mxStar.

Section mat_approx.

Variable (m n : nat).

Definition blank_to_star a := if a == Blank then Star else a.

Lemma Bit_col l b (bl : Bit b <=l l) (A : 'cV[letter]_m) (s : {set 'I_m}) :
  (forall i : 'I_m, Bit b <=l blank_to_star (A i ord0)) ->
  forall b' : 'F_2, Bit b' \in l :: [seq A m0 ord0 | m0 in s] -> b' = b.
Proof.
move=> Ha b'.
rewrite in_cons => /orP [Hy|].
  by move: bl; rewrite -(eqP Hy) lel_Bit => /eqP[].
move/mapP => [x Hx Hf].
by move: (Ha x); rewrite -Hf lel_Bit => /eqP[].
Qed.

Lemma Prod_cons_Bit l b (bl : Bit b <=l l) (A : 'cV[letter]_m) (s : {set 'I_m}) :
  (forall i, Bit b <=l blank_to_star (A i ord0)) ->
  has is_Bit (l :: [seq A m0 ord0 | m0 in s]) ->
  Prod (l :: [seq A m0 ord0 | m0 in s]) = Bit b .
Proof.
move=> Ha.
rewrite /Prod.
set lst := l :: _ => Hb.
case/boolP : (Bit 0 \in lst) => Hin0.
  case/boolP : (Bit 1 \in lst) => Hin1.
    move: (Bit_col bl Ha Hin0).
    by rewrite -(Bit_col bl Ha Hin1).
  move: Hin1; rewrite notin_num_occ_0 => /eqP ->.
  by rewrite -(Bit_col bl Ha Hin0) ltn0 lt0n -notin_num_occ_0 Hin0.
move: (Hin0); rewrite notin_num_occ_0 => /eqP ->.
case/boolP : (Bit 1 \in lst) => Hin1.
  by rewrite -(Bit_col bl Ha Hin1) ltn0 lt0n -notin_num_occ_0 Hin1.
case/hasP : Hb.
case/letterP => //; by [rewrite (negbTE Hin0) | rewrite (negbTE Hin1)].
Qed.

Definition approx (c : 'rV['F_2]_n) (M : 'M[letter]_(m, n)) :=
  [forall i, map_mx Bit c <=m map_mx blank_to_star (row i M)].

Local Notation "c <=* M" := (approx c M) (at level 20).

Lemma approx_mxStar H y : y <=* mxStar H.
Proof.
apply/'forall_forallP => /= m0 ord1.
apply/forallP => /= n0; rewrite !mxE; by case: ifP => [|] _.
Qed.

End mat_approx.

Notation "y <=* A" := (approx y A) (at level 20) : letter_scope.

Section mxSumProd_def.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Section rowVnext.

Definition rowVnextD1 (r : 'rV[letter]_n) n0 m0 : seq letter :=
  [seq r ``_ i | i in 'V n0 :\ m0].

Lemma sum_rowVnextD1 (c : 'rV['F_2]_n) (r : 'rV[letter]_n) m0 n0 :
  (forall j : 'I_n, j \in 'V m0 :\ n0 -> r ``_ j = Bit (c ``_ j)) ->
  sum_letter (filter is_Bit (rowVnextD1 r m0 n0)) = \sum_(i0 in 'V m0 :\ n0) c ``_ i0.
Proof.
move=> H0.
rewrite /sum_letter big_filter big_map big_mkcond /= big_filter.
apply eq_bigr => n1 Hn1; by rewrite H0.
Qed.

Section rowVnext_codeword.

Variables (c : 'rV['F_2]_n) (Hc : syndrome H c = 0).

Lemma sum_rowVnextD1_nostars m0 n0 (r : 'rV[letter]_n) :
  (forall j, j \in 'V m0 :\ n0 -> r ``_ j = Bit (c ``_ j)) ->
  m0 \in 'F n0 ->
  let s := rowVnextD1 r m0 n0 in
  ~~ has starblank s ->
  sum_letter (filter is_Bit s) = c ``_ n0.
Proof.
move=> H0 m0n0 s starblank.
move/matrixP/(_ ord0 m0) : Hc.
rewrite !mxE (bigD1 n0) //= => Hc'.
set rhs := \sum_(_ < _ | _) _ in Hc'.
have Hrhs : rhs = \sum_(i0 < _ | i0 \in 'V m0 :\ n0) c ``_ i0.
  rewrite /rhs.
  transitivity (\sum_(H0 < n | (H0 != n0) && (m0 \in 'F H0)) H m0 H0 * c^T H0 ord0).
    rewrite (bigID (fun j => m0 \in 'F j)) /=.
    rewrite (_ : \sum_(i0 < n | (i0 != n0) && (m0 \notin 'F i0)) H m0 i0 * c^T i0 ord0 = 0).
      by rewrite addr0.
    rewrite (eq_bigr (fun=> 0)).
      by rewrite big_const /= iter_addr0.
    move=> /= i0 /andP[] i0j.
    rewrite FnextE VnextE tanner_relE -F2_eq0 => /eqP ->; by rewrite mul0r.
  apply eq_big.
    by move=> j0 /=; rewrite in_setD1 FnextE.
  move=> i0 /andP[] H1.
  rewrite FnextE VnextE tanner_relE => /eqP ->; by rewrite mul1r mxE.
rewrite Hrhs (_ : H _ _ = 1) ?mul1r ?mxE in Hc'; last first.
  move: m0n0; by rewrite FnextE VnextE tanner_relE => /eqP.
move/eqP : Hc'.
rewrite addr_eq0 => /eqP ->.
rewrite (@sum_rowVnextD1 c) ?oppr_char2 // => *; by rewrite mxE H0.
Qed.

Lemma sum_rowVnextD1_Bit m0 n0 (m0n0 : m0 \in 'F n0) (r : 'rV[letter]_n) :
  (forall n1, n1 \in 'V m0 :\ n0 -> r ``_ n1 = Bit c ``_ n1) ->
  Sum (rowVnextD1 r m0 n0) = Bit c ``_ n0.
Proof.
move=> H0.
rewrite /Sum.
case: ifPn => [|Hx].
  case/hasP => /= x.
  case/mapP => /= n1.
  by rewrite mem_enum => /H0 -> ->.
rewrite sum_rowVnextD1_nostars // => *; by rewrite mxE H0.
Qed.

End rowVnext_codeword.

End rowVnext.

Section colFnext.

Definition ColFnext (l : letter) (c : 'cV[letter]_m) (s : {set 'I_m}) :=
  l :: [seq c m0 ord0 | m0 in s].

Lemma Prod_colFnext_Bit (b : 'F_2) (c : 'cV[letter]_m) (s : {set 'I_m}) :
  all [pred i | starletter (c i ord0) b] (enum s) ->
  Prod (ColFnext (Bit b) c s) = Bit b.
Proof.
move=> /= H1.
apply/Prod_cons.
rewrite Prod1 //; split => //.
set l := [seq _ | _ in _].
case/boolP : (Bit b \in l) => Hlst.
- left.
  apply Prod_starletter.
    apply/allP => x xFn0m0.
    by move: H1 => /allP/(_ x) /(_ xFn0m0).
  case/mapP : Hlst => m1 H2 H3.
  exists m1; rewrite -?H3 //; by rewrite mem_enum in H2.
- right.
  rewrite (_ : l = nseq (size l) Star); last first.
    apply/all_pred1P/allP => /= x.
    case/mapP => m1 Hm1 Hx.
    move: H1 => /allP/(_ _ Hm1).
    rewrite /= /starletter -Hx.
    case/orP => // xBitb.
    exfalso.
    move: Hlst; rewrite /l => /mapP; apply.
    exists m1 => //.
    by rewrite -Hx (eqP xBitb).
  apply/Prod_starblank_is_Star; by rewrite all_nseq orbT.
Qed.

Local Notation "'`F'" := (Fnext H).

Definition colFnext l (c : 'cV[letter]_m) n0 := ColFnext l c (`F n0).

Definition colFnextD1 l (c : 'cV[letter]_m) n0 m0 : seq letter :=
  ColFnext l c (`F n0 :\ m0).

End colFnext.

Definition mxSum M := \matrix_(i < m, j < n)
  if i \in 'F j then Sum (rowVnextD1 (row i M) i j) else M i j.

Definition mxProd (y : 'rV[letter]_n) M := \matrix_(i < m, j < n)
  if i \in 'F j then Prod (colFnextD1 (y ``_ j) (col j M) j i) else M i j.

Lemma has_starblank_rowVnextD1 (A B : 'M_(m, n)) y m0 n0 :
  mxProd y A <=m mxProd y B ->
  has starblank (rowVnextD1 (row m0 (mxProd y A)) m0 n0) ->
  has starblank (rowVnextD1 (row m0 (mxProd y B)) m0 n0).
Proof.
move=> AB /hasP[l l_row Hl]; move: l_row => /mapP[n1 Hn1 ln1].
apply/hasP => /=; exists l => //.
apply/mapP; exists n1 => //.
move/'forall_forallP/(_ m0 n1) : AB.
move: Hl.
rewrite {}ln1 {l} // mxE [(row _ _) _ _]mxE.
move/starblankP => /orP[/eqP ->|/eqP ->]; by [move/lel_Star | move/lel_Blank].
Qed.

Definition mxSumProd (y : 'rV[letter]_n) := mxSum \o mxProd y.

Lemma mxProd_Bit (y : 'rV[letter]_n) n0 (c : 'F_2) (cy : Bit c <=l y ``_ n0) (A : 'M[letter]_(m, n)) :
  (forall i, Bit c <=l blank_to_star (A i n0)) -> forall m0 b, mxProd y A m0 n0 = Bit b -> b = c.
Proof.
move=> Ha m0 b.
rewrite /mxProd mxE.
case: ifP => m0n0.
  move/Prod_Bit => mem_b.
  have Ha' : forall i : 'I_m, Bit c <=l blank_to_star ((col n0 A) i ord0).
    move=> i; move: Ha => /(_ i); by rewrite !mxE.
  apply: (@Bit_col _ _ _ cy _ ('F n0 :\ m0) Ha').
  move: mem_b; rewrite inE; case/orP => [/eqP <-|mem_b].
    by rewrite eqxx.
  apply/orP; right.
  case/mapP : mem_b => x Hx Hx'.
  apply/mapP; by exists x.
by move=> Hf; move: Ha => /(_ m0); rewrite Hf lel_Bit => /eqP[].
Qed.

Lemma mxProd_monotone y c (c_le_y : map_mx Bit c <=m y) A B : c <=* A -> c <=* B ->
  A <=m B -> mxProd y A <=m mxProd y B.
Proof.
move=> y'A y'B AB.
apply/'forall_forallP => m0 n0.
move Hpa' : (mxProd y B m0 n0) => b.
case/orP : (letter_split b) Hpa' => [/existsP[b' /eqP -> Hpa']|].
  move/'forall_forallP : c_le_y => /(_ ord0 n0); rewrite mxE => c_le_y'.
  have y'B' : forall i : 'I_m, Bit c ``_ n0 <=l blank_to_star (B i n0).
    move=> i.
    by move/'forall_forallP : y'B => /(_ i ord0)/forallP/(_ n0); rewrite !mxE.
  rewrite (mxProd_Bit c_le_y' y'B' Hpa').
  have y'A' : forall i : 'I_m, Bit c ``_ n0 <=l blank_to_star (A i n0).
    move=> i.
    by move/'forall_forallP : y'A => /(_ i ord0)/forallP/(_ n0); rewrite !mxE.
  move Hpa : (mxProd y A m0 n0) => c'.
  case/orP : (letter_split c') Hpa => [/existsP[c'' /eqP -> Hpa]|Hc' Hpa].
    by rewrite (mxProd_Bit c_le_y' y'A' Hpa) lell.
  rewrite /mxProd !mxE in Hpa Hpa'.
  case: ifP => Hi in Hpa Hpa'.
    rewrite (Prod_cons_Bit c_le_y') in Hpa => //.
      by rewrite -Hpa lell.
      move=> i.
      move/'forall_forallP : y'A => /(_ i ord0)/forallP/(_ n0).
      by rewrite !mxE.
    apply/hasP; exists (Bit b') => //.
    move/Prod_Bit: Hpa'.
    rewrite in_cons => /orP [|].
      by rewrite in_cons => ->.
    move/mapP=> [k Hk Hk'].
    move/'forall_forallP/(_ k n0): AB.
    move: Hk'; rewrite mxE => <-; rewrite lel_Bit => /eqP <-.
    rewrite in_cons; apply/orP; right.
    apply/mapP; exists k => //; by rewrite mxE.
  move/'forall_forallP/(_ m0 n0) : AB Hc'.
  by rewrite Hpa Hpa' lel_Bit => /eqP ->.
move=> Hb Hpa'.
move: Hpa' Hb.
rewrite /mxProd !mxE.
case: ifPn => [Hi|Hi <-].
  rewrite /Prod.
  case: ifPn => // H1 <- //; case: ifPn => //; case: ifPn => //; by case: ifPn.
by move/'forall_forallP/(_ m0 n0) : AB.
Qed.

Lemma mxSumProd_monotone A B y (c : 'rV['F_2]_n) (c_le_y : map_mx Bit c <=m y) :
  c <=* A -> c <=* B ->
  A <=m B -> mxSumProd y A <=m mxSumProd y B.
Proof.
move => Ha Ha' Haa'.
apply/'forall_forallP => m0 n0.
rewrite /mxSumProd !mxE.
case: ifP => Hi.
  rewrite /Sum.
  case: ifPn => [Hn1 | _].
    case: ifPn => // /negP Hn2.
    exfalso; apply Hn2; move: Hn1.
    exact/has_starblank_rowVnextD1/(mxProd_monotone c_le_y).
  case: ifPn => // Hn2.
  apply/orP; left.
  apply/eqP; congr Bit.
  rewrite /sum_letter 2!big_filter 2!big_map [in LHS]big_mkcond /=.
  rewrite [in RHS]big_mkcond /= 2!big_filter; apply eq_bigr => i Hi'.
  rewrite 2![(row _ _) _ _]mxE.
  move/forallP/(_ m0)/forallP/(_ i): (mxProd_monotone c_le_y Ha Ha' Haa') => /orP [/eqP -> //|].
  move: Hn2.
  move HB : (mxProd y A m0 i) => a.
  case/letterP : a HB => //= _ Hn2 /eqP.
    by move=> -> /=.
  move=> abs.
  exfalso.
  move/negP : Hn2; apply.
  apply/hasP; exists Star => //.
  apply/mapP; exists i => //.
  by rewrite mem_enum.
  by rewrite mxE.
rewrite Hi.
move/'forall_forallP : Haa'; by apply.
Qed.

Section mxSumProd_codeword.

Variables (c : 'rV['F_2]_n) (Hc : syndrome H c = 0).
Variables (y : 'rV[letter]_n) (c_le_y : map_mx Bit c <=m y).

Lemma approx_mxSumProd M : c <=* M -> c <=* mxSumProd y M.
Proof.
move=> cA.
apply/'forall_forallP => /= m0 k; rewrite {k}(ord1 k).
apply/forallP=> /= j.
rewrite 4!mxE.
case: ifPn => m0Fj; last first.
  rewrite mxE (negbTE m0Fj).
  move/'forall_forallP/(_ m0 ord0) : cA => /forallP/(_ j).
  by rewrite 3!mxE.
rewrite /Sum.
case: ifPn => // nostars.
apply/orP; left; apply/eqP; congr Bit.
rewrite (sum_rowVnextD1_nostars Hc) //= => n1 Hn1.
rewrite mxE.
move Hia : (mxProd y M m0 n1) => b.
case/orP : (letter_split b) Hia => [/existsP[/= b' /eqP -> Hia]|Hb Hia].
  move/'forall_forallP : c_le_y => /(_ ord0 n1); rewrite !mxE => c_le_y'.
  have Ha' : forall i : 'I_m, Bit c ``_ n1 <=l blank_to_star (M i n1).
    move=> i.
    by move/'forall_forallP : cA => /(_ i ord0)/forallP/(_ n1); rewrite !mxE.
  by rewrite (mxProd_Bit c_le_y' Ha' Hia).
move: nostars.
rewrite -all_predC.
move/allP => /=.
move/(_ b).
have X : b \in rowVnextD1 (row m0 (mxProd y M)) m0 j.
  rewrite -Hia.
  apply/mapP => /=.
  exists n1 => //; by rewrite ?(mxE, mem_enum).
move/(_ X).
by rewrite Hb.
Qed.

Lemma mxSumProd_invariant A : c <=* A -> mxSumProd y A <=m A ->
  c <=* mxSumProd y (mxSumProd y A) && mxSumProd y (mxSumProd y A) <=m mxSumProd y A.
Proof.
move=> Hap Halpha.
have Hap' := approx_mxSumProd Hap.
have Hap'' := approx_mxSumProd Hap'.
rewrite Hap'' /=.
by apply (mxSumProd_monotone c_le_y).
Qed.

End mxSumProd_codeword.

End mxSumProd_def.

Definition BEC_IO m n (H : 'M['F_2]_(m, n)) c y :=
  syndrome H c = 0 /\ map_mx Bit c <=m y.

Notation "x 'BEC(' H ')' y" := (BEC_IO H x y) (at level 20, format "x  'BEC('  H  ')'  y") : bec_scope.
Local Open Scope bec_scope.

Definition approx_BEC_input m n (H : 'M['F_2]_(m, n)) (y : 'rV[letter]_n) (M : 'M[letter]_(m, n)) :=
  exists2 c, c BEC( H ) y & c <=* M.

Section SumProdBEC_algo.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).

Local Notation "''F'" := (Fnext H).

Require Program.Wf.

Obligation Tactic := idtac.

Program Fixpoint SP_BEC0_rec y M
  (_ : approx_BEC_input H y M) (_ : mxSumProd H y M <=m M)
  { measure (num_stars M) } :
  {M' | mxSumProd H y M' = M' /\ M' <=m M /\ exists k, M' = iter k (mxSumProd H y) M} :=
  let M0 := mxSumProd H y M in
  match Bool.bool_dec (M == M0) true with
  | left H => M
  | right H => @SP_BEC0_rec y M0 _ _ _
  end.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
move/eqP : {Heq_anonymous} H0.
rewrite /M0 => <-; split => //.
split; [exact: lell_mat | by exists O].
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
exists y' => //; by apply approx_mxSumProd.
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
by case/andP: (mxSumProd_invariant Hy'1 Hy'2 y'a lelM).
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: BEC_y => y' [Hy'1 Hy'2] y'a.
move/andP: (mxSumProd_invariant Hy'1 Hy'2 y'a lelM) => [Ha' Hle'].
move: (lmat_le_decr lelM) => /orP [Heq|/leP] //.
elim H0.
by rewrite /M0 (eqP Heq) eqxx.
Qed.
Next Obligation.
move=> y M BEC_y lelM SP_BEC0_rec M0 filtered_var H0 Heq_anonymous.
case: (SP_BEC0_rec _ _ _ _) => H' [H'fix [H'app [k Htmp]]].
split => //=.
split; first by apply: (lel_trans_mat H'app).
exists k.+1; by rewrite -addn1 iter_add.
Qed.
Next Obligation.
by apply/Wf.measure_wf/Wf_nat.lt_wf.
Defined.

Variable (y : 'rV[letter]_n).
Hypothesis BEC_y : exists c : 'rV['F_2]_n, c BEC( H ) y.

Lemma approx_BEC_input_mxStar : approx_BEC_input H y (mxStar H).
Proof. case: BEC_y => c cy; exists c => //; exact: approx_mxStar. Qed.

Lemma lelmxStar : mxSumProd H y (mxStar H) <=m mxStar H.
Proof.
apply/'forall_forallP => m0 n0; rewrite !mxE.
case: ifP => m0n0 /=; first exact: le_Sum_Star.
by rewrite m0n0 /= lell.
Qed.

Definition SP_BEC0 := projT1 (SP_BEC0_rec approx_BEC_input_mxStar lelmxStar).

Lemma SP_BEC0_is_a_fixpoint : SP_BEC0 = mxSum H (mxProd H y SP_BEC0).
Proof. rewrite /SP_BEC0; by case: SP_BEC0_rec => H' []. Qed.

Lemma SP_BEC0_is_mxlel : SP_BEC0 <=m mxStar H.
Proof. by rewrite /SP_BEC0; case: SP_BEC0_rec => H' [? []]. Qed.

Definition iSP_BEC0 k := iter k (mxSumProd H y) (mxStar H).

Lemma SP_BEC0_is_iter : exists k, SP_BEC0 = iSP_BEC0 k.
Proof. by rewrite /SP_BEC0; case: SP_BEC0_rec => H' [? []]. Qed.

Lemma iSP_BEC0_Blank : forall l m0 n0, m0 \notin 'F n0 ->
  (iSP_BEC0 l) m0 n0 = Blank.
Proof.
elim=> [m0 n0 m0n0 | l IH m0 n0 m0n0]; by rewrite /= !mxE (negbTE m0n0) ?IH.
Qed.

(* nth iteration + Product step *)
Definition PiSP_BEC0 l := mxProd H y (iSP_BEC0 l).

Definition Esti (M : 'M[letter]_(m, n)) : 'rV[letter]_n :=
  \row_i Prod (colFnext H (y ``_ i) (col i M) i).

Definition SP_BEC := Esti SP_BEC0.

End SumProdBEC_algo.

(*
Check bp_erasure.
Extraction "bp_erasure.ml" bp_erasure.
*)


(***************************************************************************
* Safety for STLC with Datatypes - Definitions                             *
* Extented from "Type Safety for STLC" by                                  *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import List Metatheory.

(***************************************************************************)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_unit  : typ
  | typ_prod  : typ -> typ -> typ
  | typ_sum   : typ -> typ -> typ.

(** Grammar of patterns. *)

Inductive pat : Set :=
  | pat_bvar : pat
  | pat_wild : pat
  | pat_unit : pat
  | pat_pair : pat -> pat -> pat
  | pat_inj1 : pat -> pat
  | pat_inj2 : pat -> pat.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_fix  : trm -> trm
  | trm_match: trm -> pat -> trm -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_unit : trm
  | trm_pair : trm -> trm -> trm
  | trm_inj1 : trm -> trm
  | trm_inj2 : trm -> trm.

(** Arity of a pattern. *)

Fixpoint pat_arity (p : pat) : nat :=
  match p with
  | pat_bvar       => 1
  | pat_wild       => 0
  | pat_unit       => 0
  | pat_pair p1 p2 => (pat_arity p1) + (pat_arity p2)
  | pat_inj1 p1    => (pat_arity p1)
  | pat_inj2 p1    => (pat_arity p1)
  end.

(** Pattern matching. *)

Fixpoint pat_match (p : pat) (t : trm) {struct p} : option (list trm) :=
  match p, t with
  | pat_bvar      , t1             => Some (t1::nil)
  | pat_wild      , t1             => Some nil
  | pat_unit      , trm_unit       => Some nil
  | pat_pair p1 p2, trm_pair t1 t2 => match (pat_match p1 t1), (pat_match p2 t2) with
                                      | Some r1, Some r2 => Some (r1 ++ r2)
                                      | _      , _       => None end
  | pat_inj1 p1   , trm_inj1 t1    => (pat_match p1 t1)
  | pat_inj2 p1   , trm_inj2 t1    => (pat_match p1 t1)
  | _             , _              => None
  end.

(** Default term and nth function on term lists *)

Definition trm_def := trm_bvar 0 0.

Definition trm_nth n ts := List.nth n ts trm_def.

(** Opening up abstractions *)

Fixpoint opens_rec (k : nat) (us : list trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i j  => if k === i then (trm_nth j us) else (trm_bvar i j)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (opens_rec (S k) us t1)
  | trm_fix t1    => trm_fix (opens_rec (S k) us t1)
  | trm_match t1 p1 e t2 => trm_match (opens_rec k us t1) p1
                               (opens_rec (S k) us e)
                               (opens_rec (S k) us t2)
  | trm_app t1 t2 => trm_app (opens_rec k us t1) (opens_rec k us t2)
  | trm_unit      => trm_unit
  | trm_pair t1 t2 => trm_pair (opens_rec k us t1) (opens_rec k us t2)
  | trm_inj1 t1   => trm_inj1 (opens_rec k us t1)
  | trm_inj2 t1   => trm_inj2 (opens_rec k us t1)
  end.

Definition opens t us := opens_rec 0 us t.
Definition open t u := opens t (u::nil).
Definition trm_fvars := List.map trm_fvar.

Notation "{ k ~> u } t" := (opens_rec k u t) (at level 67).
Notation "t ^^ us" := (opens t us) (at level 67).
Notation "t ^ xs" := (opens t (trm_fvars xs)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, fresh L 1 (x::nil) ->
        term (t1 ^ (x::nil))) ->
      term (trm_abs t1)
  | term_fix : forall L t1,
      (forall x f, fresh L 2 (x::f::nil) ->
        term (t1 ^ (x::f::nil))) ->
      term (trm_fix t1)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2)
  | term_match : forall L t1 p e t2,
      term t1 ->
      (forall xs, fresh L (pat_arity p) xs -> term (e ^ xs)) ->
      term t2 ->
      term (trm_match t1 p e t2)
  | term_unit :
      term (trm_unit)
  | term_pair : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_pair t1 t2)
  | term_inj1 : forall t1,
      term t1 ->
      term (trm_inj1 t1)
  | term_inj2 : forall t1,
      term t1 ->
      term (trm_inj2 t1).

(** Definition of [bodys n t] as [t ^ xs] is a term when [|xs|=n] *)

Definition bodys n t :=
  exists L : vars, forall xs,
  fresh L n xs -> term (t ^ xs).

(** Environment is an associative list mapping variables to types. *)

Definition env := Env.env typ.

(** Typing relation for patterns: if Ts are the types of the
    bound variables in the pattern p, then the pattern p matches
    values of type T. *)

Reserved Notation "Us \= p ~: T" (at level 69).

Inductive pat_typing : list typ -> pat -> typ -> Prop :=
  | pat_typing_bvar : forall T,
     (T::nil) \= pat_bvar ~: T
  | pat_typing_wild : forall T,
     nil \= pat_wild ~: T
  | pat_typing_unit :
     nil \= pat_unit ~: typ_unit
  | pat_typing_pair : forall p1 p2 T1 T2 Us1 Us2,
     Us1 \= p1 ~: T1 ->
     Us2 \= p2 ~: T2 ->
     (Us1 ++ Us2) \= (pat_pair p1 p2) ~: (typ_prod T1 T2)
  | pat_typing_inj1 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T1 ->
     Us1 \= (pat_inj1 p1) ~: (typ_sum T1 T2)
  | pat_typing_inj2 : forall T2 p1 T1 Us1,
     Us1 \= p1 ~: T2 ->
     Us1 \= (pat_inj2 p1) ~: (typ_sum T1 T2)

where "Ts \= p ~: T" := (pat_typing Ts p T).

(** Typing relation for terms *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
       (forall x, fresh L 1 (x::nil) ->
       (E & x ~ U) |= t1 ^ (x::nil) ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_fix : forall L E U T t1,
      (forall x f, fresh L 2 (x::f::nil) ->
        (E & f ~ (typ_arrow U T) & x ~ U) |= t1 ^ (x::f::nil) ~: T) ->
      E |= (trm_fix t1) ~: (typ_arrow U T)
  | typing_match : forall T Us L R E t1 p e t2,
      E |= t1 ~: T ->
      Us \= p ~: T ->
      (forall xs, fresh L (pat_arity p) xs ->
        (E & (iter_push xs Us)) |= (e ^ xs) ~: R) ->
      E |= t2 ~: R ->
      E |= (trm_match t1 p e t2) ~: R
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_unit : forall E,
      ok E ->
      E |= (trm_unit) ~: (typ_unit)
  | typing_pair : forall E t1 t2 T1 T2,
      E |= t1 ~: T1 ->
      E |= t2 ~: T2 ->
      E |= (trm_pair t1 t2) ~: (typ_prod T1 T2)
  | typing_inj1 : forall T2 E t1 T1,
      E |= t1 ~: T1 ->
      E |= (trm_inj1 t1) ~: (typ_sum T1 T2)
  | typing_inj2 : forall T1 E t1 T2,
      E |= t1 ~: T2 ->
      E |= (trm_inj2 t1) ~: (typ_sum T1 T2)

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      bodys 1 t1 ->
      value (trm_abs t1)
  | value_fix : forall t1,
      bodys 2 t1 ->
      value (trm_fix t1)
  | value_unit :
      value (trm_unit)
  | value_pair : forall v1 v2,
     value v1 ->
     value v2 ->
     value (trm_pair v1 v2)
  | value_inj1 : forall v1,
     value v1 ->
     value (trm_inj1 v1)
  | value_inj2 : forall v1,
     value v1 ->
     value (trm_inj2 v1).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ (t2::nil))
  | red_fix : forall t1 t2,
      term (trm_fix t1) ->
      value t2 ->
      red (trm_app (trm_fix t1) t2)
          (t1 ^^ (t2::(trm_fix t1)::nil))
  | red_match_some : forall ts t1 p e t2,
      value t1 ->
      bodys (pat_arity p) e ->
      term t2 ->
      pat_match p t1 = Some ts ->
      red (trm_match t1 p e t2) (e ^^ ts)
  | red_match_none : forall t1 p e t2,
      value t1 ->
      bodys (pat_arity p) e ->
      term t2 ->
      pat_match p t1 = None ->
      red (trm_match t1 p e t2) t2
  | red_app_1 : forall t1 t1' t2,
      red t1 t1' ->
      term t2 ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2')
  | red_match_1 : forall t1 t1' p e t2,
      red t1 t1' ->
      bodys (pat_arity p) e ->
      term t2 ->
      red (trm_match t1 p e t2) (trm_match t1' p e t2)
  | red_pair_1 : forall t1 t1' t2,
      red t1 t1' ->
      term t2 ->
      red (trm_pair t1 t2) (trm_pair t1' t2)
  | red_pair_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_pair t1 t2) (trm_pair t1 t2')
  | red_inj1_1 : forall t1 t1',
      red t1 t1' ->
      red (trm_inj1 t1) (trm_inj1 t1')
  | red_inj2_1 : forall t1 t1',
      red t1 t1' ->
      red (trm_inj2 t1) (trm_inj2 t1').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.