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

 In this file, we combine the facts from `precomp_ess_surj.v`
 and `precomp_fully_faithful.v`. We show that if we have a fully
 faithful and essential surjective functor `F : C₁ ⟶ C₂` and a
 univalent category `D`, then we have an adjoint equivalence
 between `[ C₂ , D ]` and `[ C₁ , D ]` (the functor is given
 by precomposition). We also give some functions to use this
 adjoint equivalence.

 ****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.precomp_ess_surj.
Require Import UniMath.CategoryTheory.precomp_fully_faithful.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Local Open Scope cat.

Section PrecompEquivalence.
  Context {C₁ C₂ : category}
          (D : univalent_category)
          (F : C₁ ⟶ C₂)
          (HF₁ : essentially_surjective F)
          (HF₂ : fully_faithful F).

  Definition precomp_adjoint_equivalence
    : adj_equivalence_of_cats (pre_composition_functor C₁ C₂ (pr1 D) F).
  Proof.
    use rad_equivalence_of_cats.
    - apply is_univalent_functor_category.
      exact (pr2 D).
    - exact (pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful
               C₁ C₂ D
               F
               HF₁ HF₂).
    - exact (pre_composition_essentially_surjective
               C₁ C₂ D (pr2 D)
               F
               HF₁ HF₂).
  Defined.

  Let L : [ C₂ , D ] ⟶ [ C₁ , D ]
    := pre_composition_functor C₁ C₂ (pr1 D) F.
  Let R : [ C₁ , D ] ⟶ [ C₂ , D ]
    := right_adjoint precomp_adjoint_equivalence.
  Let ε : nat_z_iso (R ∙ L) (functor_identity _)
    := counit_nat_z_iso_from_adj_equivalence_of_cats
         precomp_adjoint_equivalence.
  Let η : nat_z_iso (functor_identity _) (L ∙ R)
    := unit_nat_z_iso_from_adj_equivalence_of_cats
         precomp_adjoint_equivalence.

  Definition lift_functor_along
             (G : C₁ ⟶ D)
    : C₂ ⟶ D
    := R G.

  Definition lift_functor_along_comm
             (G : C₁ ⟶ D)
    : nat_z_iso (F ∙ lift_functor_along G) G
    := nat_z_iso_from_z_iso _ (nat_z_iso_pointwise_z_iso ε G).

  Definition lift_nat_trans_along
             {G₁ G₂ : C₂ ⟶ D}
             (α : F ∙ G₁ ⟹ F ∙ G₂)
    : G₁ ⟹ G₂.
  Proof.
    exact (invmap
             (make_weq
                _
                (fully_faithful_from_equivalence
                   _ _ _
                   precomp_adjoint_equivalence
                   G₁ G₂))
          α).
  Defined.

  Definition lift_nat_trans_along_comm
             {G₁ G₂ : C₂ ⟶ D}
             (α : F ∙ G₁ ⟹ F ∙ G₂)
    : pre_whisker F (lift_nat_trans_along α) = α.
  Proof.
    exact (homotweqinvweq
             (make_weq
                _
                (fully_faithful_from_equivalence
                   _ _ _
                   precomp_adjoint_equivalence
                   G₁ G₂))
             α).
  Qed.

  Definition lift_nat_trans_eq_along
             {G₁ G₂ : C₂ ⟶ D}
             {β₁ β₂ : G₁ ⟹ G₂}
             (p : pre_whisker F β₁ = pre_whisker F β₂)
    : β₁ = β₂.
  Proof.
    exact (maponpaths
             pr1
             (proofirrelevance
                _
                (pr2 (fully_faithful_implies_full_and_faithful
                        _ _ _
                        (fully_faithful_from_equivalence
                           _ _ _
                           precomp_adjoint_equivalence))
                   G₁ G₂
                   (pre_whisker F β₂))
                (β₁ ,, p)
                (β₂ ,, idpath _))).
  Qed.

  Definition lift_nat_z_iso_along
             {G₁ G₂ : C₂ ⟶ D}
             (α : nat_z_iso (F ∙ G₁) (F ∙ G₂))
    : nat_z_iso G₁ G₂.
  Proof.
    exists (lift_nat_trans_along α).

    use is_functor_z_iso_pointwise_if_z_iso.
    { apply homset_property. }

    set (β := (z_iso_from_nat_z_iso (homset_property _) α)).
    set (ff_precomp := (fully_faithful_from_equivalence
                          [C₂, pr1 D] [C₁, pr1 D]
                          (pre_composition_functor C₁ C₂ (pr1 D) F)
                          precomp_adjoint_equivalence)).

    exact (fully_faithful_reflects_iso_proof
             [C₂, pr1 D] [C₁, pr1 D]
             (pre_composition_functor _ _ D F)
             ff_precomp _ _ β
          ).
  Defined.

End PrecompEquivalence.

Section WeakEquivalenceProperties.

  Lemma iscontr_prod (A B : UU)
    : iscontr A -> iscontr B -> iscontr (A × B).
  Proof.
    intros p q.
    exists (pr1 p ,, pr1 q).
    intro t.
    use total2_paths_f.
    { apply (pr2 p). }
    rewrite transportf_const.
    apply (pr2 q).
  Qed.

  Context {C1 C2 D1 D2 : category}
          (F : functor C1 C2) (G : functor D1 D2).

  Definition pair_functor_ff
             (F_ff : fully_faithful F)
             (G_ff : fully_faithful G)
    : fully_faithful (pair_functor F G).
  Proof.

    intros cd cd' cd2.

    assert (hfiberprod : hfiber # (pair_functor F G) cd2 ≃ (hfiber # F (pr1 cd2) × hfiber # G (pr2 cd2))).
    {
      use weq_iso.
      - intro x.
        use tpair.
        + exists (pr11 x).
          exact (maponpaths pr1 (pr2 x)).
        + exists (pr21 x).
          etrans.
          2: {
            apply maponpaths.
            apply x.
          }
          apply idpath.
      - intro xy.
        exists (catbinprodmor (pr11 xy) (pr12 xy)).
        use total2_paths_f.
        + exact (pr21 xy).
        + etrans. {
            exact (toforallpaths _ _ _ (transportf_const (pr21 xy) ( D2 ⟦ pr2 (pair_functor F G cd), pr2 (pair_functor F G cd') ⟧)) (pr2 (# (pair_functor F G) (catbinprodmor (pr11 xy) (pr12 xy))))).
          }
          exact (pr22 xy).
      - intro.
        use total2_paths_f.
        + apply idpath.
        + apply homset_property.
      - intro.
        use total2_paths_f.
        + use total2_paths_f.
          * apply idpath.
          * apply homset_property.
        + use total2_paths_f.
          * cbn.
            etrans. {
              apply maponpaths.
              rewrite transportf_const.
              apply idpath.
            }
            apply idpath.
          * apply homset_property.
    }

    use iscontrweqb'.
    3: { apply hfiberprod. }
    apply iscontr_prod.
    - apply (F_ff (pr1 cd) (pr1 cd') (pr1 cd2)).
    - apply (G_ff (pr2 cd) (pr2 cd') (pr2 cd2)).
  Qed.

  Definition pair_functor_eso
             (F_eso : essentially_surjective F)
             (G_eso : essentially_surjective G)
    : essentially_surjective (pair_functor F G).
  Proof.
    intro cd2.
    use (factor_through_squash _ _ (F_eso (pr1 cd2))).
    { apply ishinh. }
    intro d1.
    use (factor_through_squash _ _ (G_eso (pr2 cd2))).
    { apply ishinh. }
    intro d2.
    apply hinhpr.
    exists (pr1 d1 ,, pr1 d2).
    use precatbinprod_z_iso.
    - exact (pr2 d1).
    - exact (pr2 d2).
  Qed.

End WeakEquivalenceProperties.

Section LiftedFunctorsIdentity.

  Definition lift_functor_along_id
             {C : category}
             (D : univalent_category)
             {F : functor C D}
             (F_eso : essentially_surjective F)
             (F_ff : fully_faithful F)
    :   nat_z_iso
          (lift_functor_along D F F_eso F_ff (functor_identity C ∙ F))
          (functor_identity D).
  Proof.
    use (lift_nat_z_iso_along D F F_eso F_ff).
    use nat_z_iso_comp.
    2: apply lift_functor_along_comm.
    use make_nat_z_iso.
    - use make_nat_trans.
      { exact (λ _, identity _). }
      abstract (intro ; intros ; exact (id_right _ @ ! id_left _)).
    - intro.
      exists (identity _).
      abstract (split ; apply id_right).
  Defined.

End LiftedFunctorsIdentity.

Section LiftedFunctorsComposition.

  Context {C1 C2 C3 D1 : category}
          (D2 D3 : univalent_category)
          {F1 : functor C1 D1}
          {F2 : functor C2 D2}
          (F3 : functor C3 D3)
          (F1_eso : essentially_surjective F1)
          (F1_ff : fully_faithful F1)
          (F2_eso : essentially_surjective F2)
          (F2_ff : fully_faithful F2).

  Definition lift_functor_along_comp
             (G1 : functor C1 C2) (G2 : functor C2 C3)
    : nat_z_iso
        (lift_functor_along D3 F1 F1_eso F1_ff ((G1 ∙ G2) ∙ F3))
        (lift_functor_along D2 F1 F1_eso F1_ff (G1 ∙ F2)
                           ∙ lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3)).
  Proof.
    use (lift_nat_z_iso_along D3 F1 F1_eso F1_ff).

    set (l := lift_functor_along_comm D3 F2 F2_eso F2_ff (G2 ∙ F3)).
    set (l2_i := pre_whisker_on_nat_z_iso G1 (pr1 l) (pr2 l)).
    set (u := lift_functor_along_comm D2 F1 F1_eso F1_ff (G1 ∙ F2)).
    set (u2_i := post_whisker_z_iso_is_z_iso
                   (pr1 u)
                   (lift_functor_along D3 F2 F2_eso F2_ff ((G2 ∙ F3)))
                   (pr2 u)
        ).

    transparent assert ( l2 : (nat_z_iso
                                (functor_composite G1 (F2 ∙ lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3)))
                                (functor_composite G1 (G2 ∙ F3)))).
    {
      use make_nat_z_iso.
      2: exact l2_i.
    }

    transparent assert (u2 : (nat_z_iso
                                (functor_composite
                                    (F1 ∙ lift_functor_along D2 F1 F1_eso F1_ff (G1 ∙ F2))
                                    (lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3)))
                                (functor_composite (G1 ∙ F2) (lift_functor_along D3 F2 F2_eso F2_ff (G2 ∙ F3))))).
    {
      use make_nat_z_iso.
      2: exact u2_i.
    }

    use nat_z_iso_comp.
    2: { apply lift_functor_along_comm. }
    use nat_z_iso_comp.
    2: { exact (nat_z_iso_inv l2). }
    exact (nat_z_iso_inv u2).
  Defined.

End LiftedFunctorsComposition.

Section LiftedFunctorsPairFunctor.

  Lemma nat_z_iso_pair {C1 C2 D1 D2 E1 E2 : category}
        (F1 : functor C1 D1) (F2 : functor D1 E1)
        (G1 : functor C2 D2) (G2 : functor D2 E2)
    : nat_z_iso (pair_functor (F1 ∙ F2) (G1 ∙ G2))
                (pair_functor F1 G1 ∙ pair_functor F2 G2).
  Proof.
    use make_nat_z_iso.
    - use make_nat_trans.
      + intro ; apply catbinprodmor ; apply identity.
      + abstract (intro ; intros ; use total2_paths_f ;
          [ exact (id_right _ @ ! id_left _) | rewrite transportf_const ; exact (id_right _ @ ! id_left _) ]).
    - intro.
      use make_is_z_isomorphism.
      + apply catbinprodmor ; apply identity.
      + abstract (split ; (use total2_paths_f ; [ apply id_right | rewrite transportf_const ; apply id_right ])).
  Defined.

  Lemma nat_z_iso_between_pair {C1 C2 D1 D2 : category}
        {F1 F1' : functor C1 D1}
        {G1 G1' : functor C2 D2}
        (α : nat_z_iso F1 F1') (β : nat_z_iso G1 G1')
    : nat_z_iso (pair_functor F1 G1)
                (pair_functor F1' G1').
  Proof.
    use make_nat_z_iso.
    - use make_nat_trans.
      + intro ; apply catbinprodmor ; [apply α | apply β].
      + abstract (intro ; intros ; use total2_paths_f ; [apply (pr1 α) | rewrite transportf_const ; apply (pr1 β)]).
    - intro.
      use tpair.
      + apply catbinprodmor ; [apply (pr2 α) | apply (pr2 β)].
      + abstract (split ; (use total2_paths_f ; [apply (pr2 α) | rewrite transportf_const ; apply (pr2 β)])).
  Defined.

  Context {C1 C2 C1' C2' D1 D2 : category}
          (D1' D2' : univalent_category)
          {F1 : functor C1 D1}
          {F2 : functor C2 D2}
          (F1' : functor C1' D1')
          (F2' : functor C2' D2')
          (F1_eso : essentially_surjective F1)
          (F2_eso : essentially_surjective F2)
          (F1_ff : fully_faithful F1)
          (F2_ff : fully_faithful F2).

  Let FF := pair_functor F1 F2.
  Let FF' := pair_functor F1' F2'.

  Let FF_eso := pair_functor_eso _ _ F1_eso F2_eso.
  Let FF_ff := pair_functor_ff _ _ F1_ff F2_ff.

  Let DD' := (_ ,, is_univalent_category_binproduct (pr2 D1') (pr2 D2')) : univalent_category.

  Definition lift_functor_along_pair
             (H1 : functor C1 C1') (H2 : functor C2 C2')
    : nat_z_iso (lift_functor_along DD' FF FF_eso FF_ff (pair_functor H1 H2 ∙ pair_functor F1' F2'))
                (pair_functor (lift_functor_along D1' F1 F1_eso F1_ff (H1 ∙ F1'))
                              (lift_functor_along D2' F2 F2_eso F2_ff (H2 ∙ F2'))).
  Proof.
    use (lift_nat_z_iso_along DD' FF FF_eso FF_ff).
    set (l := lift_functor_along_comm DD' FF FF_eso FF_ff  (pair_functor H1 H2 ∙ pair_functor F1' F2')).
    use nat_z_iso_comp.
    2: { exact l. }
    use nat_z_iso_comp.
    3: { apply nat_z_iso_pair. }
    use nat_z_iso_comp.
    2: { apply (nat_z_iso_inv (nat_z_iso_pair _ _ _ _)). }
    use nat_z_iso_between_pair ; apply (nat_z_iso_inv (lift_functor_along_comm _ _ _ _ _)).
  Defined.

End LiftedFunctorsPairFunctor.

Section LiftedFunctorsProperties.

  Lemma post_whisker_nat_z_iso {C D E : category}
        {F1 F2 : functor C D} (α : nat_z_iso F1 F2) (G : functor D E)
    : nat_z_iso (F1 ∙ G) (F2 ∙ G).
  Proof.
    use make_nat_z_iso.
    2: { exact (post_whisker_z_iso_is_z_iso α G (pr2 α)). }
  Defined.

  Context {C : category} (D : univalent_category)
            (F1 : functor C D)
            (F1_eso : essentially_surjective F1)
            (F1_ff : fully_faithful F1).

  Let FF := pair_functor F1 F1.
  Let FF_ff := pair_functor_ff _ _ F1_ff F1_ff.
  Let FF_eso := pair_functor_eso _ _ F1_eso F1_eso.

  Let FFF := pair_functor FF F1.
  Let FFF_ff := pair_functor_ff _ _ FF_ff F1_ff.
  Let FFF_eso := pair_functor_eso _ _ FF_eso F1_eso.

  Let FFF' := pair_functor F1 FF.
  Let FFF'_ff := pair_functor_ff _ _ F1_ff FF_ff.
  Let FFF'_eso := pair_functor_eso _ _ F1_eso FF_eso.

  Let DD := (_ ,, is_univalent_category_binproduct (pr2 D) (pr2 D)) : univalent_category.
  Let DDD := (_ ,, is_univalent_category_binproduct (pr2 DD) (pr2 D)) : univalent_category.
  Let DDD' := (_ ,, is_univalent_category_binproduct (pr2 D) (pr2 DD)) : univalent_category.

  Lemma lift_functor_along_comm_prod
        (H : functor (category_binproduct C C) C)
    : nat_z_iso
        (lift_functor_along D FFF FFF_eso FFF_ff
                            ((pair_functor H (functor_identity C) ∙ H) ∙ F1))
        (pair_functor (lift_functor_along
                         D
                         FF
                         FF_eso
                         FF_ff
                         (functor_composite H F1)
                      )
                      (functor_identity D)
                      ∙ (lift_functor_along
                           D
                           FF
                           FF_eso
                           FF_ff
                           (functor_composite H F1))
        )
  .
  Proof.

    use nat_z_iso_comp.
    2: {
      exact (lift_functor_along_comp DD D F1 FFF_eso FFF_ff FF_eso FF_ff
                                     (pair_functor H (functor_identity C)) H).
    }

    apply post_whisker_nat_z_iso.
    use nat_z_iso_comp.
    2 : { apply lift_functor_along_pair. }
    use nat_z_iso_between_pair.
    - use make_nat_z_iso.
      2: apply is_nat_z_iso_nat_trans_id.
    - apply lift_functor_along_id.
  Defined.

  Lemma lift_functor_along_comm_prod'
        (H : functor (category_binproduct C C) C)
    : nat_z_iso
        (lift_functor_along D FFF' FFF'_eso FFF'_ff
                            ((pair_functor (functor_identity C) H ∙ H) ∙ F1))
        (pair_functor
           (functor_identity D)
           (lift_functor_along
                         D
                         FF
                         FF_eso
                         FF_ff
                         (functor_composite H F1)
                      )

                      ∙ (lift_functor_along
                           D
                           FF
                           FF_eso
                           FF_ff
                           (functor_composite H F1))
        )
  .
  Proof.

    use nat_z_iso_comp.
    2: {
      exact (lift_functor_along_comp DD D F1 FFF'_eso FFF'_ff FF_eso FF_ff
                                     (pair_functor (functor_identity C) H) H).
    }

    apply post_whisker_nat_z_iso.
    use nat_z_iso_comp.
    2 : { apply lift_functor_along_pair. }
    use nat_z_iso_between_pair.
    - apply lift_functor_along_id.
    - use make_nat_z_iso.
      2: apply is_nat_z_iso_nat_trans_id.
  Defined.

End LiftedFunctorsProperties.


Require Import HoTT.
From GR.bicategories Require Export
     general_category
     bicategory.bicategory
     bicategory.adjoint.

Definition transport_one_cell_FlFr
           `{Funext}
           {C : BiCategory}
           {A : Type}
           (f g : A -> C)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (h : C⟦f a₁,g a₁⟧)
  : (transport (fun (z : A) => C⟦f z,g z⟧) p h)
      ==>
      id_to_adjequiv _ _ (ap g p) · h · id_to_adjequiv _ _ (ap f p^)
  := match p with
     | idpath => right_unit_inv _ ∘ left_unit_inv _
     end.

Definition transport_one_cell_FlFr_inv
           `{Funext}
           {C : BiCategory}
           {A : Type}
           (f g : A -> C)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (h : C⟦f a₁,g a₁⟧)
  : (id_to_adjequiv _ _ (ap g p) · h · id_to_adjequiv _ _ (ap f p^))
      ==>
      transport (fun (z : A) => C⟦f z,g z⟧) p h
  := match p with
     | idpath => left_unit _ ∘ right_unit _
     end.

Global Instance is_iso_transport_one_cell_FlFr
       `{Funext}
       {C : BiCategory}
       {A : Type}
       (f g : A -> C)
       {a₁ a₂ : A}
       (p : a₁ = a₂)
       (h : C⟦f a₁,g a₁⟧)
  : IsIsomorphism (transport_one_cell_FlFr f g p h).
Proof.
  simple refine (Build_IsIsomorphism_2cell _ _ _).
  - apply transport_one_cell_FlFr_inv.
  - induction p ; simpl.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite right_unit_left, vcomp_left_identity.
    apply left_unit_left.
  - induction p ; simpl.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite left_unit_right, vcomp_left_identity.
    apply right_unit_right.
Defined.

Definition transport_vcomp₁_l
           `{Funext}
           {C : BiCategory}
           {X Y Z : C}
           (g : C⟦Y,Z⟧)
           {f₁ f₂ : C⟦X,Y⟧}
           (q : f₁ = f₂)
  : g ◅ idtoiso (C⟦X,Y⟧) q = idtoiso _ (ap (hcomp1 g) q).
Proof.
  induction q ; cbn.
  apply hcomp_id₂.
Defined.

Definition transport_vcomp₁_r
           `{Funext}
           {C : BiCategory}
           {X Y Z : C}
           (g : C⟦X,Y⟧)
           {f₁ f₂ : C⟦Y,Z⟧}
           (q : f₁ = f₂)
  : idtoiso (C⟦Y,Z⟧) q ▻ g = idtoiso _ (ap (fun (f : C⟦Y,Z⟧) => f · g) q).
Proof.
  induction q ; cbn.
  apply hcomp_id₂.
Defined.

Definition transport_two_cell_FlFr
           `{Funext}
           {C : BiCategory}
           {A : Type}
           {X Y : C}
           (F G : A -> C⟦X,Y⟧)
           {a₁ a₂ : A}
           (p : a₁ = a₂)
           (α : F a₁ ==> G a₁)
  : transport (fun (z : A) => F z ==> G z) p α
    =
    idtoiso (C⟦X,Y⟧) (ap G p) ∘ α ∘ (idtoiso (C⟦X,Y⟧) (ap F p))^-1.
Proof.
  induction p ; cbn.
  rewrite vcomp_left_identity, vcomp_right_identity.
  reflexivity.
Qed.


Require Import Lia.
Require Import Bool.
Require Import List.
Import PeanoNat.Nat.
Import ListNotations.
Require Extraction.
Require Import Program.Wf.
Require Import Arith.Wf_nat.

Inductive bit := B1 | B0.

Definition broken_list := list bool.
Definition message := list bit.
Definition packet : Set := bit * bit * bit.
Definition chunk : Set := bool * bool * bool.

Fixpoint bools_to_chunks (p : broken_list) : list chunk :=  match p with
  | a :: b :: c :: rest => (a,b,c) :: bools_to_chunks rest
  | _ => []
  end.

Definition sum_chunk '((a,b,c) : chunk) := b2n a + b2n b + b2n c.

Fixpoint packets_to_message (ps : list packet) := match ps with
  | [] => []
  | (a,b,c) :: rest => a :: b :: c :: packets_to_message rest
  end.

Fixpoint message_to_packets (x : message) := match x with
  | a :: b :: c :: rest => (a,b,c) :: message_to_packets rest
  | _ => []
  end.

(** Converting a list of packets to a message and back to packets is the identity. *)
Lemma packets_message_inverses : forall ps,
  message_to_packets (packets_to_message ps) = ps.
Proof.
  intros.
  induction ps as [| p ps IH].
  - reflexivity.
  - destruct p as [[a b] c]. simpl. rewrite IH. reflexivity.
Qed.

Definition encode_packet '((a,b,c) : chunk) (x : message) : packet :=
    let '(b1, b2) := (match x with
      | []                => (B0 , B0)
      | [b1']             => (b1', B0)
      | b1' :: b2' :: bs' => (b1', b2')
    end) in
    match sum_chunk (a,b,c) with
    | 0 => (match b1, b2 with
        | B0, B0 => (B0, B1, B1)
        | B0, B1 => (B1, B1, B1)
        | B1, B0 => (B1, B0, B0)
        | B1, B1 => (B1, B0, B1)
        end)
    | 1 => if a then (match b1 with
        | B0 => (B0, B0, B1)
        | B1 => (B0, B1, B0)
        end)
        else if c then (match b1 with
        | B0 => (B1, B1, B0)
        | B1 => (B0, B1, B0)
        end)
        else (match b1, b2 with
        | B0, _  => (B0, B0, B1)
        | B1, B0 => (B1, B0, B0)
        | B1, B1 => (B1, B0, B1)
        end)
    | _ => (B0, B0, B0)
    end.

Definition decode_packet (p : packet) : message := match p with
    | (B0, B0, B0) => []
    | (B0, B0, B1) => [B0]
    | (B0, B1, B0) => [B1]
    | (B0, B1, B1) => [B0; B0]
    | (B1, B0, B0) => [B1; B0]
    | (B1, B0, B1) => [B1; B1]
    | (B1, B1, B0) => [B0]
    | (B1, B1, B1) => [B0; B1]
    end.

Fixpoint drop {A} (n : nat) (l : list A) : list A := match n, l with
  | 0  , l       => l
  | n  , []      => l
  | S n, x :: ls => drop n ls
  end.

Fixpoint encode (x : message) (p : list chunk) : list packet := match p with
  | c :: rest => let pack := encode_packet c x in
    pack :: encode (drop (length (decode_packet pack)) x) rest
  | _ => []
  end.

Fixpoint decode (x : list packet) : message := match x with
  | p :: rest => decode_packet p ++ decode rest
  | _ => []
  end.

Definition anna (x : message) (p : broken_list) : message :=
  packets_to_message (encode x (bools_to_chunks p)).

Definition bruno (x : message) : message :=
  decode (message_to_packets x).


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.setoid_ring.Ring.
Require Import Cava.Cava.
Require Import Cava.CavaProperties.
Require Import AesSpec.AES256.
Require Import AesSpec.Polynomial.
Require Import AesSpec.StateTypeConversions.
Require Import AesImpl.Pkg.
Require Import AesImpl.MixColumnsCircuit.
Import StateTypeConversions.LittleEndian.

Existing Instance MixColumns.byteops.

Section Equivalence.
  Local Notation byte := (Vector.t bool 8).
  Local Notation state := (Vector.t (Vector.t byte 4) 4) (only parsing).
  Local Notation key := (Vector.t (Vector.t byte 4) 4) (only parsing).

  Lemma aes_transpose_correct n m (v : combType (Vec (Vec (Vec Bit 8) n) m)) :
    aes_transpose v = transpose v.
  Proof. cbv [aes_transpose]; simpl_ident; reflexivity. Qed.

  Lemma poly_to_byte_to_bitvec p :
    length p = 8 -> byte_to_bitvec (MixColumns.poly_to_byte p) = of_list_sized false 8 p.
  Proof.
    intros; destruct_lists_by_length.
    repeat match goal with b : bool |- _ => destruct b end; reflexivity.
  Qed.

  Lemma bitvec_to_byte_to_poly bv :
    MixColumns.byte_to_poly (bitvec_to_byte bv) = Vector.to_list bv.
  Proof.
    constant_bitvec_cases bv; reflexivity.
  Qed.

  Lemma xorV_is_add (b1 b2 : byte) :
    Vec.xor (n:=8) (b1, b2)
    = byte_to_bitvec (Polynomial.fadd (bitvec_to_byte b1)
                                      (bitvec_to_byte b2)).
  Proof.
    simpl_ident. fequal_list.
    cbv [Polynomial.fadd MixColumns.byteops].
    rewrite poly_to_byte_to_bitvec, !bitvec_to_byte_to_poly by length_hammer.
    cbv [Polynomial.add_poly].
    apply to_list_inj. autorewrite with push_to_list; push_extend.
    rewrite to_list_of_list_sized by length_hammer.
    reflexivity.
  Qed.

  Lemma aes_mul2_correct (b : byte) :
    aes_mul2 b
    = byte_to_bitvec (Polynomial.fmul Byte.x02
                                      (bitvec_to_byte b)).
  Proof.
    constant_bitvec_cases b; vm_compute; reflexivity.
  Qed.

  Lemma aes_mul4_correct (b : byte) :
    aes_mul4 b
    = byte_to_bitvec (Polynomial.fmul Byte.x04
                                      (bitvec_to_byte b)).
  Proof.
    constant_bitvec_cases b; vm_compute; reflexivity.
  Qed.

  Hint Rewrite xorV_is_add using solve [eauto] : simpl_ident.
  Hint Rewrite aes_mul2_correct using solve [eauto] : simpl_ident.
  Hint Rewrite aes_mul4_correct using solve [eauto] : simpl_ident.

  Local Open Scope poly_scope.

  Lemma zero_byte_correct : bitvec_to_byte zero_byte = fzero.
  Proof. reflexivity. Qed.
  Hint Rewrite zero_byte_correct using solve [eauto] : simpl_ident.

  Ltac prering :=
    change Byte.x03 with (Byte.x02 + Byte.x01);
    change Byte.x04 with (Byte.x02 * Byte.x02);
    change Byte.x05 with (Byte.x02 * Byte.x02 + Byte.x01);
    change Byte.x06 with (Byte.x02 * (Byte.x02 + Byte.x01));
    change Byte.x07 with (Byte.x02 * (Byte.x02 + Byte.x01) + Byte.x01);
    change Byte.x08 with (Byte.x02 * (Byte.x02 * Byte.x02));
    change Byte.x09 with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x01);
    change Byte.x0a with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02);
    change Byte.x0b with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02 + Byte.x01);
    change Byte.x0c with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02 * Byte.x02);
    change Byte.x0d with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02 * Byte.x02 + Byte.x01);
    change Byte.x0e with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02 * (Byte.x02 + Byte.x01));
    change Byte.x0e with (Byte.x02 * (Byte.x02 * Byte.x02) + Byte.x02 * (Byte.x02 + Byte.x01) + Byte.x01);
    change Byte.x01 with fone.

  Add Ring bytering : MixColumns.ByteTheory (preprocess [prering]).

  Lemma mix_single_column_equiv (is_decrypt : bool) (col : Vector.t byte 4) :
    aes_mix_single_column is_decrypt col
    = if is_decrypt
      then Vector.map
             byte_to_bitvec
             (MixColumns.inv_mix_single_column (Vector.map bitvec_to_byte col))
      else Vector.map
             byte_to_bitvec
             (MixColumns.mix_single_column (Vector.map bitvec_to_byte col)).
  Proof.
    constant_vector_simpl col.
    unfold MixColumns.inv_mix_single_column, MixColumns.mix_single_column.
    cbn [Vector.map].
    autorewrite with push_vector_map vsimpl.
    autorewrite with push_vector_fold vsimpl.

    unfold aes_mix_single_column.
    (* reduce size of term by simplifying indexConst for constant vectors immediately *)
    repeat lazymatch goal with
           | |- context [(@indexConst _ ?cava ?t ?sz (Vector.cons ?A ?x ?n ?v) ?i)] =>
             let y := constr:(@indexConst _ cava t sz (Vector.cons A x n v) i) in
             let z := (eval cbn in y) in
             change y with z
           end.
    simpl_ident.
    cbn [localSignal CombinationalSemantics].
    simpl_ident.
    destruct is_decrypt.
    all: cbn [nth_default map]; simpl_ident.
    all: repeat rewrite byte_to_bitvec_to_byte.
    all: fequal_vector; f_equal.
    all: ring.
  Qed.

  Lemma mix_columns_equiv (is_decrypt : bool) (st : state) :
    aes_mix_columns is_decrypt st
    = AES256.aes_mix_columns_circuit_spec is_decrypt st.
  Proof.
    cbv [aes_mix_columns mcompose]. simpl_ident.
    rewrite ! aes_transpose_correct by lia.
    erewrite Vector.map_ext by apply mix_single_column_equiv.
    cbv [AES256.aes_mix_columns_circuit_spec
           AES256.mix_columns AES256.inv_mix_columns
           MixColumns.mix_columns MixColumns.inv_mix_columns].
    cbv [from_flat to_flat BigEndian.to_rows BigEndian.from_rows].
    autorewrite with conversions.
    (* consolidate all the repeated maps *)
    rewrite !transpose_map_map, !Vector.map_map.
    rewrite <-!transpose_map_map, !Vector.map_map.
    destruct is_decrypt;
      repeat lazymatch goal with
             | |- [_] = [_] => apply f_equal
             | |- transpose _ = transpose _ => apply f_equal
             | |- map _ ?v = map _ ?v => apply map_ext; intros
             | _ => reflexivity
             end.
  Qed.
End Equivalence.


Require Import Statement ThreadedPredicative Wfd.

Require Import Lia.

Open Scope stmt_scope.

Definition spec := ⟨fun '(i,n) '(i',n') => i <= n /\ i' = n /\ n = n'⟩.

Definition prog := WWhile (fun '(i,n) => i <> n) Do '(i,n) := (i+1,n) Done.

(* Proof of correctness by induction on n *)
Theorem correctness : prog ⊑ spec.
Proof.
  intros (i,n) ((u,v),(HHin,_)); clear u v.
  split.
  { intros (i',n') HHwhile.
    generalize HHin; clear HHin; simpl.
    cut ((fun '(i,n) '(i',n') =>  i <= n -> i <= n /\ i' = n /\ n = n') (i,n) (i',n')); auto.
    apply HHwhile; clear.
    intros (i,n) (i',n'); simpl.
    intros [ (HHin,HHind) | (HHin,HHeq) ] HHin'.
    { lia. }
    { inversion HHeq; subst i n; clear HHeq. lia. }
  }
  { generalize i HHin; clear i HHin; induction n; simpl in *.
    { exists (0,0); apply while_construct; right; split.
      { lia. }
      { f_equal; lia. }
    }
    { intros i HHiSn.
      apply Lt.le_lt_or_eq in HHiSn.
      destruct HHiSn as [ HHiSn | HHiSn ].
      { assert (i <= n) as HHin by lia.
        destruct (IHn _ HHin) as ((i',n'),HHwhile).
        set (Whl := while _ _) in *.
        exists (S i',S n').
        cut ((fun '(i,n) '(i',n') => i <= n -> Whl (i, S n) (S i', S n')) (i,n) (i',n')).
        { intros; auto. }
        apply (while_ind _ _ _ _ _ HHwhile).
        intros (j,m) (j',m'); simpl.
        intros.
        apply while_construct; fold Whl; simpl.
        destruct H.
        { destruct H.
          left; split; try lia.
          apply H1; lia.
        }
        { destruct H.
          inversion H1; subst j' m'.
          left; split; try lia.
          apply while_construct; right; split; try lia.
          f_equal; lia.
        }
      }
      { exists (S n,S n); apply while_construct; right; split; try lia.
        subst i; f_equal; lia.
      }
    }
  }
Qed.

(* Proof of correctness where well-founded-ness is proved by showing inclusion in a well founded relation*)

Theorem correctness2 : prog ⊑ spec.
Proof.
  set (new_body := (IIf (fun '(i,n) => i <= n) Then '(i,n) := (i+1,n) Else Statement.Void End)).
  eapply (refines_trans _ _ _ _ (While_monotonic_refines _ _ _ new_body _)).
  apply (refines_extensionality_left _ _ spec).
  { apply (wfd_fix_while _ _ (pred spec)).
    { clear.
      apply (Wfd.by_inclusion _ _ (fun '(i',n') '(i,n) => i < i' <= n /\ n' = n)).
      { intros (i,n).
        constructor; intros (i',n').
        remember (n-i) as v.
        generalize i i' n n' Heqv; clear i i' n n' Heqv.
        pattern v; apply (well_founded_ind Wf_nat.lt_wf).
        clear v; intros v HHind i i' n n' HHv HHin.
        assert (n-i' < v) by lia.
        pose proof (HHind (n-i') H).
        constructor; intros (i'',n'') HHi''n''.
        apply (H0 i' _ n); lia.
      }
      { intros (i,n) (i',n'); subst new_body; simpl.
        intros (HHin,[(HHi'n',HHeq) | (_,HHfalse)]).
        { inversion HHeq; clear HHeq; subst i n; lia. }
        { contradiction. }
      }
    }
    { intros (i,n) (i',n'); simpl; split.
      { intros (HHin,(HHi'n,HHnn')); subst i' n'.
        apply Lt.le_lt_or_eq in HHin.
        destruct HHin; try lia.
        subst i; right; auto.
      }
      { intros [HH | (HHin,HHeq)].
        { firstorder. }
        { inversion HHeq; clear HHeq; subst i n. lia. }
      }
    }
  }
  { apply refines_reflexive. }
  Unshelve.
  firstorder.
Qed.

(* Proof of correctness with the aid of a variant *)

Theorem correctness3 : prog ⊑ spec.
Proof.
  set (new_body := (IIf (fun '(i,n) => i <= n) Then '(i,n) := (i+1,n) Else Statement.Void End)).
  eapply (refines_trans _ _ _ _ (While_monotonic_refines _ _ _ new_body _)).
  apply (refines_extensionality_left _ _ spec).
  { apply (wfd_fix_while _ _ (pred spec)).
    { clear.
      apply (Wfd.by_inclusion _ _ (fun '(i',n') '(i,n) => i < i' <= n /\ n' = n)).
      { apply (Wfd.by_variant _ _ _ (fun '(i,n) => n - i) _ Wf_nat.lt_wf).
        intros (i',n') (i,n); simpl. lia.
      }
      { intros (i,n) (i',n'); subst new_body; simpl.
        intros (HHin,[(HHi'n',HHeq) | (_,HHfalse)]).
        { inversion HHeq; clear HHeq; subst i n; lia. }
        { contradiction. }
      }
    }
    { intros (i,n) (i',n'); simpl; split.
      { intros (HHin,(HHi'n,HHnn')); subst i' n'.
        apply Lt.le_lt_or_eq in HHin.
        destruct HHin; try lia.
        subst i; right; auto.
      }
      { intros [HH | (HHin,HHeq)].
        { firstorder. }
        { inversion HHeq; clear HHeq; subst i n. lia. }
      }
    }
  }
  { apply refines_reflexive. }
  Unshelve.
  firstorder.
Qed.

Close Scope stmt_scope.


Require Export CatSem.CAT.functor.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section full_faithful.

Variables obC obD : Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variables (C : Cat_struct morC) (D : Cat_struct morD).

Class Faithful (F : Functor C D) := {
  faithful : forall c d (f f' : morC c d),
              #F f == #F f' -> f == f'
}.

Class Full (F : Functor C D) := {
  preimg : forall c d (f : morD (F c) (F d)), morC c d;
  preimg_cond : forall c d (f : morD (F c) (F d)),
                   #F (preimg f) == f
}.

End full_faithful.

Section comp_of_functors.

Variables obC obD obE : Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable morE : obE -> obE -> Type.
Variables (C : Cat_struct morC) (D : Cat_struct morD) (E : Cat_struct morE).
Variables (F : Functor C D) (G : Functor D E).

Instance comp_faithful (HF : Faithful F) (HG : Faithful G) :
           Faithful (CompF F G).
Proof.
  intros;
  constructor;
  intros;
  apply (faithful (Faithful:=HF));
  apply (faithful (Faithful:=HG));
  auto.
Qed.

Program Instance comp_full (HF : Full F) (HG : Full G) :
          Full (CompF F G) := {
  preimg c d f := preimg (preimg (Full := HG) f)
}.
Next Obligation.
Proof.
  intros; simpl;
  repeat rewrite preimg_cond;
  cat.
Qed.

End comp_of_functors.

Existing Instance comp_full.


Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import PeanoNat tools algebra Bool relations pomsets.
Require Import finite_expr finexp_pomsets.
Require Import bsp_terms bsp_pomsets.

Section s.
  Context {X : Set}.
  (** * Finite languages *)
  Definition ℒ := (list (bsp_terms X)).

  Global Instance eqℒ : SemEquiv ℒ := (@eqLang _ equiv).
  Global Instance infℒ : SemSmaller ℒ := (@infLang _ equiv).

  Global Instance Box_list : Box ℒ := map box.

  Global Instance ℒ_BiSemiRing : BiSemiRing ℒ sequiv prod par join un zero
    := ListBiSemiRing_bisemiring.
  Global Instance ℒ_Idem : @Idempotent ℒ sequiv join
    := ListBiSemiRing_idempotent.

  Global Instance ℒ_box_proper_inf : Proper (ssmaller ==> ssmaller) box.
  Proof.
    unfold box,Box_list;intros l m I x Ix;apply in_map_iff in Ix as (y&<-&Iy).
    apply I in Iy as (z&Iz&Ez).
    setoid_rewrite <- Ez.
    exists (▢ z);split;[apply in_map_iff;exists z;tauto|reflexivity].
  Qed.
  Global Instance ℒ_box_proper_eq : Proper (sequiv ==> sequiv) box.
  Proof. intros l m (E1&E2);split;apply ℒ_box_proper_inf;assumption. Qed.

  Fixpoint termLang s : list (bsp_terms X) :=
    match s with
    | bbsr_par s1 s2 => termLang s1 ∥ termLang s2
    | bbsr_seq s1 s2 => termLang s1 ⋅ termLang s2
    | bbsr_plus s1 s2 => termLang s1 ∪ termLang s2
    | bbsr_box s => ▢ (termLang s)
    | bbsr_unit => 𝟭
    | bbsr_zero => 𝟬
    | bbsr_var x => [bsp_var x]
    end.

  Lemma termLang_proper_Ax (Ax : relation bbsr_terms) :
    (Proper (Ax ==> sequiv) termLang) -> (Proper ((bbsr_eq Ax) ==> sequiv) termLang).
  Proof.
    intros hAx e f E;induction E.
    - reflexivity.
    - symmetry;assumption.
    - etransitivity;eassumption.
    - unfold interpret;simpl;rewrite IHE1,IHE2;reflexivity.
    - unfold interpret;simpl;rewrite IHE1,IHE2;reflexivity.
    - unfold interpret;simpl;rewrite IHE1,IHE2;reflexivity.
    - unfold interpret;simpl;rewrite IHE;reflexivity.
    - apply hAx,H.
  Qed.

  Lemma termLang_proper_bisemiring : Proper (bisemiring ==> sequiv) termLang.
  Proof.
    intros e f [];simpl.
    - apply mon_assoc.
    - apply mon_assoc.
    - apply mon_assoc.
    - apply bimon_comm.
    - apply bisemiring_comm.
    - apply ℒ_Idem.
    - apply left_unit.
    - apply right_unit.
    - apply left_unit.
    - apply left_unit.
    - apply left_absorbing.
    - apply right_absorbing.
    - apply left_absorbing.
    - apply bisemiring_left_distr.
    - apply bisemiring_right_distr.
    - apply bisemiring_par_distr.
  Qed.

  Lemma termLang_proper_box_alg : Proper (box_alg ==> sequiv) termLang.
  Proof.
    intros e f [];simpl.
    - unfold box,Box_list;rewrite map_map.
      split;intros x Ix.
      + apply in_map_iff in Ix as (y&<-&Iy).
        exists (▢ y);split;auto.
        apply in_map_iff;exists y;tauto.
      + apply in_map_iff in Ix as (y&<-&Iy).
        exists (▢(▢y));split;auto.
        apply in_map_iff;exists y;split;auto.
    - unfold box,Box_list.
      split;intros x Ix.
      + apply in_map_iff in Ix as (y&<-&[<-|F]);[|exfalso;apply F].
        exists 𝟭;split;simpl;auto.
      + destruct Ix as [<-|F];[|exfalso;apply F].
        exists (▢ 𝟭);split;auto.
        apply in_map_iff ;exists 𝟭;split;simpl;auto.
    - unfold box,Box_list;simpl;reflexivity.
    - unfold box,Box_list,join,join_list.
      rewrite map_app;reflexivity.
  Qed.

  Fixpoint from_term (t : bsp_terms X) :=
    match t with
    | bsp_var x => bbsr_var x
    | bsp_unit => 𝟭
    | bsp_seq s1 s2 => from_term s1 ⋅ from_term s2
    | bsp_par s1 s2 => from_term s1 ∥ from_term s2
    | bsp_box s => ▢ (from_term s)
    end.

  Lemma from_term_termLang t : termLang (from_term t) ≃ [t].
  Proof.
    induction t;simpl.
    - rewrite IHt1,IHt2;clear;split; intros x.
      + intros I;unfold prod,prod_list in I;apply lift_prod_spec in I as (a&b&Ia&Ib&->).
        destruct Ia as [<-|Fa],Ib as [<-|Fb];try (exfalso;apply Fa||apply Fb).
        exists (t1⋅t2);split;[left|];reflexivity.
      + intros [<-|F];[|exfalso;apply F].
        exists (t1⋅t2);split;[|reflexivity].
        apply lift_prod_spec;exists t1,t2;repeat split;left;reflexivity.
    - rewrite IHt1,IHt2;clear;split; intros x.
      + intros I;unfold par,par_list in I;apply lift_prod_spec in I as (a&b&Ia&Ib&->).
        destruct Ia as [<-|Fa],Ib as [<-|Fb];try (exfalso;apply Fa||apply Fb).
        exists (t1∥t2);split;[left|];reflexivity.
      + intros [<-|F];[|exfalso;apply F].
        exists (t1∥t2);split;[|reflexivity].
        apply lift_prod_spec;exists t1,t2;repeat split;left;reflexivity.
    - reflexivity.
    - rewrite IHt;simpl.
      unfold box,Box_list;simpl;reflexivity.
    - reflexivity.
  Qed.
  Lemma termLang_from_term e :
    BSR ⊢ Σ (map from_term (termLang e)) ⩵ e.
  Proof.
    induction e;simpl.
    - rewrite <- IHe1 , <-IHe2 at 2.
      clear;replace bbsr_seq with prod by reflexivity.
      rewrite Σ_prod;apply Σ_proper;simpl.
      unfold interpret;generalize (termLang e2);generalize (termLang e1);intros l m.
      induction l as [|x l IHl];[reflexivity|].
      simpl;unfold prod,prod_list in *;simpl.
      rewrite map_app,map_map,IHl.
      apply mon_congr;[|reflexivity].
      rewrite map_map;simpl;reflexivity.
    - rewrite <- IHe1 , <-IHe2 at 2.
      clear;replace bbsr_par with par by reflexivity.
      rewrite Σ_par;apply Σ_proper;simpl.
      unfold interpret;generalize (termLang e2);generalize (termLang e1);intros l m.
      induction l as [|x l IHl];[reflexivity|].
      simpl;unfold par,par_list in *;simpl.
      rewrite map_app,map_map,IHl.
      apply mon_congr;[|reflexivity].
      rewrite map_map;simpl;reflexivity.
    - unfold join,join_list.
      rewrite map_app;rewrite <-IHe1,<-IHe2 at 2.
      symmetry;eapply Σ_app.
    - apply right_unit.
    - unfold box,Box_list;rewrite map_map;simpl.
      rewrite <- IHe at 2;clear IHe.
      induction (termLang e) as [|b l Ihl];rsimpl.
      + symmetry;apply bbsr_ax;right;auto.
      + rsimpl.
        etransitivity;[|symmetry;apply bbsr_ax;right;apply bbsr_eq_box_plus].
        rewrite <- Ihl;reflexivity.
    - apply right_unit.
    - reflexivity.
  Qed.

  Global Instance from_term_proper : Proper (equiv ==> bbsr_eq BSR) from_term.
  Proof.
    intros s t E;induction E;simpl;auto.
    - eauto.
    - apply mon_assoc.
    - apply mon_assoc.
    - apply bimon_comm.
    - apply left_unit.
    - apply right_unit.
    - apply left_unit.
    - weak_right;auto.
    - weak_right;auto.
  Qed.

  Lemma bcsr_exchange_law :
    forall a b c d : (@bbsr_terms X), BCSR ⊢ (a ∥ b) ⋅ (c ∥ d) ≦ a ⋅ c ∥ b ⋅ d.
  Proof. intros;unfold leqA;symmetry;weak_right;apply bbsr_ax;auto. Qed.

  Lemma bcsr_box_inf :
    forall a : @bbsr_terms X, BCSR ⊢ ▢ a ≦ a.
  Proof. intros a;unfold leqA;symmetry;weak_right;apply bbsr_ax;auto. Qed.

  Global Instance from_term_proper_inf : Proper (subsume ==> leqA (bbsr_eq BCSR)) from_term.
  Proof.
    intros s t E;induction E;simpl;auto.
    - apply from_term_proper in H;rewrite H;reflexivity.
    - rewrite IHE,IHE0;reflexivity.
    - rewrite IHE,IHE0;reflexivity.
    - rewrite IHE,IHE0;reflexivity.
    - rewrite IHE;reflexivity.
    - apply bcsr_exchange_law.
    - apply bcsr_box_inf.
  Qed.

  Corollary termLang_iso e f : BSR ⊢ e ⩵ f <-> (termLang e) ≃ (termLang f).
  Proof.
    split.
    - apply termLang_proper_Ax.
      intros s t [h|h];revert h.
      + apply termLang_proper_bisemiring.
      + apply termLang_proper_box_alg.
    - intros E.
      etransitivity;[symmetry;apply termLang_from_term|].
      etransitivity;[|apply termLang_from_term].
      apply antisymmetry.
      + apply Σ_bounded.
        intros a Ia.
        apply in_map_iff in Ia as (s&<-&Is).
        apply E in Is as (b&Ib&<-).
        apply Σ_bigger,in_map_iff;exists b;tauto.
      + apply Σ_bounded.
        intros a Ia.
        apply in_map_iff in Ia as (s&<-&Is).
        apply E in Is as (b&Ib&<-).
        apply Σ_bigger,in_map_iff;exists b;tauto.
  Qed.
  Lemma from_term_pomsets s :
    lift [⟦s⟧] ≃ ⟦from_term s⟧.
  Proof.
    induction s;rsimpl.
    - rewrite <- IHs1,<-IHs2;clear IHs1 IHs2.
      intro;unfold lift,mem;simpl.
      split;[intros (y&[<-|F]&E)|intros (u1&u2&E&(v1&[<-|F1]&E1)&(v2&[<-|F2]&E2))];
        try (exfalso;apply F||apply F1||apply F2).
      + exists ⟦s1⟧,⟦s2⟧;repeat split.
        * symmetry;assumption.
        * eexists;split;[left;reflexivity|reflexivity].
        * eexists;split;[left;reflexivity|reflexivity].
      + exists (⟦ s1 ⟧ ⋅ ⟦ s2 ⟧).
        rewrite E,<- E1,<-E2.
        split;[tauto|reflexivity].
    - rewrite <- IHs1,<-IHs2;clear IHs1 IHs2.
      intro;unfold lift,mem;simpl.
      split;[intros (y&[<-|F]&E)|intros (u1&u2&E&(v1&[<-|F1]&E1)&(v2&[<-|F2]&E2))];
        try (exfalso;apply F||apply F1||apply F2).
      + exists ⟦s1⟧,⟦s2⟧;repeat split.
        * symmetry;assumption.
        * eexists;split;[left;reflexivity|reflexivity].
        * eexists;split;[left;reflexivity|reflexivity].
      + exists (⟦ s1 ⟧ ∥ ⟦ s2 ⟧).
        rewrite E,<- E1,<-E2.
        split;[tauto|reflexivity].
    - intro;simpl;unfold lift,mem;simpl.
      unfold interpret;simpl;reflexivity.
    - rewrite <- IHs.
      intro;simpl;unfold lift,mem;simpl.
      split.
      + intros (y&[<-|F]&E);[|exfalso;apply F].
        exists ⟦s⟧;split;[|symmetry;assumption].
        exists ⟦s⟧;split;[tauto|reflexivity].
      + intros (q&(p&[<-|F]&E1)&E2);[|exfalso;apply F].
        exists (▢ ⟦ s ⟧);split;[tauto|].
        rewrite E1,<-E2;reflexivity.
    - intro;simpl;unfold lift,mem;simpl.
      split.
      + intros (?&[<-|F]&<-);[reflexivity|tauto].
      + intros E;exists 𝟭;symmetry in E;tauto.
  Qed.

  Lemma termLang_pomsets s :
    ⟦s⟧ ≃ lift (map interpret (termLang s)).
  Proof.
    rewrite <- (termLang_from_term s) at 1.
    induction (termLang s);rsimpl.
    - intro;simpl;split;[tauto|].
      intros (?&F&_);apply F.
    - rewrite IHl;clear IHl.
      rewrite <- from_term_pomsets.
      setoid_rewrite <-join_list_eq.
      reflexivity.
  Qed.
End s.

Require Import pomset_isomorphism.
Section bsr.
  Context {X : Set} {decX : decidable_set X}.

  Theorem completeness_bbsr_terms (s t : @bbsr_terms X) :
    BSR ⊢ s ⩵ t <-> ⟦s⟧ ≃ ⟦t⟧.
  Proof.
    split;[apply soundness_bbsr_terms|].
    intros Is.
    rewrite <- (termLang_from_term s),<- (termLang_from_term t).
    rewrite (termLang_pomsets s),(termLang_pomsets t) in Is.
    apply antisymmetry.
    - apply Σ_bounded.
      intros f If.
      apply in_map_iff in If as (u&<-&Iu).
      assert (Iu' : ⟦u⟧ ∊ (lift (map interpret (termLang s))))
        by (exists ⟦u⟧;split;[apply in_map_iff;exists u;tauto|reflexivity]).
      apply Is in Iu' as (p&Iv&Ev);apply in_map_iff in Iv as (v&<-&Iv).
      apply completeness_bsp_terms_iso in Ev.
      apply from_term_proper in Ev as <-.
      apply Σ_bigger,in_map_iff;exists v;tauto.
    - apply Σ_bounded.
      intros f If.
      apply in_map_iff in If as (u&<-&Iu).
      assert (Iu' : ⟦u⟧ ∊ (lift (map interpret (termLang t))))
        by (exists ⟦u⟧;split;[apply in_map_iff;exists u;tauto|reflexivity]).
      apply Is in Iu' as (p&Iv&Ev);apply in_map_iff in Iv as (v&<-&Iv).
      apply completeness_bsp_terms_iso in Ev.
      apply from_term_proper in Ev as <-.
      apply Σ_bigger,in_map_iff;exists v;tauto.
  Qed.
End bsr.

Require Import pomset_homomorphism.
Section bcsr.
  Context {X : Set} {decX : decidable_set X}.

  Theorem completeness_bcsr_terms (s t : @bbsr_terms X) :
   BCSR ⊢ s ⩵ t <-> ⟦s⟧↓ ≃ ⟦t⟧↓.
  Proof.
    split;[apply soundness_bcsr_terms|].
    intros Is.
    assert (L1 : ⟦s⟧↓ ≲ ⟦t⟧↓) by (rewrite Is;reflexivity).
    assert (L2 : ⟦t⟧↓ ≲ ⟦s⟧↓) by (rewrite Is;reflexivity).
    rewrite closure_incl in L1,L2;clear Is.
    rewrite <-(termLang_from_term s).
    rewrite <-(termLang_from_term t).
    rewrite (termLang_pomsets s),(termLang_pomsets t) in L1,L2.
    apply antisymmetry.
    - apply Σ_bounded.
      intros f If.
      apply in_map_iff in If as (u&<-&Iu).
      assert (Iu' : ⟦u⟧ ∊ (algebra.lift (map interpret (termLang s))))
        by (exists ⟦u⟧;split;[apply in_map_iff;exists u;tauto|reflexivity]).
      apply L1 in Iu' as (q&(p&Iv&Ev)&L).
      apply in_map_iff in Iv as (v&<-&Iv).
      rewrite <- Ev in L;clear q Ev.
      apply completeness_subsumption in L.
      apply from_term_proper_inf in L as ->.
      apply Σ_bigger,in_map_iff;exists v;tauto.
    - apply Σ_bounded.
      intros f If.
      apply in_map_iff in If as (u&<-&Iu).
      assert (Iu' : ⟦u⟧ ∊ (algebra.lift (map interpret (termLang t))))
        by (exists ⟦u⟧;split;[apply in_map_iff;exists u;tauto|reflexivity]).
      apply L2 in Iu' as (q&(p&Iv&Ev)&L).
      apply in_map_iff in Iv as (v&<-&Iv).
      rewrite <- Ev in L;clear q Ev.
      apply completeness_subsumption in L.
      apply from_term_proper_inf in L as ->.
      apply Σ_bigger,in_map_iff;exists v;tauto.
  Qed.
End bcsr.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of statements and expressions, pg. 63.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsHeapObjects.
Require Export StaticSemanticsTypingHeapObjects.
Require Export StaticSemanticsKindingAndContextWellFormedness.

Inductive ret : St -> Prop :=
| ret_ret       : forall (e : E),
                       ret (retn e)

| ret_if        : forall (e : E) (s1 s2 : St),
                       ret s1 ->
                       ret s2 ->
                       ret (if_s e s1 s2)

| ret_seq_1     : forall (s s' : St),
                       ret s ->
                       ret (seq s s')

| ret_seq_2     : forall (s s' : St),
                       ret s' ->
                       ret (seq s s')

| ret_let       : forall (x : EVar) (e : E) (s : St),
                       ret s ->
                       ret (letx x e s)

| ret_open      : forall (e : E) (alpha : TVar) (x : EVar) (s : St),
                       ret s ->
                       ret (open e alpha x s)

| ret_openstar  : forall (e : E) (alpha : TVar) (x : EVar) (s : St),
                       ret s ->
                       ret (openstar e alpha x s).

(* TODO inconsistent naming. *)
Inductive styp : Delta -> Upsilon -> Gamma -> Tau -> St   -> Prop :=
(* This is correct, return at end of program. *)
  | styp_e_3_1    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                           (tau tau': Tau) (e : E),
                      (* This just messes up the proofs. *)
                      rtyp d u g e  tau' ->
                      (* rtyp d u g e  tau -> *)
                      styp d u g tau (e_s e)

  | styp_return_3_2 : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (e : E),
                         rtyp d u g e tau ->
                         styp d u g tau (retn e)

  | styp_seq_3_3    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (s1 s2 : St),
                         styp d u g tau s1 ->
                         styp d u g tau s2 ->
                         styp d u g tau (seq s1 s2)

  | styp_while_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (e: E) (s : St),
                         rtyp d u g e cint ->
                         styp d u g tau s ->
                         styp d u g tau (while e s)

  | styp_if_3_5     :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                              (tau : Tau) (e: E) (s1 s2 : St),
                          rtyp d u g e cint ->
                          styp d u g tau s1 ->
                          styp d u g tau s2 ->
                          styp d u g tau (if_s e s1 s2)

(* Bug 38 wrong tau' in styp. *)
  | styp_let_3_6    :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EVar)  (tau tau' : Tau)
                               (s : St) (e : E),
                          getG g x = None ->
                          K d tau' A ->  (* Thesis change. *)
                          styp d u ([(x,tau')] ++ g) tau s ->
                          rtyp d u g e    tau' ->
                          styp d u g tau  (letx x e s)

(* Bug 33, alpha conversion of alpha here ? *)
(* TODO can I unfold the expected pack here and make these syntax directed ? *)
(* I think so. *)
(* Bug 44, forgot not in domain checks. *)
  | styp_open_3_7   :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EVar)  (p : Phi) (alpha : TVar)
                               (k : Kappa) (tau tau' : Tau)
                               (s : St) (e : E),
                          getD d alpha = None ->
                          getG g x = None ->
                          K d tau A      ->
                          rtyp d u g e (etype p alpha k tau') ->
                          styp ([(alpha,k)] ++ d) u ([(x,tau')] ++ g)
                               tau s ->
                          styp d u g tau (open e alpha x s)

  | styp_openstar_3_8 :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                               (x : EVar)  (alpha : TVar)
                               (k : Kappa) (tau tau' : Tau)
                               (s : St) (e : E),
                          rtyp d u g e (etype aliases alpha k tau') ->
                          styp ([(alpha,k)] ++ d)
                               u
                               ([(x,tau')] ++ g)
                               tau s ->
                          getD d alpha = None ->
                          getG g x = None ->
                          K d tau A      ->
                          styp d u g tau (openstar e alpha x s)

with      ltyp :   Delta -> Upsilon -> Gamma -> E -> Tau -> Prop :=

  | SL_3_1     : forall (d : Delta) (g : Gamma) (u : Upsilon)
                           (x : EVar) (p : P) (tau tau': Tau),
                      getG g x = Some tau' ->
                      gettype u x nil tau' p tau ->
                      WFC d u g->
                      K d tau' A ->
                      ltyp d u g (p_e x p) tau

  | SL_3_2     : forall (d : Delta) (u : Upsilon) (g : Gamma)
                        (e : E) (tau : Tau) ,
                      rtyp d u g e (ptype tau) ->
                      K d tau A ->
                      ltyp d u g (star e) tau

  | SL_3_3     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      ltyp d u g e (cross t0 t1) ->
                      ltyp d u g (dot e zero_pe) t0

  | SL_3_4     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      ltyp d u g e (cross t0 t1) ->
                      ltyp d u g (dot e one_pe) t1

with      rtyp :  Delta -> Upsilon -> Gamma -> E   -> Tau -> Prop :=
  | SR_3_1  : forall (d : Delta) (g : Gamma) (u : Upsilon)
                        (x  : EVar) (p : P) (tau tau': Tau),
                   getG g x = Some tau' ->
                   gettype u x nil tau' p tau ->
                   K d tau' A ->
                   WFC d u g ->
                   rtyp d u g (p_e x p) tau

  | SR_3_2  :  forall (e : E) (tau : Tau)
                      (d : Delta) (u : Upsilon) (g : Gamma),
                    rtyp d u g e (ptype tau) ->
                    K d tau A ->
                    rtyp d u g (star e) tau

  | SR_3_3  :  forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                        rtyp d u g e (cross t0 t1) ->
                        rtyp d u g (dot e zero_pe) t0

  | SR_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      rtyp d u g e (cross t0 t1) ->
                      rtyp d u g (dot e one_pe) t1

  | SR_3_5  : forall (d : Delta) (u : Upsilon) (g : Gamma) (z : Z),
                   WFC d u g ->
                   rtyp d u g (i_e (i_i z)) cint

  | SR_3_6  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (tau : Tau),
                   ltyp d u g e tau ->
                   rtyp d u g (amp e) (ptype tau)

  | SR_3_7  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e0 e1: E) (t0 t1 : Tau),
                   rtyp d u g e0 t0 ->
                   rtyp d u g e1 t1 ->
                   rtyp d u g (cpair e0 e1) (cross t0 t1)

  | SR_3_8  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau : Tau),
                   ltyp d u g e1 tau ->
                   rtyp d u g e2 tau ->
                   ASGN d tau    ->
                   rtyp d u g (assign e1 e2) tau

  | SR_3_9  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau tau' : Tau),
                   rtyp d u g e1 (arrow tau' tau) ->
                   rtyp d u g e2 tau' ->
                   rtyp d u g (appl e1 e2) tau

  | SR_3_10 : forall (d : Delta) (u : Upsilon) (g : Gamma) (tau : Tau) (s : St),
                   styp d u g tau s ->
                   ret s ->
                   rtyp d u g (call s) tau

  | SR_3_11 : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau': Tau) (alpha : TVar) (k : Kappa),
                   rtyp d u g e (utype alpha k tau') ->
                   AK   d tau k ->
                   rtyp d u g (inst e tau) (subst_Tau tau' tau alpha)

  | SR_3_12 : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau': Tau) (alpha : TVar) (k : Kappa) (p : Phi),
                   rtyp d u g e (subst_Tau tau tau' alpha) ->
                   AK   d tau' k ->
                   K    d (etype p alpha k tau) A ->
                   rtyp d u g (pack tau' e (etype p alpha k tau))
                              (etype p alpha k tau)

  | SR_3_13 : forall (d : Delta) (u : Upsilon) (g : Gamma) (tau tau': Tau)
                     (s : St) (x : EVar),
                   getG g x = None ->
                   styp d u ([(x,tau)] ++ g) tau' s ->
                   ret s ->
                   rtyp d u g (f_e (dfun tau x tau' s)) (arrow tau tau')

  | SR_3_14 : forall (d : Delta) (u : Upsilon) (g : Gamma) (f : F)
                        (tau : Tau) (alpha : TVar) (k : Kappa),
                   getD d alpha = None ->
                   WFC  d u g ->
                   rtyp ([(alpha,k)] ++ d) u g (f_e f) tau ->
                   rtyp d u g (f_e (ufun alpha k f)) (utype alpha k tau).

Scheme styp_ind_mutual := Induction for styp Sort Prop
with   ltyp_ind_mutual := Induction for ltyp Sort Prop
with   rtyp_ind_mutual := Induction for rtyp Sort Prop.
Combined Scheme typ_ind_mutual from
          styp_ind_mutual, ltyp_ind_mutual, rtyp_ind_mutual.

 (* Bug 42, getH *)
Inductive htyp: Upsilon -> Gamma -> H -> Gamma -> Prop :=
   | htyp_empty : forall (u : Upsilon) (g: Gamma),
                       htyp u g [] []
   | htyp_xv    : forall (u : Upsilon) (g g': Gamma) (h h': H) (x : EVar) (v : E) (tau : Tau),
                      getH h x = Some v ->
                      Value v ->
                      deleteH h x = h' ->
                      htyp u g h' g' ->
                      rtyp nil u g v tau ->
                      htyp u g h ([(x, tau)] ++ g').

(* Bug 43, getH *)
Inductive refp  : H -> Upsilon -> Prop :=
  | refp_empty  : forall (h : H),
                       refp h nil
  | refp_pack  : forall (h : H) (u : Upsilon) (x : EVar) (p : P) (tau tau' : Tau) (alpha : TVar) (k : Kappa) (v v' : E),
                      getH h x = Some v' ->
                      get v' p (pack tau' v (etype aliases alpha k tau)) ->
                      refp h u ->
                      refp h ([((x, p),tau')] ++ u).

Inductive prog  : H -> St -> Prop :=
  | program  : forall (h : H) (u : Upsilon) (g : Gamma) (tau : Tau) (s : St),
                    htyp u g h g ->
                    refp h u     ->
                    styp nil u g tau s ->
                    ret s ->
                    prog h s.


Definition injective :=
fun {rT aT : Type} (f : aT -> rT) => forall x1 x2 : aT, f x1 = f x2 -> x1 = x2.
Definition nat_of_bool := fun b : bool => if b then 1 else 0.
Lemma nat_of_bool_inj : injective nat_of_bool.
Proof.
unfold injective.
intros.
unfold nat_of_bool in * |-.
destruct x1,x2; (trivial || inversion H).
(*trivial.
inversion H.
inversion H.
trivial.*)
Defined.

CoInductive bigbody (R I : Type) : Type :=
    BigBody : I -> (R -> R -> R) -> bool -> R -> bigbody R I.

Definition applybig {R I} (body : bigbody R I) (x:R) :  R
:= (match body with
| BigBody _ _ _ op true v => op v x
| BigBody _ _ _ op false _ => x
end).

Definition funcomp :=fun {A B C : Type} (u : unit) (f : B -> A) (g : C -> B) (x : C) =>
let 'tt := u in f (g x).
Definition foldr :=fun {T R : Type} (f : T -> R -> R) (z0 : R) =>
fix foldr (s : list T) : R :=
  match s with
  | nil => z0
  | cons x s' => f x (foldr s')
  end.

Definition reducebig R I idx r (body : I -> bigbody R I) :=
  foldr (funcomp tt applybig body) idx r.

Section bigop_sec.
Hypothesis bigop : forall {R} {I}, R -> list I -> (I -> bigbody R I) -> R.

Check bigop _ _ 0.
(*Definition index_enum (T : finType) := Finite.enum T.*)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(*Lemma nat_of_bool_inj : injective nat_of_bool.
Proof. by case=> [] []. Qed.*)

Lemma all_false n (r : n.-tuple bool) :
  \max_(i in 'I_n) tnth r i <= 0 ->
  forall i, tnth r i = false.
Proof.
by move/bigmax_leqP => H i; apply/nat_of_bool_inj/eqP; rewrite -leqn0 H.
Show Proof.
Qed.

(**"\max_"
bigmax_leqP : forall (I : finType) (P : pred I) (m : nat) (F : I -> nat),
       reflect (forall i : I, P i -> F i <= m) (\max_(i | P i) F i <= m)
eqP : reflect (?x = ?y) (?x == ?y)
leqn0 : forall n : nat, (n <= 0) = (n == 0)

"\max_ ( i | P ) F" := BigOp.bigop O (index_enum _)
                         (fun i => BigBody i maxn P F) : nat_scope
**)
Lemma all_false_tran (n:nat) (r:list bool) :

->
True.

Locate "\o".
Print funcomp.
Print foldr.

Locate ".-tuple".
Print tuple_of.
Locate "\max_".
(*"\max_ ( i 'in' A ) F" := BigOp.bigop O (index_enum _)
                            (fun i => BigBody i maxn (in_mem i (mem A)) F)
: nat_scope *)

Check BigBody.
(* BigBody : forall R I : Type, I -> (R -> R -> R) -> bool -> R -> bigbody R I *)
Print BigBody.
Locate "'I_".
(* "''I_' n" := ordinal n (default interpretation) *)
Print tnth.
(* tnth =
fun (n : nat) (T : Type) (t : n.-tuple T) (i : 'I_n) =>
nth (tnth_default t i) t i
     : forall (n : nat) (T : Type), n.-tuple T -> 'I_n -> T *)


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e213m3_7limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Export Coq.Init.Datatypes.
Require Export List.
Export ListNotations.

Open Scope type_scope.

Inductive term : Type :=
|lambda : term -> term
|loc : nat -> term
|unit : term
|var : nat -> term
|app : term -> term -> term
|get : term -> term
|put : term -> term -> term
|alloc : term -> term
|fork : term -> term
|atomic : term -> term
|inatomic : term -> term.

Inductive value : term -> Prop :=
|v_lam : forall e, value (lambda e)
|v_loc : forall n, value (loc n)
|v_unit : value unit.

Inductive ctxt : Type :=
|hole : ctxt
|appCtxt : term -> ctxt -> ctxt
|appValCtxt (t:term) : value t -> ctxt -> ctxt
|getCtxt : ctxt -> ctxt
|putCtxt : term -> ctxt -> ctxt
|putValCtxt (t:term) : value t -> ctxt -> ctxt
|allocCtxt : ctxt -> ctxt
|inatomicCtxt : ctxt -> ctxt.

Definition location := nat.
Definition stamp := nat.

Inductive logItem : Type :=
|readItem : location -> ctxt -> term -> logItem
|writeItem : location -> term -> logItem
.

Definition log := list logItem.

Definition thread := option (nat * term) * log * term.

Inductive pool : Type :=
|Single : thread -> pool
|Par : pool -> pool -> pool.


Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import VST.msl.Coqlib2.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.subgraph2.

Section DualGraph.

Context {V E: Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Context (g: PreGraph V E).

Definition dual_src e := dst g e.
Definition dual_dst e := src g e.
Definition dualgraph: PreGraph V E :=
  Build_PreGraph EV EE (vvalid g) (evalid g) dual_src dual_dst.

End DualGraph.


(*
MacBook-Air:trunk billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Practice_07.

Coq < Goal forall a b c d e f g h i j:Prop, (((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ (i /\ j)) /\ ~f) -> ~b.
1 subgoal

  ============================
   forall a b c d e f g h i j : Prop,
   ((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j) /\ ~ f -> ~ b

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  f : Prop
  g : Prop
  h : Prop
  i : Prop
  j : Prop
  H : ((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j) /\ ~ f
  ============================
   ~ b

Unnamed_thm < elim H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  f : Prop
  g : Prop
  h : Prop
  i : Prop
  j : Prop
  H : ((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j) /\ ~ f
  ============================
   (a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j -> ~ f -> ~ b

Unnamed_thm < intro.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  e : Prop
  f : Prop
  g : Prop
  h : Prop
  i : Prop
  j : Prop
  H : ((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j) /\ ~ f
  H0 : (a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ i /\ j
  ============================
   ~ f -> ~ b

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Practice_07.
Goal forall a b c d e f g h i j:Prop, (((a /\ b) /\ (c /\ d) /\ (e /\ f) /\ (g /\ h) /\ (i /\ j)) /\ ~f) -> ~b.
intros.
elim H.
intro.
firstorder.
Qed.


(**   Pierre Casteran
      LaBRI, Université de Bordeaux
*)
Set Apply With Renaming.

From Coq Require Import Arith Lia  List  Relation_Operators
     Operators_Properties Peano_dec Wellfounded.Inverse_Image
     Wellfounded.Inclusion.

From hydras Require Import More_Arith Epsilon0  Hessenberg
     Simple_LexProd MoreLibHyps.

From hydras Require Export Hydra_Definitions.
Import Relations.
Open Scope nat_scope.

(** ** Properties of the  [hydra] data type
 *)

Lemma add_r_0 : forall h: Hydra, add_r h 0 = h.
  now destruct h.
Qed.

Lemma hy_app_assoc :
  forall (s1 s2 s3 : Hydrae) ,
    hy_app s1 (hy_app s2 s3) = hy_app (hy_app s1 s2) s3.
Proof.
  induction s1.
  - reflexivity.
  - intros s2 s3; cbn; now rewrite IHs1.
Qed.

Lemma hcons_mult_app : forall (h: Hydra) (n :nat) (s s': Hydrae),
    hcons_mult h n (hy_app s s') =
    hy_app (hcons_mult h n s) s'.
Proof.
  induction n.
  - now cbn.
  - cbn; intros; now rewrite IHn.
Qed.

Lemma hcons_mult_comm :
  forall i h s,
    hcons_mult h i (hcons h s) = hcons h (hcons_mult h i s).
Proof.
   induction i as [| i IHi]; simpl; auto.
   intros; now rewrite IHi.
Qed.

(* Properties of R1, R2, S0, S1 and S2 *)

Lemma R1_iff s s' : R1 (node s) (node s') <->  S0 s s'.
Proof.
 split.
   - now inversion 1.
   - now constructor.
Qed.

Lemma R2_iff i s s' : R2 i (node s) (node s') <->
                      S1 i s s' \/ S2 i s s'.
Proof.
  split.
  - inversion 1; auto.
  - destruct 1; [left| right];trivial.
Qed.

Lemma S2_iff : forall n h h' s s',
    S2 n (hcons h s) (hcons h' s') <->
    R2 n h h' /\ s = s' \/
                 h = h' /\ S2 n s s'.
Proof.
  split.
  - inversion 1.
  +  subst s; auto.
  +   right;auto.
  -   intros [[H0 H1] | [H0 H1]].
      +  subst s; now left.
      +  subst h'; now right.
Qed.

Lemma S0_app : forall s1 s2 s3, S0 s2 s3 ->
                                S0 (hy_app s1 s2)
                                   (hy_app s1 s3).
Proof.
  induction s1.
  - cbn; auto.
  - intros; cbn;  constructor;auto.
Qed.

Lemma R1_app : forall s1 s2 s3,
    R1 (node s2) (node s3) ->
    R1 (node (hy_app s1 s2)) (node (hy_app s1 s3)).
Proof.
  constructor; inversion  H; now apply S0_app.
Qed.

Lemma S1_app n : forall s1 s2 s3,
    S1 n s2 s3 -> S1 n (hy_app s1 s2) (hy_app s1 s3).
Proof.
  induction s1; simpl hy_app.
  - trivial.
  - intros s2 s3 H; constructor; auto.
Qed.

(** Induction Schemes for R2 *)

Scheme R2_ind2 := Induction for R2 Sort Prop
                  with
                  S2_ind2 := Induction for S2 Sort Prop.
Arguments  R2_ind2 n P P0 : rename.
Arguments  S2_ind2 n P P0 : rename.

Lemma S2_app : forall  n  s1 s2 ,
    S2 n s1 s2 ->
    forall l,  S2 n (hy_app l s1) (hy_app l s2).
Proof.
  intros n s1 s2 h;
    eapply  S2_ind2 with
        (P := fun h1 h2 _ => match h1, h2 with
                               node s1, node s2 =>
                               forall l, R2 n (node (hy_app l s1))
                                            (node (hy_app l s2))
                             end).
  - intros; constructor.
    apply S1_app; auto.
    intros;  eauto.
  - constructor 2.
    induction l.
    + cbn; auto.
    + cbn; now constructor 2.
  -  intros h0 h' s r  H l;  destruct h0, h';  induction l.
     + simpl;auto.
     +  simpl;auto; constructor 2;auto.
  - auto.
  -  eexact h.
Qed.

Lemma R2_app n : forall  s1 s2 ,
    R2 n (node s1) (node  s2) ->
    forall l,  R2 n (node (hy_app l s1))
                  (node (hy_app l s2)).
Proof.
      intros s1 s2 H;  inversion  H.
      - intros; constructor.
        apply S1_app; auto.
      -  constructor 2; now apply S2_app.
Qed.

Lemma hcons_mult_S0 : forall h  i s s' ,
                             S0 s s' ->
                             S0 (hcons_mult h i s)
                                (hcons_mult h i s').
Proof.
    induction i.
    - now  simpl.
    - right; auto.
Qed.

Lemma hcons_mult_S1 n : forall h i  s s' , S1 n s s' ->
                                         S1  n (hcons_mult h i s)
                                              (hcons_mult h i s').
Proof.
  induction i.
  - now  simpl.
 -  right;auto.
Qed.

Lemma hcons_mult_S2 n : forall h  i s s' , S2 n s s' ->
                                            S2 n (hcons_mult h i s)
                                               (hcons_mult h i s').
Proof.
  induction i.
  - now  simpl.
  - right;auto.
Qed.

(**  ** Properties of single rounds *)

Lemma head_no_round_n : forall i h, ~ round_n i head h.
Proof.
  intros i h  H; destruct H.
  - inversion H.
    inversion H1.
  -  inversion H.
     +  inversion H1.
     +  inversion H1.
Qed.

Lemma head_no_round : forall h, ~ round head h.
Proof.
  intros h H; destruct H as [i Hi].
  now apply (head_no_round_n i h).
Qed.

(** ** Properties of [battle] *)

(* begin snippet battleTrans *)
Lemma rounds_trans {b:Battle} :
  forall i h j h', rounds b i h j h' ->
                   forall k h0,  rounds b k h0 i h ->
                                 rounds b k h0 j h'. (* .no-out *)
(*| .. coq:: no-out |*)
Proof.
  intros i h j h' H k h0. induction 1 /dr.
  - intros h'0 ? ?; now right with h'0.
  - intros ? ? ? h'' ? ? ? ; right with h'';auto.
Qed.
(*||*)
(* end snippet battleTrans *)

(** ** Properties of standard and free battle classes *)

Lemma standard_incl_free : forall i h h',
     battle_rel standard   i h  h'-> battle_rel  free  i h h' .
Proof.
  -   intros; red.  red in H. now  exists i.
Qed.

Lemma standard_battle_head :
  forall i h j h',
    @rounds standard  i h j h' ->  h <> head.
Proof.
  induction 1;  intro; subst h; eapply head_no_round_n ; eauto.
Qed.

(** **  Generic properties of round_plus *)

Lemma round_plus_trans : forall h h' h'', h -+-> h' ->
                                      h' -+-> h'' ->
                                      h -+-> h''.
Proof.
  unfold round_plus.
  intros h h' h''; repeat rewrite <- clos_trans_t1n_iff.
  econstructor 2; eauto.
Qed.

Lemma S0_remove_r : forall l , S0 (add_head_r l) l.
  induction l; simpl.
  - left.
 - now right.
Qed.

Lemma S0_remove_r_i : forall i l, S0 (add_head_r_plus l (S i))
                                     (add_head_r_plus l i).
Proof.
  simpl;  intros; apply S0_remove_r.
Qed.

Lemma R1_remove_r_i : forall i h,
                       R1 (add_r h (S i)) (add_r h i).
Proof.
  destruct h; constructor; apply S0_remove_r_i.
Qed.

Lemma round_n_remove_h : forall i j h,
    round_n j  (add_r h (S i)) (add_r h i).
Proof.
  intros; left;apply R1_remove_r_i.
Qed.

Lemma remove_heads_r : forall i h j, rounds standard
                                       j
                                       (add_r h (S i))
                                       (S i+j)%nat
                                       h.
Proof.
  induction i.
 -   simpl;  intros; left;auto.
     simpl; replace  h with (add_r  h 0) at 2.
     +  left;  apply R1_remove_r_i.
     +  now rewrite add_r_0.
 - intros h j;  specialize (IHi h (S j)).
    apply rounds_trans with (S j) (add_r h (S i)).
    +    replace (S (S i) + j)%nat with (S i + S j)%nat;  auto.
         lia.
    +   left.
        * apply round_n_remove_h.
Qed.

Lemma remove_heads_r_free: forall i h j, rounds free
                                       j
                                       (add_r h (S i))
                                       (S i+j)%nat
                                       h.
Proof.
  intros; specialize (remove_heads_r i h j).
 induction 1.
 left. now apply standard_incl_free.
  auto.
  right with h''.
  now apply standard_incl_free.
  auto.
Qed.

Lemma variant_mono_free  {A:Type} {Lt: relation A}{Tr : Transitive Lt}
      {Wf: well_founded Lt} m {V: Hvariant Wf free m}:
  forall i h j h', rounds free i h j h' -> Lt (m h') (m h).
Proof.
  induction 1;auto.
  -  apply (variant_decr 0).
     + intro; subst; eapply head_no_round; eauto.
     + auto.
  - transitivity (m h''); auto.
    apply (variant_decr  0).
    +  intro; subst; eapply head_no_round; eauto.
    + auto.
Qed.

Lemma m_strict_mono  {A:Type} {Lt: relation A}{St: StrictOrder  Lt}
      {Wf: well_founded Lt} m (V: @Hvariant _ _ Wf free m){h h':Hydra}:
  h -+->  h' -> Lt (m h') (m h).
 Proof.
      induction 1;auto.
      apply (variant_decr 0).
      - intro; subst; eapply head_no_round; eauto.
      - auto.
      - transitivity (m y); auto.
        apply (variant_decr  0).
      +  intro; subst; eapply head_no_round; eauto.
      + auto.
    Qed.

(** companion lemmas for R1 and R2 *)

Lemma round_n_inv i h h' : round_n i h h' -> R1 h h' \/ R2 i h h'.
Proof.
  destruct 1;auto.
Qed.

Lemma rounds_free_equiv1 : forall i j h h',
    rounds free i h j h' ->
    h -+-> h'.
Proof.
  induction 1.
  - now  left.
  - now  right with h''.
 Qed.

Lemma rounds_free_equiv2 : forall h h',
     h -+-> h' ->
    forall i, exists j,  rounds  free i h j h'.
Proof.
  induction 1 as [h h' H | h h'' h' H H0 Hind].
  - intro i; exists (S i); left;auto.
  - intros i. destruct (Hind (S i)) as [j Hj].
    exists j; eright; eauto.
 Qed.

Lemma Termination_strong (B:Battle) :
   Termination -> B_termination B.
Proof.
  intro H; red; apply wf_incl  with (R2:=(transp _ round)).
  - intros h' h;   destruct 1 as [i Hi];
     now  generalize (battle_ok _ _ _ Hi).
  -  apply H.
Qed.

Lemma Hvariant_Termination {A : Type} {lt : relation A}
      (Hwf : well_founded lt) (m : Hydra -> A) :
  @Hvariant _ _ Hwf  free m ->  Termination.
Proof.
  destruct 1.
  intro x; apply Acc_incl with (fun h' h =>  lt (m h') (m h)).
  - intros h' h H; destruct H; apply variant_decr with x0.
    + intro ; subst h;  apply (head_no_round_n _ _ H).
    + exists x0; easy.
  -  apply Acc_inverse_image, Hwf.
Qed.

(* begin snippet nextRoundDec *)

(** If the hydra is not reduced to a head, there exists at
    least one head that  Hercules can chop off  *)

Definition  next_round_dec n (h: Hydra) :
  (h = head) + {h' : Hydra & {R1 h h'} + {R2  n h  h'}}. (* .no-out *)
(*| .. coq:: none |*)
Proof.
induction h using   Hydra_rect2 with
(P0 :=
   (fun hs =>
      (hs = hnil) +
      { hs' : Hydrae & ( S0 hs hs') + {S1 n hs hs'} + {S2 n hs hs'}})%type).
rename h into s.
- destruct s.
  + now left.
  + right.
    destruct IHh.
    * discriminate.

    * destruct s0 as [hs' [s0 | s0]].
      { destruct s0.
        (** chose  a lowest head *)
        exists (node hs').
        left;   now constructor.
        exists (node hs').
        right; now left.
      }
      {  exists (node hs').
         right;now right.
      }
- now left.
- destruct IHh.
  +  right;  exists h0 ; left ; left.
  (* choose the leftmost head *)
  subst h; left.
  +  right;   destruct s as [h' [H1 | H1]].
   *   exists (hcons_mult h' (S n)  h0).
       left; right ;   now constructor.
   *   exists (hcons h' h0);  right ;  now constructor.
Defined.
(*||*)

(* end snippet nextRoundDec *)

Definition  next_round  n :
 forall h , round_spec h n.
Proof.
  intro h; destruct (next_round_dec n h).
  - now right.
  - destruct s as [h' [H | H]].
    + left; exists h'; now left.
    + left; exists h'; now right.
Defined.

Definition next_step (f : forall n h, round_spec h n) n h :=
  match f n h with
      inright _ => head
    | inleft (exist _ h' _) =>  h'
  end.

Definition classic_battle f t h :=
  let fix go n t h :=
      match h, t with head, _ => h
                   |   _, 0 => h
                | _, S t' => go (S n) t' (next_step f n h)
      end
  in go 1 t h.


Require Import Permutation.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Utf8 Omega.
Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Require Import Coq.Init.Wf.
Require Import Coq.Init.Specif.

Section Swap.

Variable At : Set.

(* Equality on atoms is decidable *)

Axiom eqAtDec : forall a1 a2 : At, {a1 = a2} + {a1 <> a2}.

Lemma atDecRefl : forall a, exists H, eqAtDec a a = left H.
  intros. destruct (eqAtDec a a). exists e. reflexivity.
  contradiction.
Qed.

Ltac rewriteAtRefl a := let H := fresh in let E := fresh in pose proof (atDecRefl a); destruct H as [E H];
  rewrite H; clear H; clear E.

Definition swap (a1 a2 a : At) : At :=
  if eqAtDec a a1 then a2 else if eqAtDec a a2 then a1 else a.

(* TODO this should be automatizable once I am smarter *)

Lemma swapCasesFirst: forall a1 a2 a, (a = a1) -> (swap a1 a2) a = a2.
Proof.
  intros a1 a2 a H. compute; subst. rewriteAtRefl a1. reflexivity.
Qed.

Lemma swapCasesSecond: forall a1 a2 a, (a = a2) -> (swap a1 a2) a = a1.
Proof with (subst; auto).
  intros a1 a2 a H. compute... rewriteAtRefl a2. destruct (eqAtDec a2 a1)...
Qed.

Lemma swapCasesNone: forall a1 a2 a, (a <> a1) -> (a <> a2) -> (swap a1 a2) a = a.
Proof with (try contradiction; auto).
  intros a1 a2 a I1 I2. compute. destruct (eqAtDec a a1)... destruct (eqAtDec a a2)...
Qed.

Lemma swapId : forall a, swap a a = @id At.
Proof with (subst;auto).
  intros. extensionality a'. destruct (eqAtDec a a'). rewrite swapCasesFirst...
  rewrite swapCasesNone...
Qed.

Lemma swapId' : forall a a1, (swap a a) a1 = a1.
Proof.
  intros. replace a1 with (id a1) by reflexivity. rewrite swapId. reflexivity.
Qed.

Local Hint Rewrite swapCasesFirst swapCasesSecond swapCasesNone.

(* Solves if the goal requires one case analysis *)

Ltac swapCases :=
  auto;
  try (rewrite swapCasesFirst; [ swapCases | solve [swapCases]]);
  try (rewrite swapCasesSecond; [ swapCases | solve [swapCases]]);
  try (rewrite swapCasesNone; [ swapCases | solve [swapCases] | solve [swapCases]]).

Lemma swapSelfInverse : forall a1 a2, compose (swap a1 a2) (swap a1 a2) = @id At.
Proof with (subst; auto).
  intros a1 a2. extensionality a; unfold compose.
  destruct (eqAtDec a a1) as [e1 | i1]; subst; swapCases.
  destruct (eqAtDec a a2) as [e2 | i2]; subst; swapCases.
Qed.

Lemma swapSelfInverse' : forall a1 a2 a, (swap a1 a2) ((swap a1 a2) a) = a.
Proof.
  intros a1 a2 a.
  replace a with (id a) at 2 by reflexivity.
  erewrite <- swapSelfInverse. reflexivity.
Qed.

Lemma swapComm : forall a1 a2, swap a1 a2 = swap a2 a1.
Proof with (subst; auto).
  intros. extensionality a. destruct (eqAtDec a a1) as [e1 | i1],
    (eqAtDec a a2) as [e2 | i2]; subst; swapCases.
Qed.

Instance swapPerm (a1 a2 : At) :
  Permutation At (swap a1 a2) (swap a1 a2) := {}.
Proof.
  - apply swapSelfInverse'.
  - apply swapSelfInverse'.
Defined.

Import ListNotations.

Instance swapFinPerm (a1 a2 : At) :
  FinPerm At (swap a1 a2) (swap a1 a2) := {
  perm := swapPerm a1 a2;
}.
Proof with (subst; auto).
  destruct (eqAtDec a1 a2).
  - exists nil. intros a. intros H...
    exfalso. apply H. simpl. rewrite swapId...
  - exists (a1 :: a2 :: nil). intros.
    destruct (eqAtDec a a1) as [e1 | i1]...
     + left...
     + right. destruct (eqAtDec a a2) as [e2 | i2]...
        { left... }
        { right. exfalso. apply H. simpl. rewrite swapCasesNone... }
Defined.

(* Every finite permutation can be constructed by a sequence of swaps *)

Fixpoint swapList (l : list (At * At)) (a : At) : At :=
  match l with
    | [] => a
    | (a1, a2) :: l' => swap a1 a2 (swapList l' a)
  end.

Corollary swapList_cons:
  forall a1 a2 l1 l2 a, swapList l2 (swapList ((a1, a2) :: l1) a) =
    swapList (l2 ++ [(a1, a2)]) (swapList l1 a).
Proof. induction l2.
  - simpl. reflexivity.
  - intros. destruct a. simpl. rewrite <- IHl2. reflexivity.
Qed.

Corollary swapList_app: forall l1 l2 a, swapList (l1 ++ l2) a =
  swapList l1 ((swapList l2) a).
Proof.
  induction l1.
  - simpl. reflexivity.
  - intros. destruct a as [a1 a2]. simpl. rewrite IHl1. reflexivity.
Qed.

Instance swapListPerm (l : list (At * At)) :
  Permutation At (swapList l) (swapList (rev l)):= {}.
Proof.
  - induction l.
    + reflexivity.
    + intros a0. destruct a as [a1 a2].
      replace (rev ((a1, a2) :: l)) with ((rev l) ++ [(a1, a2)]) by reflexivity.
      rewrite swapList_app. simpl. rewrite IHl. apply swapSelfInverse'.
  - induction l.
    + reflexivity.
    + intros. destruct a as [a1 a2]. simpl.
      rewrite swapList_app. simpl. rewrite swapSelfInverse'. apply IHl.
Defined.

Instance swapListFinPerm (l : list (At * At)) : FinPerm At (swapList l) (swapList (rev l)):= {
  perm := swapListPerm l;
}.
Proof with (subst; auto).
  exists (fold_right (fun a l => match a with (a1, a2) => (a1 :: a2 :: l) end) [] l).
  intros a Ineq. generalize dependent a. induction l; intros.
  - simpl in Ineq. contradiction.
  - destruct a as [a1 a2]. simpl in *. destruct (eqAtDec a1 a0), (eqAtDec a2 a0)...
    right; right. apply IHl. intros C. rewrite C in Ineq.
    apply Ineq. apply swapCasesNone...
Defined.

Definition lengthOrder := (fun (l1 l2 : list At) => length l1 < length l2).

Lemma wellFoundedLeq: well_founded lengthOrder.
Proof with (subst; auto).
  unfold lengthOrder. intros l1. constructor. induction (length l1).
  - intros l2 L. inversion L.
  - intros l2 L. induction l2.
    + constructor. intros l3 L2. inversion L2.
    + constructor. intros l3 L3. apply IHn. omega.
Qed.

Definition swapList_noDup (l : list (At * At)) :=
  (NoDup (fold_right (fun p l2 => match p with (a1, a2) =>  a1 :: a2 :: l2 end) [] l)).

Definition swapList_useful (p : finPermType At) (l : list (At * At)) :=
  (forall a a', In (a, a') l -> (a <> a' /\ p a <> a /\ p a' <> a' /\ p a <> p a')).

Lemma permutationToSwaps : forall p : finPermType At, exists (l : list (At * At)),
  getFinPermFunction  p = swapList l /\ swapList_noDup l /\ swapList_useful p l.
Proof with (subst; auto).
  intros [[f g] [P [l I]]]. simpl.
  generalize dependent f. generalize dependent g. generalize dependent l. simpl.

  apply (@well_founded_ind (list At) lengthOrder wellFoundedLeq
   (fun l =>
      forall (g f : At → At) (P : Permutation At f g) (I : ∀ a : At, f a ≠ a → In a l),
          ∃ l0 : list (At * At), f = swapList l0
            ∧ swapList_noDup l0
            ∧ swapList_useful (exist (λ p : (At → At) * (At → At),
              FinPerm At (fst p) (snd p)) (f, g) {| perm := P;
                finite := ex_intro
                  (λ l1 : list At, ∀ a : At, f a ≠ a → In a l1) l I |}) l0)).
  - intros l H g f P I. destruct l.
    (* Base case *)
    + exists nil. split; try split...
      * extensionality a. destruct (eqAtDec (f a) a); auto. apply I in n. inversion n.
      * constructor.
      * intros a a' IA. simpl. inversion IA.
    (* Induction step *)
    + (* This will be the reduced permutation *)
      remember (compose f (swap a (g a))) as f' eqn:F'.

      (* Firt prove three auxiliary facts *)
      assert (f' a = a). {
        subst. unfold compose. swapCases. apply permInvRight. apply P. }

      assert (forall a', a' <> a -> f a' = a' -> f' a' = a').
      { intros a' IA PA. rewrite F'. autounfold. simpl in *.
        destruct (eqAtDec a' (g a)).
        { swapCases. subst. exfalso. apply IA. rewrite <- PA. rewrite permInvLeft...
          apply permInverse. apply P. }
        { swapCases. }
      }

      assert (lengthOrder l (a :: l)) as L. { unfold lengthOrder. constructor. }
      destruct (eqAtDec (g a) a).
      * eapply H in L. clear H. destruct L as [l1 [IH1 [IH2 IH3]]].
        unfold swapList_noDup in IH2. unfold swapList_useful in IH3. simpl in *.
        exists l1. split; [apply IH1| clear IH1]. split...
        Unshelve.
        apply g. apply P.
        intros. assert (a0 <> a). rewrite <- perm_inv_same_domain with (f := f) in e...
        intros C... apply I in H. destruct H. symmetry in H. contradiction. apply H.
      * eapply H with (f := f') in L. clear H. destruct L as [l1 [IH1 [IH2 IH3]]].
        exists (l1 ++ [(a, g a)]). split; try split.
        { extensionality a'. rewrite swapList_app. rewrite <- IH1.
          simpl. rewrite F'. unfold compose. rewrite swapSelfInverse'. reflexivity. }
        { admit. }
        { unfold swapList_useful in *. simpl in *. intros.
          apply in_app_or in H. destruct H.
          { admit. }
          { destruct H; try inversion H.
            split; repeat try split...
            { rewrite perm_inv_same_domain'. apply n. apply P. }
            { rewrite permInvLeft... apply permInverse... }
            { rewrite permInvRight... rewrite perm_inv_same_domain'.
              apply n. apply P. }
          }
        Unshelve. apply (compose (swap a (g a)) g).
        constructor. intros. subst. unfold compose. rewrite swapSelfInverse'.
        apply permInvRight... intros. subst... unfold compose.
        replace (g (f (swap a (g a) a0))) with ((swap a (g a) a0)).
        apply swapSelfInverse'. rewrite permInvLeft...
        intros. subst. assert (a <> a0). intros C. subst.
        unfold compose in H. rewrite swapCasesFirst in H. apply H. apply permInvRight...
        reflexivity. destruct (eqAtDec (g a) a0).
        unfold compose in H. eapply perm_chain in e.
        rewrite perm_inv_same_domain' with (g := f) in e. apply I in e.
        destruct e. contradiction. apply H3. apply permInverse...
         apply permInverse. apply P. apply H2.
        unfold compose in H. rewrite swapCasesNone in H...
        apply I in H. destruct H. contradiction. apply H.
Admitted.

End Swap.