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.


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.


(* 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.


(*=== 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.