Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.EquivalenceWhiskeredNonCurriedMonoidalCategories.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesReordered.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.FinalLayer.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.CurriedMonoidalCategories.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.AssociatorUnitorsLayer.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.FinalLayer.

Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.EquivalenceMonCatCurried.
Require Import UniMath.Bicategories.MonoidalCategories.UnivalenceMonCat.EquivalenceWhiskeredCurried.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

(*
Definition TODO {A : UU} : A.
Admitted.

Section EquivalenceMonCatNonCurried.

  Definition cmonoidal_to_noncurriedmonoidal
    :  ob UMONCAT ≃ ∑ C : monoidal_cat, is_univalent (monoidal_cat_cat C).
  Proof.
    refine (_ ∘ equivalence_cmon_structure_oblayer)%weq.

    refine (_ ∘ _)%weq.
    {
      use weqfibtototal.
      2: exact (λ C, cmon_equiv_wmon (pr1 C)).
    }

    refine (_ ∘ _)%weq.
    1: apply weqtotal2comm12.

    use weq_subtypes'.
    - refine (moncats0_equiv_uncurried ∘ moncats_equiv_moncats0 ∘ _)%weq.
      use weqfibtototal.
      intro C.
      exact (invweq (monoidal_struct_equiv_monoidal C)).
    - intro ; apply isaprop_is_univalent.
    - intro ; apply isaprop_is_univalent.
    - intro ; apply isrefl_logeq.
  Defined.

End EquivalenceMonCatNonCurried.

Section EquivalenceMonCatNonCurriedLaxFunctors.

  Lemma UMONCAT_2cell_equality
        {M N : ob UMONCAT} {F G : hom M N}
        (α β : (hom M N)⟦F,G⟧)
    : (∏ x : pr11 M,  (pr11 α) x = (pr11 β) x) -> α = β.
  Proof.
    intro p.
    repeat (use total2_paths_f).
    - apply funextsec ; intro x.
      exact (p x).
    - apply isaprop_is_nat_trans.
      apply homset_property.
    - repeat (apply funextsec ; intro) ; apply homset_property.
    - apply homset_property.
    - apply isapropunit.
    - apply isapropunit.
    - apply isapropunit.
    - apply isapropunit.
  Qed.

  Lemma LaxMonoidalFunctor_mor_equality
        {M N : monoidal_cat} {F G : LaxMonoidalFunctorCat M N}
        (α β : (LaxMonoidalFunctorCat M N)⟦F,G⟧)
    : (∏ x : pr11 M,  (pr111 α) x = (pr111 β) x) -> α = β.
  Proof.
    intro p.
    repeat (use total2_paths_f).
    - apply funextsec ; intro x.
      exact (p x).
    - apply isaprop_is_nat_trans.
      apply homset_property.
    - repeat (apply funextsec ; intro) ; apply homset_property.
    - apply homset_property.
    - apply isapropunit.
    - apply isapropunit.
    - apply isapropunit.
  Qed.

  Lemma tensor_on_hom_eq
        (M : ob UMONCAT)
        {x1 x2 y1 y2 : pr11 M}
        (f : (pr11 M)⟦x1,x2⟧) (g : (pr11 M)⟦y1,y2⟧)
    : tensor_on_hom (pr11 (pr112 M)) x1 x2 y1 y2 f g = # (pr121 (cmonoidal_to_noncurriedmonoidal M)) (f #, g).
  Proof.
    etrans.
    2: {  apply (tensor_comp (pr1 (pr112 M)) _ _ _ _ _ _ _ _ _ _). }
    rewrite id_right.
    now rewrite id_left.
  Qed.

  Definition cmonoidal_to_noncurried_functor_pt_data
             (M N : ob UMONCAT)
             {F : functor (pr11 M) (pr11 N)}
             (ptF : functor_tensor_disp_cat
                      (pr121 (cmonoidal_to_noncurriedmonoidal M))
                      (pr121 (cmonoidal_to_noncurriedmonoidal N)) F
             )
    :  preserves_tensor_data (pr1 (pr111 (pr2 M))) (pr1 (pr111 (pr2 N))) F
    := λ x y, pr1 ptF (x,y).

  Lemma cmonoidal_to_noncurried_functor_pt_nat
        (M N : ob UMONCAT)
             {F : functor (pr11 M) (pr11 N)}
             (ptF : functor_tensor_disp_cat
                      (pr121 (cmonoidal_to_noncurriedmonoidal M))
                      (pr121 (cmonoidal_to_noncurriedmonoidal N)) F
             )
    : preserves_tensor_nat (cmonoidal_to_noncurried_functor_pt_data M N ptF).
  Proof.
    intros x1 x2 y1 y2 f g.
    refine (_ @ ! pr2 ptF _ _ (f #, g) @ _).
    - apply maponpaths.
      apply (maponpaths (#F)).
      apply tensor_on_hom_eq.
    - apply maponpaths_2.
      exact (! tensor_on_hom_eq N (#F f) (#F g)).
  Qed.

  Definition cmonoidal_to_noncurried_functor_pt
             (M N : ob UMONCAT)
             {F : functor (pr11 M) (pr11 N)}
             (ptF : functor_tensor_disp_cat
                      (pr121 (cmonoidal_to_noncurriedmonoidal M))
                      (pr121 (cmonoidal_to_noncurriedmonoidal N)) F
             )
    : preserves_tensor (pr111 (pr2 M)) (pr111 (pr2 N)) F
    := _ ,, cmonoidal_to_noncurried_functor_pt_nat M N ptF.

  Lemma cmonoidal_to_noncurrier_preserves_lunitor
        (M N : ob UMONCAT)
        (F : LaxMonoidalFunctorCat
               (pr1 (cmonoidal_to_noncurriedmonoidal M))
               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
    : preserves_lunitor
        (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F)
        (pr112 (pr12 M)) (pr112 (pr12 N)).
  Proof.
    intro x.
    refine (_ @ ! (pr112 F x)).
    do 2 apply maponpaths_2.
    apply tensor_on_hom_eq.
  Qed.

  Lemma cmonoidal_to_noncurrier_preserves_runitor
        (M N : ob UMONCAT)
        (F : LaxMonoidalFunctorCat
               (pr1 (cmonoidal_to_noncurriedmonoidal M))
               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
    : preserves_runitor
        (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F)
        (pr212 (pr12 M)) (pr212 (pr12 N)).
  Proof.
    intro x.
    refine (_ @ ! (pr212 F x)).
    do 2 apply maponpaths_2.
    apply tensor_on_hom_eq.
  Qed.

  Lemma cmonoidal_to_noncurrier_preserves_associator
        (M N : ob UMONCAT)
        (F : LaxMonoidalFunctorCat
               (pr1 (cmonoidal_to_noncurriedmonoidal M))
               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
    : preserves_associator
        (cmonoidal_to_noncurried_functor_pt M N (pr121 F),, pr221 F)
        (pr221 (pr2 M)) (pr221 (pr2 N)).
  Proof.
    intros x y z.
    etrans. {
      do 2 apply maponpaths_2.
      apply tensor_on_hom_eq.
    }
    refine (pr22 F x y z @ _).
    apply maponpaths_2.
    rewrite <- (tensor_on_hom_eq N).
    apply idpath.
  Admitted.

  Definition cmonoidal_to_noncurried_functor
             (M N : ob UMONCAT)
    :  LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                             (pr1 (cmonoidal_to_noncurriedmonoidal N)) → UMONCAT ⟦ M, N ⟧.
  Proof.
    intro F.
    use tpair.
    { exact (pr11 F). }

    use tpair.
    - use tpair.
      + split.
        * apply cmonoidal_to_noncurried_functor_pt.
          apply (pr121 F).
        * exact (pr221 F).
      + repeat split.
        * apply cmonoidal_to_noncurrier_preserves_lunitor.
        * apply cmonoidal_to_noncurrier_preserves_runitor.
        * apply cmonoidal_to_noncurrier_preserves_associator.
    - exact tt.
  Defined.

  Definition cmonoidal_from_noncurried_functor (M N : ob UMONCAT)
    :  UMONCAT ⟦ M, N ⟧
       → LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                               (pr1 (cmonoidal_to_noncurriedmonoidal N)).
  Proof.
    intro F.
    use tpair.
    - exists (pr1 F).
      split.
      + use tpair.
        * intro ; apply (pr1 (pr112 F)).
        * intros [x1 x2] [y1 y2] [f g].
          etrans. { apply maponpaths_2, (! tensor_on_hom_eq N _ _). }
          refine (! pr21 (pr112 F) x1 y1 x2 y2 f g @ _).
          simpl.
          do 2 apply maponpaths.
          apply tensor_on_hom_eq.
      + apply (pr2 (pr112 F)).
    - repeat split.
      + abstract (
            intro x ;
            refine (! (pr11 (pr212 F) x) @ _) ;
            do 2 apply maponpaths_2 ;
            apply (tensor_on_hom_eq N)).
      + abstract (
            intro x ;
            refine (! (pr21 (pr212 F) x) @ _) ;
            do 2 apply maponpaths_2 ;
            apply (tensor_on_hom_eq N)).
      + intros x y z.
        (*
        etrans. { do 2 apply maponpaths_2. apply (! tensor_on_hom_eq N _ _). }
        refine ((pr2 (pr212 F) x y z) @ _).
        apply maponpaths_2.
        apply maponpaths.
        apply (tensor_on_hom_eq N).
         *)
        apply TODO.
  Defined.

  Definition cmonoidal_from_noncurried_nattrans
             (M N : ob UMONCAT)
             { F G : hom M N }
             (α : hom M N ⟦ F, G ⟧)
    :  LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                             (pr1 (cmonoidal_to_noncurriedmonoidal N))
                             ⟦ (λ F0 : hom M N, cmonoidal_from_noncurried_functor M N F0) F,
                               (λ F0 : hom M N, cmonoidal_from_noncurried_functor M N F0) G ⟧.
  Proof.
    use tpair.
    - exists (pr1 α).
      split.
      + intros x y.
        etrans. {
          apply maponpaths_2.
          apply (! tensor_on_hom_eq N _ _).
        }
        exact (! pr1 (pr112 α) x y).
      + exact (pr2 (pr112 α)).
    - repeat split.
  Defined.

  Definition cmonoidal_to_noncurried_nattrans
             (M N : UMONCAT)
             {F G : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
        (pr1 (cmonoidal_to_noncurriedmonoidal N))}
             (α : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                                        (pr1 (cmonoidal_to_noncurriedmonoidal N)) ⟦ F, G ⟧)
    : (hom M N)⟦ (λ F0 : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
              (pr1 (cmonoidal_to_noncurriedmonoidal N)), cmonoidal_to_noncurried_functor M N F0) F,
  (λ F0 : LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                                (pr1 (cmonoidal_to_noncurriedmonoidal N)), cmonoidal_to_noncurried_functor M N F0) G ⟧.
  Proof.
    exists (pr11 α).
    use tpair.
    - use tpair.
      + split.
        * intros x y.
          etrans.
          2: {
            apply maponpaths_2.
            apply (! tensor_on_hom_eq N _ _).
          }
          exact (! pr121 α x y).
        * exact (pr221 α).
      + repeat split ; exact tt.
    - repeat split.
  Defined.

  Definition cmonoidal_to_noncurried_hom_data
             (M N : ob UMONCAT)
    : functor_data
        (hom M N)
        (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                                               (pr1 (cmonoidal_to_noncurriedmonoidal N))).
  Proof.
    use make_functor_data.
    - intro F.
      exact (cmonoidal_from_noncurried_functor M N F).
    - intros F G α.
      exact (cmonoidal_from_noncurried_nattrans M N α).
  Defined.

  Definition cmonoidal_from_noncurried_hom_data
             (M N : ob UMONCAT)
    : functor_data
        (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
        (hom M N).
  Proof.
    use make_functor_data.
    - intro F.
      exact (cmonoidal_to_noncurried_functor M N F).
    - intros F G α.
      exact (cmonoidal_to_noncurried_nattrans M N α).
  Defined.

  Lemma cmonoidal_to_noncurried_hom_is_functor
        (M N : ob UMONCAT)
    : is_functor (cmonoidal_to_noncurried_hom_data M N).
  Proof.
    split.
    - intro.
      apply LaxMonoidalFunctor_mor_equality.
      intro ; apply idpath.
    - intro ; intros.
      apply LaxMonoidalFunctor_mor_equality.
      intro ; apply idpath.
  Qed.

  Lemma cmonoidal_from_noncurried_hom_is_functor
        (M N : ob UMONCAT)
    : is_functor (cmonoidal_from_noncurried_hom_data M N).
  Proof.
    split.
    - intro.
      apply UMONCAT_2cell_equality.
      intro ; apply idpath.
    - intro ; intros.
      apply UMONCAT_2cell_equality.
      intro ; apply idpath.
  Qed.

  Definition cmonoidal_to_noncurried_hom
             (M N : ob UMONCAT)
    : functor
        (hom M N)
        (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
    := _ ,, cmonoidal_to_noncurried_hom_is_functor M N.

  Definition cmonoidal_from_noncurried_hom
             (M N : ob UMONCAT)
    : functor
        (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                               (pr1 (cmonoidal_to_noncurriedmonoidal N)))
        (hom M N)
    := _ ,, cmonoidal_from_noncurried_hom_is_functor M N.

  Definition cmonoidal_unit_noncurried_hom_data (M N : ob UMONCAT)
    : nat_trans_data (functor_identity (hom M N))
                (cmonoidal_to_noncurried_hom M N ∙ cmonoidal_from_noncurried_hom M N).
  Proof.
    intro F.
    exists (nat_trans_id _).
    use tpair.
    - use tpair.
      + use tpair.
        * intros x y.

          rewrite id_right.
          refine (! id_left _ @ _).
          apply maponpaths_2.
          etrans.
          2: { apply (! tensor_on_hom_eq N _ _). }
          exact (! functor_id (pr121 (cmonoidal_to_noncurriedmonoidal N)) (pr11 F x , pr11 F y)).
        * apply id_right.
      + repeat split.
    - exact tt.
  Defined.

  Definition cmonoidal_unit_noncurried_hom_is_nat_trans
             (M N : ob UMONCAT)
    : is_nat_trans _ _ (cmonoidal_unit_noncurried_hom_data M N).
  Proof.
    intro ; intros.
    use UMONCAT_2cell_equality.
    intro.
    exact (id_right _ @ ! id_left _).
  Qed.

  Definition cmonoidal_unit_noncurried_hom (M N : ob UMONCAT)
    : nat_trans (functor_identity (hom M N))
                (cmonoidal_to_noncurried_hom M N ∙ cmonoidal_from_noncurried_hom M N)
    := _ ,, cmonoidal_unit_noncurried_hom_is_nat_trans M N.

  Definition cmonoidal_counit_noncurried_hom_data (M N : ob UMONCAT)
    :  nat_trans_data
         (cmonoidal_from_noncurried_hom M N ∙ cmonoidal_to_noncurried_hom M N)
         (functor_identity (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                                                  (pr1 (cmonoidal_to_noncurriedmonoidal N)))).
  Proof.
    intro F.
    use tpair.
    - exists (nat_trans_id _).
      split.
      + intros x y.
        simpl ; rewrite id_right ; cbn.
        etrans. {
          apply maponpaths_2.
          etrans. {
            apply (! tensor_on_hom_eq N _ _).
          }
          apply tensor_id.
        }
        apply id_left.
      + apply id_right.
    - repeat (use tpair) ; exact tt.
  Defined.

  Definition cmonoidal_counit_noncurried_hom_is_nat_trans (M N : ob UMONCAT)
    :  is_nat_trans _ _ (cmonoidal_counit_noncurried_hom_data M N).
  Proof.
    intro ; intros.
    use LaxMonoidalFunctor_mor_equality.
    intro.
    exact (id_right _ @ ! id_left _).
  Qed.

  Definition cmonoidal_counit_noncurried_hom (M N : ob UMONCAT)
    :  nat_trans
         (cmonoidal_from_noncurried_hom M N ∙ cmonoidal_to_noncurried_hom M N)
         (functor_identity (LaxMonoidalFunctorCat (pr1 (cmonoidal_to_noncurriedmonoidal M))
                                                  (pr1 (cmonoidal_to_noncurriedmonoidal N))))
    := _ ,, cmonoidal_counit_noncurried_hom_is_nat_trans M N.

  Definition cmonoidal_formadjunction_noncurried (M N : ob UMONCAT)
    :  form_adjunction _ _ (cmonoidal_unit_noncurried_hom M N) (cmonoidal_counit_noncurried_hom M N).
  Proof.
    split.
    - intro ; intros.
      apply LaxMonoidalFunctor_mor_equality ; intro ; apply id_left.
    - intro ; intros.
      apply UMONCAT_2cell_equality ; intro ; apply id_left.
  Qed.

  Definition cmonoidal_formequivalence_noncurried (M N : ob UMONCAT)
    :  forms_equivalence
         (cmonoidal_to_noncurried_hom M N ,, cmonoidal_from_noncurried_hom M N,, cmonoidal_unit_noncurried_hom M N,, cmonoidal_counit_noncurried_hom M N).
  Proof.
    split ; intro.
    - use tpair.
      + repeat (use tpair).
        * apply nat_trans_id.
        * apply nat_trans_id.
        * intros x y.
          simpl.
          rewrite id_right.
          etrans.
          2: {
            apply maponpaths_2.
            apply (! tensor_id _ _ _).
          }
          apply (! id_left _).
        * apply id_right.
        * exact tt.
        * exact tt.
        * exact tt.
        * exact tt.
      + split ; apply UMONCAT_2cell_equality ; intro ; apply id_right.
    - use tpair.
      + repeat (use tpair).
        * apply nat_trans_id.
        * apply nat_trans_id.
        * intros x y.
          simpl.
          rewrite id_right.
          etrans. {
            apply maponpaths_2.
            apply (! tensor_on_hom_eq N _ _).
          }
          etrans. {
            apply maponpaths_2.
            apply (tensor_id _ _ _).
          }
          apply id_left.
        * apply id_right.
        * exact tt.
        * exact tt.
        * exact tt.
      + split.
        * apply LaxMonoidalFunctor_mor_equality.
          intro ; apply id_right.
        * apply LaxMonoidalFunctor_mor_equality.
          intro ; apply id_right.
  Defined.

  Definition cmonoidal_adjequiv_noncurried_hom
             (M N : ob UMONCAT)
    : adj_equivalence_of_cats (cmonoidal_to_noncurried_hom M N).
  Proof.
    use make_adj_equivalence_of_cats.
    - exact (cmonoidal_from_noncurried_hom M N).
    - exact (cmonoidal_unit_noncurried_hom M N).
    - exact (cmonoidal_counit_noncurried_hom M N).
    - exact (cmonoidal_formadjunction_noncurried M N).
    - exact (cmonoidal_formequivalence_noncurried M N).
  Defined.
End EquivalenceMonCatNonCurriedLaxFunctors.
*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e383m187_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj12eqsynthconj2 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus Zero (plus lv1 lv0))).
Admitted.
QuickChick conj12eqsynthconj2.


Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.

Section MachineModel.
  Definition var : Type := nat.
  Definition location : Type := nat.
  Definition register (value_t: Type) : Type := var -> value_t.
  Definition memory (value_t: Type) : Type := location -> value_t.
End MachineModel.

Section Security.
  Inductive sec_level : Set :=
  | L : sec_level
  | H : sec_level.

  Definition sec_level_le (sl sl': sec_level) :=
    match sl, sl' with
    | H, L  => False
    | _, _ => True
    end.

  Definition sec_level_le_compute (sl sl': sec_level) :=
    match sl, sl' with
      | H, L  => false
      | _, _ => true
    end.
  Lemma sec_level_le_correct (sl sl': sec_level) :
    sec_level_le_compute sl sl' = true <-> sec_level_le sl sl'.
  Proof.
    destruct sl, sl'; intuition; try discriminate; unfold sec_level_le in *; auto.
  Qed.

  Definition sec_level_join (sl sl': sec_level) : sec_level :=
    match sl, sl' with
    | H, _ | _, H => H
    | L, L => L
    end.
  Lemma sec_level_join_ge (sl sl': sec_level) :
    sec_level_le sl (sec_level_join sl sl') /\ sec_level_le sl' (sec_level_join sl sl').
  Proof.
    induction sl, sl'; unfold sec_level_join; unfold sec_level_le; auto.
  Qed.
  Lemma sec_level_join_le_l (sl sl' sl'': sec_level) :
    sec_level_le (sec_level_join sl sl') sl'' -> sec_level_le sl sl''.
  Proof.
    induction sl, sl', sl''; unfold sec_level_join; unfold sec_level_le; auto.
  Qed.
  Lemma sec_level_join_le_r (sl sl' sl'': sec_level) :
    sec_level_le (sec_level_join sl sl') sl'' -> sec_level_le sl' sl''.
  Proof.
    induction sl, sl', sl''; unfold sec_level_join; unfold sec_level_le; auto.
  Qed.
  Lemma sec_level_le_trans (sl sl' sl'': sec_level) :
    sec_level_le sl sl' -> sec_level_le sl' sl'' -> sec_level_le sl sl''.
  Proof.
    intros; unfold sec_level_le; induction sl, sl', sl''; auto.
  Qed.
  Lemma sec_level_le_refl (sl : sec_level) :
    sec_level_le sl sl.
  Proof.
    intros; unfold sec_level_le; induction sl; auto.
  Qed.

  Lemma sec_level_join_comm (sl sl' : sec_level) :
    sec_level_join sl sl' = sec_level_join sl' sl.
  Proof.
    intros; unfold sec_level_join; induction sl, sl'; auto.
  Qed.

  Definition sec_spec : Type :=  location -> sec_level.
  Definition well_formed_spec (g : sec_spec) : Prop := forall l, exists p, g l = p.

  Definition protected (sl: sec_level) : Prop := sl = H.
  Lemma join_protected_l (sl sl': sec_level) :
    protected sl -> protected (sec_level_join sl sl').
  Proof.
    induction sl, sl'; unfold sec_level_join; simpl; auto.
    intros. inversion H0.
  Qed.
  Lemma join_protected_r (sl sl': sec_level) :
    protected sl' -> protected (sec_level_join sl sl').
  Proof.
    induction sl, sl'; unfold sec_level_join; simpl; auto.
    intros. inversion H0.
  Qed.

  Parameter g0: sec_spec.
  Parameter immutable_locs: sec_spec -> set location.
End Security.


(** * Bicolano: Big step (interface only) *)

(* <Insert License Here>

    $Id: BigStep.v 68 2006-02-02 15:06:27Z davidpichardie $ *)

(** Big step semantics.

 @author Benjamin Gregoire *)
(* Hendra : - Modified to suit DEX program.
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_Domain.

Set Implicit Arguments.
Definition cons_option (A:Set) (o:option A) (l:list A) :=
   match o with
   | None => l
   | Some e => e::l
   end.
Unset Implicit Arguments.

Section TRANS.
 Set Implicit Arguments.
 Variable A B :Type.
 Variable R : A -> A + B -> Prop.

 Inductive TransStep_l : A -> A + B -> Prop :=
   | TransStep_l_refl : forall a,
       TransStep_l a (inl _ a)
   | TransStep_l_one : forall a r,
        R a r -> TransStep_l a r
   | TransStep_l_trans : forall a1 a2 r,
       R a1 (inl _ a2) ->
       TransStep_l a2 r ->
       TransStep_l a1 r.

 Variable R' : A -> A -> Prop.

 Inductive ClosReflTrans : A -> A -> Prop :=
   | ClosReflTrans_refl : forall a, ClosReflTrans a a
   | ClosReflTrans_trans : forall a a' a'',
       R' a a' ->
       ClosReflTrans a' a'' ->
       ClosReflTrans a a''.

 Unset Implicit Arguments.

End TRANS.

Open Scope type_scope.

Module Type DEX_BIGSTEP.

 Declare Module DEX_Dom : DEX_SEMANTIC_DOMAIN.

 Load "DEX_BigStepLoad.v".

  Parameter IntraStepStar_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop),
      (forall m s, P m s (inl _ s)) ->
      (forall m s r, DEX_exec_return p m s r -> P m s (inr _ r)) ->
      (forall m s s' , DEX_exec_intra p m s s' ->
         forall r, DEX_IntraStepStar p m s' r -> P m s' r ->
         P m s r) ->
   forall m s r, DEX_IntraStepStar p m s r -> P m s r.

  Parameter IntraStepStar_intra_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState -> Prop),
      (forall m s, P m s s) ->
      (forall m s s', DEX_exec_intra p m s s' ->
         forall s'', DEX_IntraStepStar_intra p m s' s'' -> P m s' s'' ->
         P m s s'') ->
   forall m s s', DEX_IntraStepStar_intra p m s s' -> P m s s'.

  Parameter BigStep_ind :
   forall (p:DEX_Program)
    (P : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop),
      (forall m s r, DEX_exec_return p m s r -> P m s r) ->
      (forall m s s' , DEX_exec_intra p m s s' ->
         forall r, DEX_BigStep p m s' r -> P m s' r ->
         P m s r) ->
   forall m s r, DEX_BigStep p m s r -> P m s r.

  Parameter ReachableStar_ind :
   forall (p:DEX_Program)
    (P : (DEX_Method * DEX_IntraNormalState) -> (DEX_Method * DEX_IntraNormalState) -> Prop),
      (forall m s, P (m,s) (m,s)) ->
      (forall m s s', DEX_exec_intra p m s s' ->
         forall m' s'', ClosReflTrans (DEX_ReachableStep p) (m,s') (m',s'') ->
         P (m,s') (m',s'') ->
         P (m,s) (m',s'')) ->
   forall ms ms',
      ClosReflTrans (DEX_ReachableStep p) ms ms' -> P ms ms'.

End DEX_BIGSTEP.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section VotedForTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votedFor_term_sanity (net : network) : Prop :=
    forall t h h',
      currentTerm (snd (nwState net h')) = t ->
      votedFor (snd (nwState net h')) = Some h ->
      t <= currentTerm (snd (nwState net h)).

  Class votedFor_term_sanity_interface : Prop :=
    {
      votedFor_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votedFor_term_sanity net
    }.
End VotedForTermSanity.


Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.

Definition spositive (a: tree): tree :=
  tmatch a tfalse ttrue.

Definition tpred (a: tree): tree :=
  tmatch a (err T_nat) (lvar 0 term_var).

Definition notype_tpred (a: tree): tree :=
  tmatch a notype_err (lvar 0 term_var).

Definition negate (t: tree): tree := ite t tfalse ttrue.
Definition unfold_left (t: tree): tree := sum_match t (lvar 0 term_var) notype_err.
Definition unfold_right (t: tree): tree := sum_match t notype_err (lvar 0 term_var).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************)
(*    Proof of Huffman algorithm: UList.v                              *)
(*                                                                     *)
(*    Definition of list with distinct elements                        *)
(*                                                                     *)
(*    Definition: ulist                                                *)
(*                                                                     *)
(*                                    Laurent.Thery@inria.fr (2003)    *)
(***********************************************************************)

Require Import List.
Require Import Arith.
From Huffman Require Import Permutation.
From Huffman Require Import sTactic.

Section UniqueList.
Variable A : Type.
Variable eqA_dec : forall a b : A, {a = b} + {a <> b}.

(* A list is unique if there is not twice the same element in the list *)
Inductive ulist : list A -> Prop :=
  | ulist_nil : ulist nil
  | ulist_cons : forall a l, ~ In a l -> ulist l -> ulist (a :: l).
Hint Constructors ulist : core.

(* Inversion theorem *)
Theorem ulist_inv : forall a l, ulist (a :: l) -> ulist l.
Proof using.
intros a l H; inversion H; auto.
Qed.

(* The append of two unique list is unique if the list are distinct *)
Theorem ulist_app :
 forall l1 l2,
 ulist l1 ->
 ulist l2 -> (forall a : A, In a l1 -> In a l2 -> False) -> ulist (l1 ++ l2).
Proof using.
intros L1; elim L1; simpl in |- *; auto.
intros a l H l2 H0 H1 H2; apply ulist_cons; simpl in |- *; auto.
red in |- *; intros H3; case in_app_or with (1 := H3); auto; intros H4.
inversion H0; auto.
apply H2 with a; auto.
apply H; auto.
apply ulist_inv with (1 := H0); auto.
intros a0 H3 H4; apply (H2 a0); auto.
Qed.

(* Inversion theorem the appended list *)
Theorem ulist_app_inv :
 forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 -> False.
Proof using.
intros l1; elim l1; simpl in |- *; auto.
intros a l H l2 a0 H0 [H1| H1] H2.
inversion H0; auto.
case H5; rewrite H1; auto with datatypes.
apply (H l2 a0); auto.
apply ulist_inv with (1 := H0); auto.
Qed.

(* Inversion theorem the appended list *)
Theorem ulist_app_inv_l : forall l1 l2 : list A, ulist (l1 ++ l2) -> ulist l1.
Proof using.
intros l1; elim l1; simpl in |- *; auto.
intros a l H l2 H0; inversion H0; apply ulist_cons; auto.
Contradict H3; auto with datatypes.
apply H with l2; auto.
Qed.

(* Inversion theorem the appended list *)
Theorem ulist_app_inv_r : forall l1 l2 : list A, ulist (l1 ++ l2) -> ulist l2.
Proof using.
intros l1; elim l1; simpl in |- *; auto.
intros a l H l2 H0; inversion H0; auto.
Qed.

(* Uniqueness is decidable *)
Definition ulist_dec : forall l, {ulist l} + {~ ulist l}.
intros l; elim l; auto.
intros a l1 [H| H]; auto.
case (In_dec eqA_dec a l1); intros H2; auto.
right; red in |- *; intros H1; inversion H1; auto.
right; Contradict H; apply ulist_inv with (1 := H).
Defined.

(* Uniqueness is compatible with permutation *)
Theorem ulist_perm :
 forall l1 l2 : list A, permutation l1 l2 -> ulist l1 -> ulist l2.
Proof using.
intros l1 l2 H; elim H; clear H l1 l2; simpl in |- *; auto.
intros a l1 l2 H0 H1 H2; apply ulist_cons; auto.
inversion H2; auto.
Contradict H4; apply permutation_in with (1 := permutation_sym _ _ _ H0);
 auto.
inversion H2; auto.
intros a b L H0; apply ulist_cons; auto.
inversion H0; auto.
inversion H3; auto.
simpl in |- *; Contradict H7; case H7; auto.
intros H8; case H2; rewrite H8; simpl in |- *; auto.
apply ulist_cons; auto.
inversion H0; auto.
Contradict H2; simpl in |- *; auto.
inversion H0; auto.
inversion H3; auto.
Qed.

End UniqueList.
Arguments ulist [A].
Hint Constructors ulist : core.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal31.

Set Printing Depth 1000.
Definition lfind_eval  n:=
Cons n Nil.

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).

Compute lfind_eval  (Zero).


(*=== There is THE OLD CODE below! ===*)

(*Require Import ClassicalChoice. choice
Theorem choice :
 forall (A B : Type) (R : A->B->Prop),
   (forall x : A, exists y : B, R x y) ->
    exists f : A->B, (forall x : A, R x (f x)).*)

Definition choice :=
  forall (A B : Type) (P : A -> B -> Prop),
  (forall a : A, (exists b : B, P a b)) ->
  (exists f : A -> B, forall a : A, P a (f a)).

Check sup.
(*Section sec_choice.*)
(*Context (AC : choice).*)
Section sec2.
Context (S:Ens).
Context (H:~IN Vide S).

(* попроще: *)
Section easy.
Definition A:=pi1 S.
Definition B:=pi1 (Union S).
Definition P:= fun ts tus => IN (pi2 (Union S) tus) (pi2 S ts).
Theorem hyp : forall a : A, (exists b : B, P a b).
Proof.
intro a.
unfold A, B, P in *|-*.
pose (XinS := lem4 S a). (*apply (lem4 S) in a as XinS.???*) (* 'IN X S' *)
pose (X:=pi2 S a). (* Множество 'X' соответствует терму 'a'.*)
(*'X' is nonempty *)
(* so there exists q, 'IN q X' *)
pose (J:=lem3 S H X XinS).
destruct J as [b binX].
pose (binUS := IN_Union S X b XinS binX).
exists (in2term _ _ binUS).
fold X in XinS |- *.
simpl.
eapply IN_sound_left.
apply goodlem.
assumption.
Defined.

(* function and property *)
Definition fp := ex2sig _ _ (AC A B P hyp).
Definition fu := fun v : pi1 S =>
 OrdPair (pi2 S v) (pi2 (Union S) ((proj1_sig fp) v)).
Definition chfu : Ens := (sup (pi1 S) fu).
Theorem choifunc_total (X:Ens) (G:IN X S): exists Q, IN (OrdPair X Q) chfu /\ IN Q X.
Proof.
pose (t:=in2term S X G).
pose (p:=fu t).
(*&pose (p:=t). *)
unfold fu in p.
exists (pi2 (Union S) (proj1_sig fp t)).
split.
(*exists p.*)
{ unfold chfu.
  unfold IN.
exists t. (*!*)
unfold t.

apply OrdPair_sound_both.
apply goodlem.
apply EQ_refl. }
{
pose (Y:= proj2_sig fp t).
unfold P in Y.
eapply IN_sound_right.
2 : exact Y.
unfold t.
apply EQ_sym.
apply goodlem. }
Defined.


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

Coq < Section Simplification_C.

Coq < Goal forall x z m g h:Prop, (((x -> z) /\ m) /\ (g -> h)) -> ((x -> z) /\ m).
1 subgoal

  ============================
   forall x z m g h : Prop, ((x -> z) /\ m) /\ (g -> h) -> (x -> z) /\ m

Unnamed_thm < intros.
1 subgoal

  x : Prop
  z : Prop
  m : Prop
  g : Prop
  h : Prop
  H : ((x -> z) /\ m) /\ (g -> h)
  ============================
   (x -> z) /\ m

Unnamed_thm < apply H.
No more subgoals.

Unnamed_thm < Qed.
intros.
apply H.

Unnamed_thm is defined

Coq <

*)

Section Simplification_C.
Goal forall x z m g h:Prop, (((x -> z) /\ m) /\ (g -> h)) -> ((x -> z) /\ m).
intros.
apply H.
Qed.


From Coq Require Import PArith.
From Coq Require Import Omega.
From Coq Require Import List.

Import List.ListNotations.
Open Scope list_scope.

From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.Memories.

(** * Defined variables *)

(**

  The [Is_defined_in] predicate identifies the variables defined by a
  set of equations.

 *)

Module Type ISDEFINED
       (Ids            : IDS)
       (Op             : OPERATORS)
       (Import CESyn   : CESYNTAX     Op)
       (Import Syn     : NLSYNTAX Ids Op CESyn)
       (Import Mem     : MEMORIES Ids Op CESyn Syn).

  (** ** Logical predicates: *)

  Inductive Is_defined_in_eq : ident -> equation -> Prop :=
  | DefEqDef:
      forall x ck e,
        Is_defined_in_eq x (EqDef x ck e)
  | DefEqApp:
      forall x xs ck f e r,
        In x xs ->
        Is_defined_in_eq x (EqApp xs ck f e r)
  | DefEqFby:
      forall x ck v e,
        Is_defined_in_eq x (EqFby x ck v e).

  (* definition is needed in signature *)
  Definition Is_defined_in (x: ident) (eqs: list equation) : Prop :=
    List.Exists (Is_defined_in_eq x) eqs.

  (** ** Properties *)

  Hint Constructors Is_defined_in_eq.

  Lemma not_Is_defined_in_eq_EqDef:
    forall x i ck ce,
      ~ Is_defined_in_eq x (EqDef i ck ce) -> x <> i.
  Proof.
    intros x i ck ce H0 xeqi.
    rewrite xeqi in H0.
    assert (Is_defined_in_eq i (EqDef i ck ce)) by auto.
    contradiction.
  Qed.

  Lemma not_Is_defined_in_eq_EqApp:
    forall x ys ck f le r,
      ~ Is_defined_in_eq x (EqApp ys ck f le r) -> ~ List.In x ys.
  Proof.
    intros * H. intro.
    exfalso. apply H. auto.
  Qed.

  Lemma Is_defined_in_EqApp:
    forall xs ck f es r d,
      0 < length xs ->
      Is_defined_in_eq (hd d xs) (EqApp xs ck f es r).
  Proof.
    intros * Length.
    constructor.
    destruct xs; simpl in *; auto; omega.
  Qed.

  Lemma not_Is_defined_in_eq_EqFby:
    forall x i ck v0 le,
      ~ Is_defined_in_eq x (EqFby i ck v0 le) -> x <> i.
  Proof.
    intros x i ck v0 le H0 xeqi.
    rewrite xeqi in H0.
    assert (Is_defined_in_eq i (EqFby i ck v0 le)) by auto.
    contradiction.
  Qed.

  Lemma not_Is_defined_in_cons:
    forall x eq eqs,
      ~Is_defined_in x (eq :: eqs)
      <-> ~Is_defined_in_eq x eq /\ ~Is_defined_in x eqs.
  Proof.
    intros x eq eqs. split.
    - (* ==> *)
      intro Hndef; split; intro His_def;
        eapply Hndef. now constructor. now constructor 2.
    - (* <== *)
      intros [Hdef_eq Hdef_eqs] Hdef_all.
      inv Hdef_all; eauto.
  Qed.

  Lemma In_memory_eq_In_defined_eq_gen:
    forall x eq S,
      PS.In x (memory_eq S eq)
      -> Is_defined_in_eq x eq \/ PS.In x S.
  Proof.
    intros x eq S.
    destruct eq; simpl; intro HH; try intuition.
    apply PS.add_spec in HH; intuition.
    subst; left; constructor.
  Qed.

  Corollary In_memory_eq_Is_defined_eq:
    forall x eq,
      PS.In x (memory_eq PS.empty eq)
      -> Is_defined_in_eq x eq.
  Proof.
    intros.
    cut (Is_defined_in_eq x eq \/ PS.In x PS.empty).
    intro His_def; destruct His_def; auto; not_In_empty.
    apply In_memory_eq_In_defined_eq_gen; auto.
  Qed.

  Lemma Is_defined_in_memories:
    forall x eqs,
      PS.In x (memories eqs) -> Is_defined_in x eqs.
  Proof.
    unfold memories, Is_defined_in.
    induction eqs.
    - simpl; intro; not_In_empty.
    - intro HH; simpl in HH.
      apply In_fold_left_memory_eq in HH.
      rewrite List.Exists_cons.
      destruct HH as [HH|HH].
      + right; now apply IHeqs with (1:=HH).
      + left.
        apply In_memory_eq_Is_defined_eq in HH; auto.
  Qed.

  Lemma In_EqFby_Is_defined_in:
    forall x ck c0 e eqs,
      In (EqFby x ck c0 e) eqs ->
      Is_defined_in x eqs.
  Proof.
    induction eqs; inversion_clear 1; subst.
    now repeat constructor.
    constructor 2; intuition.
  Qed.

  (** ** Decision procedures: *)

  Fixpoint defined_eq (defs: PS.t) (eq: equation) {struct eq} : PS.t :=
    match eq with
    | EqDef x _ _   => PS.add x defs
    | EqApp xs _ _ _ _ => ps_adds xs defs
    | EqFby x _ _ _ => PS.add x defs
    end.

  Definition defined (eqs: list equation) : PS.t :=
    List.fold_left defined_eq eqs PS.empty.

  (** ** Silly unfolding property: *)

  Lemma Subset_defined_eq:
    forall eq m1 m2,
      PS.Subset m1 m2 ->
      PS.Subset (defined_eq m1 eq) (defined_eq m2 eq).
  Proof.
    intros * Hsub.
    destruct eq; simpl.
    - apply PSP.subset_add_3, PSP.subset_add_2; try apply PS.add_spec; auto.
    - now apply Subset_ps_adds.
    - apply PSP.subset_add_3, PSP.subset_add_2; try apply PS.add_spec; auto.
  Qed.

  Lemma In_fold_left_defined_eq:
    forall x eqs m,
      PS.mem x (List.fold_left defined_eq eqs m) = true
      <-> PS.mem x (List.fold_left defined_eq eqs PS.empty) = true \/ PS.In x m.
  Proof.
    induction eqs as [|eq].
    - split; auto.
      destruct 1 as [H|]; auto.
      now apply not_In_empty in H; contradiction.
    - split.
      + intro H.
        simpl; rewrite IHeqs. setoid_rewrite IHeqs in H. clear IHeqs.
        destruct H as [H|H]; auto.
        destruct eq; simpl in *; try rewrite PS.add_spec in *;
          try rewrite ps_adds_spec in *; destruct H; auto.
      + simpl. setoid_rewrite IHeqs.
        destruct 1 as [[H|H]|H]; auto.
        rewrite <-Subset_defined_eq with (m1:=PS.empty);
          auto using PSP.subset_empty.
        right. destruct eq; simpl;
                 try apply PS.add_spec; try apply ps_adds_spec; auto.
  Qed.

  (** ** Reflection lemmas: *)

  Lemma Is_defined_in_eqP :
    forall x eq, Is_defined_in_eq x eq <-> PS.mem x (defined_eq PS.empty eq) = true.
  Proof.
  intros x eq; split; [ intro Hdef | intro Hmem].
  - (* ==> *)
    destruct Hdef; simpl;
    match goal with
    | |- context[ PS.mem ?x (PS.add ?x _) ] =>
      now rewrite PSE.add_mem_1
    | |- context[ PS.mem _ (ps_adds _ _) ] =>
      now apply PS.mem_spec, ps_adds_spec; auto
    end.
  - (* <== *)
    destruct eq; simpl in *;
    match goal with
    | |- context[ EqApp _ _ _ _ _ ] =>
      edestruct (in_dec ident_eq_dec) as [Hin_xys | Hnin_xys];
        [ eauto using Is_defined_in_eq
        | exfalso;
          apply ps_adds_spec in Hmem as [Hmem | Hmem]; auto;
          eapply not_In_empty; eauto ]
    | _ =>
      destruct (ident_eq_dec i x) eqn:Hxi;
        [ subst; auto using Is_defined_in_eq
        | exfalso;
          rewrite PSP.Dec.F.add_neq_b, PSF.empty_b in Hmem; auto;
          discriminate ]
    end.
  Qed.

  Lemma Is_defined_inP:
    forall x eqs,
      Is_defined_in x eqs <-> PS.mem x (defined eqs) = true.
  Proof.
    unfold defined, Is_defined_in.
    induction eqs as [ | eq ].
    - rewrite List.Exists_nil; split; intro H;
      try apply not_In_empty in H; contradiction.
    - simpl;
        rewrite In_fold_left_defined_eq, PS.mem_spec.
      split.
      + (* ==> *)
        intro H; apply List.Exists_cons in H; destruct H.
        inversion H; destruct eq;
          match goal with
          | |- context[ EqApp _ _ _ _ _ ] =>
            generalize ps_adds_spec; intro add_spec
          | _ =>
            generalize PS.add_spec; intro add_spec
          end;
          (right; apply add_spec; intuition).
        left; apply IHeqs; apply H.
      + (* <== *)
        rewrite List.Exists_cons.
        destruct 1.
        * now intuition.
        * destruct eq;
            match goal with
            | |- context[ EqApp _ _ _ _ _ ] =>
              generalize ps_adds_spec; intro add_spec
            | _ =>
              generalize PS.add_spec; intro add_spec
            end;
          (simpl in H; apply add_spec in H; destruct H;
           [ try rewrite H; left; constructor; auto
           | apply not_In_empty in H; contradiction]).

  Qed.

  Lemma Is_defined_in_vars_defined:
    forall x eqs,
      Is_defined_in x eqs
      <-> In x (vars_defined eqs).
  Proof.
    intros; rewrite Is_defined_inP, PS.mem_spec.
    induction eqs as [ | eq eqs IHeqs ]; simpl.
    - now rewrite PSF.empty_iff.
    - destruct eq; rewrite <- PS.mem_spec; unfold defined; simpl.
      + rewrite In_fold_left_defined_eq, PSF.add_iff, PSF.empty_iff, IHeqs; tauto.
      + unfold vars_defined; simpl;
          rewrite in_app, In_fold_left_defined_eq, ps_adds_spec,
          PSF.empty_iff, IHeqs; tauto.
      + rewrite In_fold_left_defined_eq, PSF.add_iff, PSF.empty_iff, IHeqs; tauto.
  Qed.

  Lemma Is_defined_in_eq_dec:
    forall x eq, {Is_defined_in_eq x eq}+{~Is_defined_in_eq x eq}.
  Proof.
    intros;
      eapply Bool.reflect_dec,
             Bool.iff_reflect,
             Is_defined_in_eqP.
  Qed.

  Lemma Is_defined_in_dec:
    forall x eqs, {Is_defined_in x eqs}+{~Is_defined_in x eqs}.
  Proof.
    intros;
      eapply Bool.reflect_dec,
             Bool.iff_reflect,
             Is_defined_inP.
  Qed.

  Lemma decidable_Is_defined_in:
    forall x eqs,
      Decidable.decidable (Is_defined_in x eqs).
  Proof.
    intros. apply decidable_Exists.
    intros eq Hin.
    destruct (Is_defined_in_eq_dec x eq); [left|right]; auto.
  Qed.

  (** ** Properties *)

  Lemma Is_defined_in_var_defined:
    forall x eq,
      Is_defined_in_eq x eq <-> List.In x (var_defined eq).
  Proof.
  intros; rewrite Is_defined_in_eqP, PS.mem_spec.

  destruct eq; simpl;
    rewrite ?PSF.add_iff, ?ps_adds_spec, PSF.empty_iff;
    intuition.
  Qed.

  Lemma Is_defined_in_cons:
    forall x eq eqs,
      Is_defined_in x (eq :: eqs) ->
      Is_defined_in_eq x eq
      \/ (~Is_defined_in_eq x eq /\ Is_defined_in x eqs).
  Proof.
    intros x eq eqs Hdef.
    apply List.Exists_cons in Hdef.
    destruct (Is_defined_in_eq_dec x eq); intuition.
  Qed.

  Lemma In_memory_eq_In_defined_eq:
    forall x eq S,
      PS.In x (memory_eq S eq)
      -> PS.In x (defined_eq S eq).
  Proof.
    intros x eq S HH.
    destruct eq;
      match goal with
      | |- context[ EqApp _ _ _ _ _ ] =>
        generalize ps_adds_spec; intro add_spec
      | _ =>
        generalize PS.add_spec; intro add_spec
      end;
      try (apply add_spec; now intuition).
    apply add_spec in HH.
    destruct HH as [HH|HH].
    - rewrite HH; apply add_spec; left; reflexivity.
    - apply add_spec; right; exact HH.
  Qed.

  Lemma In_fold_left_memory_eq_defined_eq:
    forall x eqs S,
      PS.In x (List.fold_left memory_eq eqs S)
      -> PS.In x (List.fold_left defined_eq eqs S).
  Proof.
    intros x eqs.
    induction eqs as [|eq eqs IH]; [now intuition|].
    intros S HH.
    apply IH in HH; clear IH.
    apply In_fold_left_defined_eq in HH.
    simpl. apply In_fold_left_defined_eq.
    destruct HH as [HH|HH].
    - left; exact HH.
    - right; now apply In_memory_eq_In_defined_eq with (1:=HH).
  Qed.

  Lemma not_Exists_Is_defined_in_n_in:
    forall n, ~Exists (fun ni=>Is_defined_in ni n.(n_eqs)) (map fst n.(n_in)).
  Proof.
    intros n HH.
    rewrite Exists_map in HH.
    apply decidable_Exists_not_Forall in HH.
    2:(intros; apply decidable_Is_defined_in).
    apply HH. clear HH.
    apply Forall_forall.
    intros x Hin.
    rewrite Is_defined_in_vars_defined.
    rewrite n.(n_defd).
    destruct x as [x xty].
    apply In_InMembers in Hin.
    rewrite <-fst_InMembers. simpl.
    apply (NoDupMembers_app_InMembers _ _ _ n.(n_nodup) Hin).
  Qed.

  Lemma Is_defined_in_In:
    forall x eqs,
      Is_defined_in x eqs ->
      exists eq, In eq eqs /\ Is_defined_in_eq x eq.
  Proof.
    induction eqs as [|eq]. now inversion 1.
    inversion_clear 1 as [? ? Hdef|? ? Hex].
    - exists eq; split; auto with datatypes.
    - apply Exists_exists in Hex as (eq' & Hin & Hdef).
      exists eq'; split; auto with datatypes.
  Qed.

  Lemma node_output_defined_in_eqs:
    forall n x,
      In x (map fst n.(n_out)) ->
      Is_defined_in x n.(n_eqs).
  Proof.
    intros n x Ho.
    cut (In x (map fst (n.(n_vars) ++ n.(n_out)))).
    - intro Hvo. rewrite <-n_defd in Hvo.
      now apply Is_defined_in_vars_defined.
    - rewrite map_app. apply in_or_app. now right.
  Qed.

  Lemma node_variable_defined_in_eqs:
    forall n x,
      In x (map fst n.(n_vars)) ->
      Is_defined_in x n.(n_eqs).
  Proof.
    intros n x Ho.
    cut (In x (map fst (n.(n_vars) ++ n.(n_out)))).
    - intro Hvo. rewrite <-n_defd in Hvo.
      now apply Is_defined_in_vars_defined.
    - rewrite map_app. apply in_or_app. now left.
  Qed.

  Lemma vars_defined_cons:
    forall eq eqs x,
      In x (vars_defined (eq :: eqs))
      <-> (Is_defined_in_eq x eq \/ In x (vars_defined eqs)).
  Proof.
    intros.
    destruct eq; simpl; split; intro HH;
      try destruct HH;
      repeat match goal with
             | [ H:Is_defined_in_eq _ _ |- _ ] => now inv H; auto
             | [ H: In _ (_ ++ _) |- _ ] => apply in_app_or in H as [|]
             | |- In _ (_ ++ _) => apply in_or_app
             end;
      subst; auto.
  Qed.

  Lemma Exists_Is_defined_in_eq_vars_defined:
    forall eqs x,
      Exists (Is_defined_in_eq x) eqs <-> In x (vars_defined eqs).
  Proof.
    induction eqs as [|eq eqs IH]. now split; inversion 1.
    setoid_rewrite Exists_cons. setoid_rewrite IH.
    now setoid_rewrite vars_defined_cons.
  Qed.

  Lemma NoDup_vars_defined_cons:
    forall eq eqs,
      NoDup (vars_defined (eq :: eqs)) ->
      NoDup (vars_defined eqs).
  Proof.
    destruct eq; [inversion 1| |inversion 1]; auto.
    simpl. setoid_rewrite NoDup_app'_iff. intuition.
  Qed.

  Lemma NoDup_Is_defined_in:
    forall eq eqs x,
      NoDup (vars_defined (eq :: eqs)) ->
      Is_defined_in x (eq :: eqs) ->
      (Is_defined_in_eq x eq /\ ~Is_defined_in x eqs)
      \/ (~Is_defined_in_eq x eq /\ Is_defined_in x eqs).
  Proof.
    intros eq eqs x ND Def.
    apply Is_defined_in_cons in Def as [Def|]; auto.
    left; destruct eq; inv Def; simpl in *.
    - inv ND; rewrite <-Is_defined_in_vars_defined in *; auto.
    - apply NoDup_app'_iff in ND as (ND1 & ND2 & ND3). split; auto.
      rewrite Forall_forall in ND3.
      setoid_rewrite <-Exists_Is_defined_in_eq_vars_defined in ND3.
      now apply ND3.
    - inv ND; rewrite <-Is_defined_in_vars_defined in *; auto.
  Qed.

  Lemma gather_mems_Is_defined_in:
    forall x eqs,
      In x (gather_mems eqs) ->
      Is_defined_in x eqs.
  Proof.
    induction eqs as [|eq eqs IH]. now inversion 1.
    intro Hin. destruct eq; [| |destruct Hin as [Hin|Hin]]; simpl in *;
                 try (now constructor 2; apply IH).
    subst. now constructor.
  Qed.

  Lemma gather_insts_Is_defined_in:
    forall x eqs,
      InMembers x (gather_insts eqs) ->
      Is_defined_in x eqs.
  Proof.
    induction eqs as [|eq eqs IH]. now inversion 1.
    intro Hin.
    destruct eq; [|destruct l; try destruct Hin as [Hin|Hin]|]; simpl in *;
      try (now constructor 2; apply IH).
    subst. now repeat constructor.
  Qed.

  Lemma gather_mem_eq_Is_defined_in_eq:
    forall eq x,
      In x (gather_mem_eq eq) ->
      Is_defined_in_eq x eq.
  Proof.
    destruct eq; auto; simpl; intros x HH; try contradiction.
    destruct HH; subst; auto. contradiction.
  Qed.

  Lemma gather_inst_eq_Is_defined_in_eq:
    forall eq x,
      InMembers x (gather_inst_eq eq) -> Is_defined_in_eq x eq.
  Proof.
    destruct eq; simpl; try contradiction.
    destruct l. now intuition.
    inversion 1; subst. now repeat constructor.
    match goal with [ H: InMembers _ [] |- _ ] => inversion H end.
  Qed.

  Lemma NoDup_In_gather_mems:
    forall eq eqs x,
      NoDup (vars_defined (eq :: eqs)) ->
      In x (gather_mems (eq :: eqs)) ->
      (In x (gather_mem_eq eq) /\ ~(In x (gather_mems eqs)))
      \/ (~In x (gather_mem_eq eq) /\ In x (gather_mems eqs)).
  Proof.
    intros eq eqs x ND Def.
    simpl in *. apply NoDup_app'_iff in ND as (ND1 & ND2 & ND3).
    assert (forall x, Is_defined_in_eq x eq -> ~Is_defined_in x eqs) as ND4.
    { intros y Dy. apply Is_defined_in_var_defined in Dy.
      rewrite Forall_forall in ND3. apply ND3 in Dy.
      now rewrite Is_defined_in_vars_defined. }
    apply in_app_or in Def as [Def|Def].
    - left; split; auto.
      apply gather_mem_eq_Is_defined_in_eq, ND4 in Def.
      now apply (flip_impl (gather_mems_Is_defined_in _ _)).
    - right; split; auto.
      apply (flip_impl (gather_mem_eq_Is_defined_in_eq _ _)).
      intro D. apply ND4 in D.
      apply gather_mems_Is_defined_in in Def; auto.
  Qed.

  Lemma NoDup_In_gather_insts:
    forall eq eqs x,
      NoDup (vars_defined (eq :: eqs)) ->
      InMembers x (gather_insts (eq :: eqs)) ->
      (InMembers x (gather_inst_eq eq) /\ ~(InMembers x (gather_insts eqs)))
      \/ (~InMembers x (gather_inst_eq eq) /\ InMembers x (gather_insts eqs)).
  Proof.
    intros eq eqs x ND Def.
    simpl in *. apply NoDup_app'_iff in ND as (ND1 & ND2 & ND3).
    assert (forall x, Is_defined_in_eq x eq -> ~Is_defined_in x eqs) as ND4.
    { intros y Dy. apply Is_defined_in_var_defined in Dy.
      rewrite Forall_forall in ND3. apply ND3 in Dy.
      now rewrite Is_defined_in_vars_defined. }
    apply InMembers_app in Def as [Def|Def].
    - left; split; auto.
      apply gather_inst_eq_Is_defined_in_eq, ND4 in Def.
      now apply (flip_impl (gather_insts_Is_defined_in _ _)).
    - right; split; auto.
      apply (flip_impl (gather_inst_eq_Is_defined_in_eq _ _)).
      intro D. apply ND4 in D.
      apply gather_insts_Is_defined_in in Def; auto.
  Qed.

End ISDEFINED.

Module IsDefinedFun
       (Ids     : IDS)
       (Op      : OPERATORS)
       (CESyn   : CESYNTAX     Op)
       (Syn     : NLSYNTAX Ids Op CESyn)
       (Mem     : MEMORIES Ids Op CESyn Syn)
       <: ISDEFINED Ids Op CESyn Syn Mem.
  Include ISDEFINED Ids Op CESyn Syn Mem.
End IsDefinedFun.


Section Props_Confluence.

  Variable R R' : red_rule.

  Hypothesis same_rel : forall e : env, same_relation term (R e) (R' e).
  Hypothesis R_confl : confluent R.

  Lemma confluent_is_ext : confluent R'.
Proof.
unfold confluent, commut, transp in |- *.
intros.
elim same_rel with e.
unfold inclusion in |- *; intros.
elim R_confl with e x y z; auto with pts; intros.
exists x0; auto with pts.
Qed.

  Lemma strip_confl :
   forall e : env, commut term (R_rt R e) (transp term (R e)).
Proof.
unfold commut, transp in |- *.
simple induction 1; intros.
elim R_confl with e y0 x0 z; intros; auto with pts.
exists x1; auto with pts.

exists z; auto with pts.

elim H1 with z0; intros; auto with pts.
elim H3 with x1; intros; auto with pts.
exists x2; auto with pts.
red in |- *.
apply rt_trans with x1; auto with pts.
Qed.

  Lemma strongly_confluent : confluent (R_rt R).
Proof.
unfold confluent, commut, transp in |- *.
simple induction 1; intros.
elim strip_confl with e z x0 y0; intros; auto with pts.
exists x1; auto with pts.

exists z; auto with pts.

elim H1 with z0; intros; auto with pts.
elim H3 with x1; intros; auto with pts.
exists x2; auto with pts.
red in |- *.
apply rt_trans with x1; auto with pts.
Qed.

End Props_Confluence.

Section Props_Church_Rosser.

  Variable R : red_rule.
  Hypothesis Rconfl : confluent (R_rt R).

  Lemma confl_church_rosser : church_rosser R.
Proof.
red in |- *.
simple induction 1; intros.
split with y; auto with pts.

split with x; auto with pts.

inversion_clear H1.
split with x0; trivial.

inversion_clear H1.
inversion_clear H3.
elim Rconfl with (1 := H5) (2 := H1); intros.
split with x2.
red in |- *; apply rt_trans with x0; auto.

red in |- *; apply rt_trans with x1; auto.
Qed.

End Props_Church_Rosser.

Section Tait_Martin_Lof.

  Variable R R' : red_rule.

  Hypothesis R'_confl : confluent R'.
  Hypothesis incl_R_R' : forall e : env, inclusion term (R e) (R' e).
  Hypothesis incl_R'_R_rt : forall e : env, inclusion term (R' e) (R_rt R e).

  Lemma closures_are_equal :
   forall e : env, same_relation term (R_rt R' e) (R_rt R e).
Proof.
unfold same_relation, inclusion, R_rt in |- *.
split.
simple induction 1; intros; auto with pts.
apply (incl_R'_R_rt e x0 y0); auto with pts.

apply rt_trans with y0; auto with pts.

simple induction 1; intros; auto with pts.
apply rt_step.
apply (incl_R_R' e x0 y0); auto with pts.

apply rt_trans with y0; auto with pts.
Qed.

  Lemma confl_closure : confluent (R_rt R).
Proof.
apply confluent_is_ext with (R_rt R').
exact closures_are_equal.

apply strongly_confluent.
trivial with pts.
Qed.

  Lemma TML_Church_rosser : church_rosser R.
Proof.
apply confl_church_rosser.
exact confl_closure.
Qed.

End Tait_Martin_Lof.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2014                                          *)
(*                                                                        *)
(*     Michaël Armand                                                     *)
(*     Benjamin Grégoire                                                  *)
(*     Chantal Keller                                                     *)
(*                                                                        *)
(*     INRIA - École Polytechnique - MSR                                  *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(*** Spl -- a small checker for simplifications ***)

(* Add LoadPath ".." as SMTCoq. *)
(* Add LoadPath "../lia" as SMTCoq.lia. *)
Require Import List PArray Bool Int31 ZMicromega.
Require Import Misc State SMT_terms.
Require Lia.

Local Open Scope array_scope.
Local Open Scope int31_scope.

(* Arbritrary arithmetic simplifications *)

Section Arith.

  Variable t_form : PArray.array Form.form.
  Variable t_atom : PArray.array Atom.atom.

  Local Notation build_clause := (Lia.build_clause t_form t_atom).

  Definition check_spl_arith orig res l :=
    match orig with
      | li::nil =>
        let cl := (Lit.neg li)::res::nil in
        match build_clause Lia.empty_vmap cl with
          | Some (_, bf) =>
            if ZTautoChecker bf l then res::nil
            else C._true
          | None => C._true
        end
      | _ => C._true
    end.

  Section Valid.

    Variables (t_i : array typ_eqb)
              (t_func : array (Atom.tval t_i))
              (ch_atom : Atom.check_atom t_atom)
              (ch_form : Form.check_form t_form)
              (wt_t_atom : Atom.wt t_i t_func t_atom).

    Local Notation interp_form_hatom :=
      (Atom.interp_form_hatom t_i t_func t_atom).
    Local Notation rho :=
      (Form.interp_state_var interp_form_hatom t_form).

    Let wf_rho : Valuation.wf rho.
    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form); auto. Qed.

    Hint Immediate wf_rho.

    Lemma valid_check_spl_arith :
      forall orig, C.valid rho orig ->
        forall res l, C.valid rho (check_spl_arith orig res l).
    Proof.
      unfold check_spl_arith; intros [ |li [ |t q]].
      (* Case nil *)
      intros; apply C.interp_true; auto.
      (* List with one element *)
      intros H res l; case_eq (build_clause Lia.empty_vmap (Lit.neg li :: res :: nil)); [ |intros; apply C.interp_true; auto].
      intros (vm1, bf) Heq; destruct (Lia.build_clause_correct _ _ _ t_func ch_atom ch_form wt_t_atom _ _ _ _ Heq) as [H1 H0].
      red; simpl; auto.
      decompose [and] H0; case_eq (ZTautoChecker bf l); [intros Heq3|intros; apply C.interp_true; auto].
      unfold C.valid; replace (C.interp rho (res :: nil)) with (C.interp rho (Lit.neg li :: res :: nil)).
      rewrite H6; apply ZTautoChecker_sound with l;trivial.
      simpl; replace (Lit.interp rho (Lit.neg li)) with false; auto.
      rewrite Lit.interp_neg; unfold C.valid in H; simpl in H; rewrite orb_false_r in H; rewrite H; auto.
      (* List with at least two elements *)
      intros; apply C.interp_true; auto.
    Qed.

  End Valid.

End Arith.