Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import UniMath.RezkCompletion.limits.products.
Require Import UnicodeNotations.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).

Lemma transportf_idpath (A : UU) (B : A -> UU) (a : A) (b : B a)
: transportf _ (idpath a) b = b.
Proof.
  apply idpath.
Defined.

Section Constant_Functor.
Variables C D : precategory.
Variable d : D.

Definition constant_functor_data: functor_data C D :=
   functor_data_constr C D (fun _ => d) (fun _ _ _  => identity _) .

Lemma is_functor_constant: is_functor constant_functor_data.
Proof.
  split; simpl.
  red; intros; apply idpath.
  red; intros; simpl.
  apply pathsinv0.
  apply id_left.
Qed.

Definition constant_functor: functor C D := tpair _ _ is_functor_constant.

End Constant_Functor.

Lemma functor_id_id (A B : precategory) (G : functor A B) (a : A) (f : a ⇒ a)
  : f = identity _ → #G f = identity _ .
Proof.
  intro e.
  rewrite e.
  apply functor_id.
Defined.

Lemma path_to_ctr (A : UU) (B : A -> UU) (isc : iscontr (total2 (fun a => B a)))
           (a : A) (p : B a) : a = pr1 (pr1 isc).
Proof.
  set (Hi := tpair _ a p).
  apply (maponpaths pr1 (pr2 isc Hi)).
Defined.

Lemma dirprodeq (A B : UU) (ab ab' : A × B) :
  pr1 ab = pr1 ab' → pr2 ab = pr2 ab' → ab = ab'.
Proof.
  intros H H'.
  destruct ab as [a b].
  destruct ab' as [a' b']; simpl in *.
  induction H.
  induction H'.
  apply idpath.
Defined.

Lemma is_nat_trans_post_whisker (B C D : precategory)
   (G H : functor B C) (gamma : nat_trans G H) (K : functor C D):
  is_nat_trans (functor_composite _ _ _ G K)
                         (functor_composite _ _ _ H K)
     (fun b : B => #K (gamma b)).
Proof.
  unfold is_nat_trans.
  intros b b' f.
  simpl.
  rewrite <- functor_comp.
  rewrite (nat_trans_ax gamma).
  rewrite functor_comp.
  apply idpath.
Qed.

Definition post_whisker {B C D : precategory} (hsC : has_homsets C) (hsD : has_homsets D)
   (G H: ob [B, C, hsC]) (gamma : G --> H) (I : ob [C, D, hsD])
  : functor_compose _ _ G I --> functor_compose _ _ H I.
Proof.
  exists (fun b : B => #(pr1 I) (pr1 gamma b)).
  apply is_nat_trans_post_whisker.
Defined.

Section nat_trans_eq.

Variables C D : precategory.
Variable hsD : has_homsets D.
Variables F G : functor C D.
Variables alpha beta : nat_trans F G.

Definition nat_trans_eq_weq : weq (alpha = beta) (forall c, alpha c = beta c).
Proof.
  eapply weqcomp.
  - apply total2_paths_isaprop_equiv.
    intro x. apply isaprop_is_nat_trans. apply hsD.
  - apply weqtoforallpaths.
Defined.
End nat_trans_eq.

Section Coproducts.

Variable C : precategory.
Variable CC : Coproducts C.
Variables a b c d x y : C.

Lemma CoproductArrow_eq (f f' : a ⇒ c) (g g' : b ⇒ c)
  : f = f' → g = g' →
      CoproductArrow _ (CC _ _) f g = CoproductArrow _ _ f' g'.
Proof.
  induction 1.
  induction 1.
  apply idpath.
Qed.

Lemma CoproductArrow_eq_cor (f f' : CoproductObject C (CC a b) ⇒ c)
  : CoproductIn1 _ _;; f = CoproductIn1 _ _;; f' → CoproductIn2 _ _;; f = CoproductIn2 _ _;; f' →
      f = f' .
Proof.
  intros Hyp1 Hyp2.
  rewrite (CoproductArrowEta _ _ _ _ _ f).
  rewrite (CoproductArrowEta _ _ _ _ _ f').
  apply CoproductArrow_eq; assumption.
Qed.

(** specialized versions of beta rules for coproducts *)
(* all the following lemmas for manipulation of the hypothesis
Lemma CoproductIn1Commutes_left (f : a ⇒ c)(g : b ⇒ c)(h : a ⇒ c): CoproductIn1 C (CC _ _) ;; CoproductArrow C (CC _ _) f g = h -> f = h.
Proof.
  intro Hyp.
  rewrite CoproductIn1Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn1Commutes_right (f : a ⇒ c)(g : b ⇒ c)(h : a ⇒ c): h = CoproductIn1 C (CC _ _) ;; CoproductArrow C (CC _ _) f g -> h = f.
Proof.
  intro Hyp.
  rewrite CoproductIn1Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn2Commutes_left (f : a ⇒ c)(g : b ⇒ c)(h : b ⇒ c): CoproductIn2 C (CC _ _) ;; CoproductArrow C (CC _ _) f g = h -> g = h.
Proof.
  intro Hyp.
  rewrite CoproductIn2Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn2Commutes_right (f : a ⇒ c)(g : b ⇒ c)(h : b ⇒ c): h = CoproductIn2 C (CC _ _) ;; CoproductArrow C (CC _ _) f g -> h = g.
Proof.
  intro Hyp.
  rewrite CoproductIn2Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn1Commutes_left_in_ctx (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : a ⇒ d): CoproductIn1 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h) = h' -> f ;; h = h'.
Proof.
  intro Hyp.
  rewrite assoc in Hyp.
  rewrite CoproductIn1Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn1Commutes_right_in_ctx (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : a ⇒ d): h' = CoproductIn1 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h)  -> h' = f ;; h.
Proof.
  intro Hyp.
  apply pathsinv0 in Hyp.
  apply pathsinv0.
  exact (CoproductIn1Commutes_left_in_ctx _ _ _ _ Hyp).
Qed.

Lemma CoproductIn2Commutes_left_in_ctx (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : b ⇒ d): CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h) = h' -> g ;; h = h'.
Proof.
  intro Hyp.
  rewrite assoc in Hyp.
  rewrite CoproductIn2Commutes in Hyp.
  exact Hyp.
Qed.

Lemma CoproductIn2Commutes_right_in_ctx (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : b ⇒ d): h' = CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h)  -> h' = g ;; h.
Proof.
  intro Hyp.
  apply pathsinv0 in Hyp.
  apply pathsinv0.
  exact (CoproductIn2Commutes_left_in_ctx _ _ _ _ Hyp).
Qed.

Lemma CoproductIn2Commutes_right_in_double_ctx (g0 : x ⇒ b)(f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : x ⇒ d): h' = g0 ;; CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h)  -> h' = g0 ;; g ;; h.
Proof.
  intro Hyp.
  rewrite Hyp.
  repeat rewrite <- assoc.
  apply maponpaths.
  rewrite assoc.
  rewrite CoproductIn2Commutes.
  apply idpath.
Qed.
*)

(* optimized versions in direct style *)
Lemma CoproductIn1Commutes_right_dir (f : a ⇒ c)(g : b ⇒ c)(h : a ⇒ c): h = f -> h = CoproductIn1 C (CC _ _) ;; CoproductArrow C (CC _ _) f g.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply pathsinv0.
  apply CoproductIn1Commutes.
Qed.

Lemma CoproductIn2Commutes_right_dir (f : a ⇒ c)(g : b ⇒ c)(h : b ⇒ c): h = g -> h = CoproductIn2 C (CC _ _) ;; CoproductArrow C (CC _ _) f g.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply pathsinv0.
  apply CoproductIn2Commutes.
Qed.

Lemma CoproductIn1Commutes_right_in_ctx_dir (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : a ⇒ d): h' = f ;; h -> h' = CoproductIn1 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h).
Proof.
  intro Hyp.
  rewrite Hyp.
  rewrite assoc.
  rewrite CoproductIn1Commutes.
  apply idpath.
Qed.

Lemma CoproductIn2Commutes_right_in_ctx_dir (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : b ⇒ d): h' = g ;; h -> h' = CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h).
Proof.
  intro Hyp.
  rewrite Hyp.
  rewrite assoc.
  rewrite CoproductIn2Commutes.
  apply idpath.
Qed.

Lemma CoproductIn1Commutes_left_dir (f : a ⇒ c)(g : b ⇒ c)(h : a ⇒ c): f = h -> CoproductIn1 C (CC _ _) ;; CoproductArrow C (CC _ _) f g = h.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply CoproductIn1Commutes.
Qed.

Lemma CoproductIn2Commutes_left_dir (f : a ⇒ c)(g : b ⇒ c)(h : b ⇒ c): g = h -> CoproductIn2 C (CC _ _) ;; CoproductArrow C (CC _ _) f g = h.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply CoproductIn2Commutes.
Qed.

Lemma CoproductIn1Commutes_left_in_ctx_dir (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : a ⇒ d): f ;; h = h' -> CoproductIn1 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h) = h'.
Proof.
  intro Hyp.
  rewrite <- Hyp.
  rewrite assoc.
  rewrite CoproductIn1Commutes.
  apply idpath.
Qed.

Lemma CoproductIn2Commutes_left_in_ctx_dir (f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : b ⇒ d): g ;; h = h' -> CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h) = h'.
Proof.
  intro Hyp.
  rewrite <- Hyp.
  rewrite assoc.
  rewrite CoproductIn2Commutes.
  apply idpath.
Qed.

Lemma CoproductIn1Commutes_right_in_double_ctx_dir (g0 : x ⇒ a)(f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : x ⇒ d): h' = g0 ;; f ;; h -> h' = g0 ;; CoproductIn1 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h).
Proof.
  intro Hyp.
  rewrite Hyp.
  repeat rewrite <- assoc.
  apply maponpaths.
  rewrite assoc.
  rewrite CoproductIn1Commutes.
  apply idpath.
Qed.

Lemma CoproductIn2Commutes_right_in_double_ctx_dir (g0 : x ⇒ b)(f : a ⇒ c)(g : b ⇒ c)(h : c ⇒ d)(h' : x ⇒ d): h' = g0 ;; g ;; h -> h' = g0 ;; CoproductIn2 C (CC _ _) ;; (CoproductArrow C (CC _ _) f g ;; h).
Proof.
  intro Hyp.
  rewrite Hyp.
  repeat rewrite <- assoc.
  apply maponpaths.
  rewrite assoc.
  rewrite CoproductIn2Commutes.
  apply idpath.
Qed.
(** end of specialized versions of the beta laws for coproducts *)

(* do we ever want to create a multitude of similar lemmas for other rewrite rules?
Lemma id_left_to_the_right (C': precategory)(a b : C')(f h : C' ⟦ a, b ⟧): h = f -> h = identity a;; f.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply pathsinv0, id_left.
Qed.

Lemma id_left_to_the_right_in_ctx (C': precategory)(a b c: C')(f : C' ⟦ a, b ⟧)(g : C' ⟦ b, c ⟧)(h : C' ⟦ a, c ⟧): h = f ;; g -> h = identity a ;; f ;; g.
Proof.
  intro Hyp.
  rewrite Hyp.
  rewrite id_left.
  apply idpath.
Qed.

Lemma assoc_to_the_right (C' : precategory) (a b c d : C') (f : C' ⟦ a, b ⟧)
       (g : C' ⟦ b, c ⟧) (h : C' ⟦ c, d ⟧)(res: C' ⟦ a, d ⟧) : res = f;; g;; h -> res = f;; (g;; h).
Proof.
  intro Hyp.
  rewrite Hyp.
  apply pathsinv0, assoc.
Qed.

Lemma assoc_back_to_the_right (C' : precategory) (a b c d : C') (f : C' ⟦ a, b ⟧)
       (g : C' ⟦ b, c ⟧) (h : C' ⟦ c, d ⟧)(res: C' ⟦ a, d ⟧) : res = f;; (g;; h) -> res = f;; g;; h.
Proof.
  intro Hyp.
  rewrite Hyp.
  apply assoc.
Qed.
*)

Definition CoproductOfArrows_comp (f : a ⇒ c) (f' : b ⇒ d) (g : c ⇒ x) (g' : d ⇒ y)
  : CoproductOfArrows _ (CC a b) (CC c d) f f' ;;
    CoproductOfArrows _ (CC _ _) (CC _ _) g g'
    =
    CoproductOfArrows _ (CC _ _) (CC _ _)(f ;; g) (f' ;; g').
Proof.
  apply CoproductArrowUnique.
  - rewrite assoc.
    rewrite CoproductOfArrowsIn1.
    rewrite <- assoc.
    rewrite CoproductOfArrowsIn1.
    apply assoc.
  - rewrite assoc.
    rewrite CoproductOfArrowsIn2.
    rewrite <- assoc.
    rewrite CoproductOfArrowsIn2.
    apply assoc.
Qed.

Definition CoproductOfArrows_eq (f f' : a ⇒ c) (g g' : b ⇒ d)
  : f = f' → g = g' →
      CoproductOfArrows _ _ _ f g = CoproductOfArrows _ (CC _ _) (CC _ _) f' g'.
Proof.
  induction 1.
  induction 1.
  apply idpath.
Qed.

Lemma precompWithCoproductArrow_eq  (CCab : CoproductCocone _ a b)
    (CCcd : CoproductCocone _ c d) (f : a ⇒ c) (g : b ⇒ d)
     (k : c ⇒ x) (h : d ⇒ x) (fk : a ⇒ x) (gh : b ⇒ x):
      fk = f ;; k → gh = g ;; h →
        CoproductOfArrows _ CCab CCcd f g ;; CoproductArrow _ CCcd k h =
         CoproductArrow _ CCab (fk) (gh).
Proof.
  intros H H'.
  rewrite H.
  rewrite H'.
  apply precompWithCoproductArrow.
Qed.

End Coproducts.

Section Products.

Variable C : precategory.
Variable CC : Products C.
Variables a b c d x y : C.

Definition ProductOfArrows_comp (f : a ⇒ c) (f' : b ⇒ d) (g : c ⇒ x) (g' : d ⇒ y)
  : ProductOfArrows _ (CC c d) (CC a b) f f' ;;
    ProductOfArrows _ (CC _ _) (CC _ _) g g'
    =
    ProductOfArrows _ (CC _ _) (CC _ _)(f ;; g) (f' ;; g').
Proof.
  apply ProductArrowUnique.
  - rewrite <- assoc.
    rewrite ProductOfArrowsPr1.
    rewrite assoc.
    rewrite ProductOfArrowsPr1.
    apply pathsinv0.
    apply assoc.
  - rewrite <- assoc.
    rewrite ProductOfArrowsPr2.
    rewrite assoc.
    rewrite ProductOfArrowsPr2.
    apply pathsinv0.
    apply assoc.
Qed.

Definition ProductOfArrows_eq (f f' : a ⇒ c) (g g' : b ⇒ d)
  : f = f' → g = g' →
      ProductOfArrows _ _ _ f g = ProductOfArrows _ (CC _ _) (CC _ _) f' g'.
Proof.
  induction 1.
  induction 1.
  apply idpath.
Qed.

End Products.

Section Product_unique.

Variable C : precategory.
Variable CC : Products C.
Variables a b : C.

Lemma Product_endo_is_identity (P : ProductCone _ a b)
  (k : ProductObject _ P ⇒ ProductObject _ P)
  (H1 : k ;; ProductPr1 _ P = ProductPr1 _ P)
  (H2 : k ;; ProductPr2 _ P = ProductPr2 _ P)
  : identity _ = k.
Proof.
  apply pathsinv0.
  eapply pathscomp0.
  apply ProductArrowEta.
  apply pathsinv0.
  apply ProductArrowUnique; apply pathsinv0.
  + rewrite id_left. exact H1.
  + rewrite id_left. exact H2.
Qed.

End Product_unique.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


(** * Main definitions to be used in the rest of the formalization. *)
Require Export syntax sos.
Require Export Classes.RelationClasses.

(** A simple notation for relations over terms of type [st]. *)

Notation "'Env'" := StR.

(** Definitions to combine relations over states. These definitions will be needed for specifying the logical properties for the deductive system. *)

Section RelationCombinators.

  Definition rstOr (R G:StR) : StR :=
    fun s s' => R s s' \/ G s s'.

  Definition rstAnd (R G:StR) : StR :=
    fun s s' => R s s' /\ G s s'.

  Definition rstImp (R G:StR) : Prop :=
    forall s s', R s s' -> G s s'.

  Definition rstComp (R G:StR) :=
    fun s s'' =>
      exists s', R s s' /\ G s' s''.

  Lemma rstOr_refl :
    forall (R1 R2 R3:StR),
      Reflexive R1 ->
      Reflexive R2 ->
      rstImp (rstOr R1 R2) R3 ->
      Reflexive R3.
  Proof.
    intros.
    red.
    intro.
    apply H1.
    left;auto.
  Qed.

End RelationCombinators.

Infix "<{∪}>" := rstOr(at level 45).
Infix "<{∩}>" := rstAnd(at level 45).
Infix "<{⊆}>" := rstImp(at level 45).
Infix "<{⊙}>" := rstComp(at level 45).

(** * Stability conditions *)

Section Stability.

  (* The environment performs a change in the state but this change does not
     interferes with validity of the predicate given as argument. *)

  Definition stable (R:Env)(P:assrt) :=
    forall x y, P x /\ R x y -> P y.

  (** Stability extends to [n] compositions and to the closure of [R]. *)

  Lemma stable_starn :
    forall n R P,
      stable R P ->
      stable (starn _ R n) P.
  Proof.
    induction n.
    intros.
    red.
    intros.
    destruct H0.
    inv H1.
    intros.
    red;intros.
    destruct H0.
    inv H1.
    generalize H;intro.
    apply IHn with R P in H.
    red in H.
    assert(P y0).
    eapply H2;eauto.
    apply (H y0 y (conj H5 H4)).
  Qed.

  (** Trivially, if we know that for all [n] the stability condition
  is true, then it is also true for the reflexive-transitive closure. *)

  Lemma stable_star :
    forall R P,
      stable R P ->
      stable (star _ R) P.
  Proof.
    red;intros.
    destruct H0.
    apply star2starn in H1.
    destruct H1 as [n H1].
    eapply stable_starn;eauto.
  Qed.

  Lemma stable_and :
    forall R1 R2 P,
      stable R1 P ->
      stable R2 P -> stable (rstAnd R1 R2) P.
  Proof.
    intros.
    red;intros.
    destruct H1.
    destruct H2.
    red in H;specialize H with x y.
    eapply H;auto.
  Qed.

  Lemma stable_impl :
    forall R1 R2 P,
      stable R2 P ->
      rstImp R1 R2 ->
      stable R1 P.
  Proof.
    intros;red;intros.
    destruct H1.
    eapply H.
    split;eauto.
  Qed.

End Stability.

(** Notion of one-step and several step reduction(s) of a
    program under possible intereference. *)

Section Reductions.

  (** Interference: When the environment interferes, it just changes
  the state but does not alter the body of the program being
  executed. *)

  Definition interf R :=
    fun x y:(stmt*st) =>
      (fst x) = (fst y) /\ R (snd x)  (snd y).

  (** Transition under possible interference: Either the program
  reduces, or the environment interferes. *)

  Definition prog_red R :=
    fun x y => x ⇒ y \/ interf R x y.

  (** Finitely many reductions under interference: n steps of
  execution under interference. *)

  Definition prog_red_n (n:nat) R :=
    fun x y => starn (stmt*st) (prog_red R) n x y.

  Definition prog_red_star R :=
    fun x y => star (stmt*st) (prog_red R) x y.

End Reductions.

Infix "-( R )->" := (interf R)(at level 50).
Notation "x -( R )⋆-> y" := (star (stmt*st) (prog_red R) x y)(at level 45).
Notation "x -( R )^( n )-> y" := (starn (stmt*st) (prog_red R) n x y)(at level 45).

Lemma star_n_impl :
  forall n R R' x y,
    rstImp R R' ->
    x -(R)^(n)-> y -> x -(R')^(n)-> y.
Proof.
  induction n;intros.
  inv H0.
  constructor.
  inv H0.
  destruct H2.
  constructor 2 with y0.
  left;auto.
  eapply IHn;eauto.
  destruct H1.
  destruct x;destruct y0.
  simpl in *.
  subst.
  constructor 2 with (s1,s2).
  right;split;auto.
  eapply IHn;eauto.
Qed.

Lemma star_impl_rely :
  forall R R' x y,
    rstImp R R' -> x -(R)⋆-> y -> x -(R')⋆-> y.
Proof.
  induction 2;intros.
  constructor.
  destruct H0.
  constructor 2 with y.
  left;auto.
  assumption.
  constructor 2 with y.
  right.
  red in H0.
  red.
  destruct H0;split;eauto.
  assumption.
Qed.

Lemma rstAnd_split :
  forall R1 R2:StR,
  forall x y, star _ (prog_red (rstAnd R1 R2)) x y ->
              star _ (prog_red R1) x y /\ star _ (prog_red R2) x y.
Proof.
  induction 1.  split;auto.  destruct IHstar.  split.
  destruct H.  constructor 2 with y.  left;auto.  assumption.
  destruct H.  destruct H3.  constructor 2 with y.  right.
  destruct x;destruct y.  split;auto.  assumption.
  destruct H.
  econstructor 2 with y.
  left;auto.
  assumption.
  destruct H.
  destruct x;destruct y.
  constructor 2 with (s1,s2).
  destruct H3.
  right;split;auto.
  assumption.
Qed.

(** Definition the guarantee condition. It should specify the following behavior:
     - all the program reductions [(c,x) =c=> (c',x')] must satisfy a given
       guarantee relation [G], i.e., if [(c,x) =c=> (c',x')] then [G x x'].
 *)

Definition within (R G:StR)(c:stmt)(s:st) :=
  forall y c' , star _ (prog_red R) (c,s) (c',y) ->
                forall c'' z, (c',y) ⇒ (c'',z) -> G y z.

Definition within_n(R G:StR)(c:stmt)(s:st)(n:nat) :=
  forall y c' , starn _ (prog_red R) n (c,s) (c',y) ->
                forall c'' z, (c',y) ⇒ (c'',z) -> G y z.

Lemma all_within_n :
  forall R G c s,
    (forall n, within_n R G c s n) -> within R G c s.
Proof.
  intros.
  red;intros.
  do_star2starn H0.
  apply H in H0.
  eapply H0;auto.
  apply H1.
Qed.

(** Simple syntactical notation for the notion of within. *)

Notation "<< R , G , c , x >>" := (within R G c x)(at level 0).
Notation "<< R , G , c , x [ n ]>>" := (within_n R G c x n)(at level 0).

(** Notion of Hoare validity. *)

Section HoareValidity.

  Definition HG (P:assrt)(c:stmt)(Q:assrt) :=
    forall x,
      P x -> forall s', star _ step (c,x) (skip,s') -> Q s'.

  Definition HG_val (R G:Env)(P:assrt)(c:stmt)(Q:assrt) :=
    forall x,
      P x ->
      (forall s', star _ (prog_red R) (c,x) (skip,s') ->  Q s')
        /\ within R G c x.

  Definition HG_val' (R G:Env)(P:assrt)(c:stmt)(Q:assrt) :=
    forall x,
      P x ->
      (forall s', star _ (prog_red R) (c,x) (skip,s') ->  Q s')
        /\ (forall s', star _ (prog_red R) (c,x) (skip,s') ->  within R G c x).

  Definition G_val (P:assrt)(c:stmt)(G:StR)(Q:assrt) :=
    forall x,
      P x ->
      (forall s', star _ (prog_red ID) (c,x) (skip,s') ->  Q s' /\ star _ G x s').

End HoareValidity.


Set Implicit Arguments.
Require Import RelationClasses Morphisms Init.Wf List Lia Init.Nat Setoid.
From Undecidability.HOU Require Import calculus.calculus unification.unification.
From Undecidability.HOU.second_order Require Export diophantine_equations goldfarb.encoding goldfarb.multiplication.
Import ListNotations ArsInstances.

(* ** Equivalences *)
Section EquationEquivalences.

  Variable (sigma: fin -> exp ag).
  Hypothesis (N: forall x, normal (sigma x)).

  Section Variables.
    Lemma forward_vars x n: encodes (sigma (F x)) n -> sigma • fst (varEQ x) ≡ sigma • snd (varEQ x).
    Proof.
      intros H. unfold varEQ; cbn; unfold funcomp.
      change shift with (add 1); rewrite ren_plus_combine, !H; cbn; unfold var_zero.
      change (g a (var 1)) with (enc 1 (var 1)); now simplify.
    Qed.

    Lemma backward_vars x: sigma • fst (varEQ x) ≡ sigma • snd (varEQ x) -> exists n, encodes (sigma (F x)) n.
    Proof using N.
      cbn; simplify.
      unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
      intros H; eapply normal_forms_encodes in H; (eauto 2).
    Qed.

  End Variables.

  Section Constants.
      Variable (n: nat) (x: nat).
      Hypothesis (Ex: encodes (sigma (F x)) n).

      Lemma forward_consts: n = 1 -> sigma • fst (constEQ x) ≡ sigma • snd (constEQ x).
      Proof using Ex.
        cbn; unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
        rewrite Ex; asimpl; now intros ->.
      Qed.

      Lemma backward_consts:  sigma • fst (constEQ x) ≡ sigma • snd (constEQ x) -> n = 1.
      Proof using Ex.
        cbn.
        unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
        rewrite Ex. asimpl. intros ? % equiv_lam_elim % equiv_lam_elim.
        eapply enc_injective;[| |eauto]; (eauto 2).
      Qed.

  End Constants.

  Section Addition.
    Variable (m n p: nat) (x y z: nat).
    Hypothesis (Ex: encodes (sigma (F x)) m) (Ey: encodes (sigma (F y)) n) (Ez: encodes (sigma (F z)) p).

    Lemma forward_add: m + n = p -> sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z).
    Proof using Ex Ey Ez.
      intros <-; cbn.
      unfold funcomp; change shift with (add 1); rewrite !ren_plus_combine; unfold var_zero; cbn.
      erewrite Ex, Ey, Ez; now simplify.
    Qed.

    Lemma backward_add:
      sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z) -> m + n = p.
    Proof using Ex Ey Ez.
      cbn.
      unfold funcomp; change shift with (add 1); rewrite !ren_plus_combine; unfold var_zero; cbn.
      rewrite Ex, Ey, Ez; simplify; intros H % equiv_lam_elim % equiv_lam_elim.
      rewrite <-enc_app in H.
      eapply enc_injective;[| |eauto]; (eauto 2).
    Qed.

  End Addition.

  (* *** Multiplication *)
  Section Multiplication.

    Variable (m n p: nat) (x y z: nat).
    Hypothesis
      (Ex: encodes (sigma (F x)) m) (Ey: encodes (sigma (F y)) n) (Ez: encodes (sigma (F z)) p).

    Lemma forward_mul:
        m * n = p -> sigma (G x y z) = T n m -> sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z).
    Proof using Ex Ey Ez.
      intros H1 H2. unfold mulEQ; cbn. unfold funcomp.
      rewrite H2. change shift with (add 1); rewrite !ren_plus_combine; cbn [plus].
      rewrite Ex, Ey, Ez. subst p. eapply G_forward.
    Qed.

    Lemma backward_mult:
      sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z) -> m * n = p /\ sigma (G x y z) = T n m.
    Proof using N Ex Ey Ez.
      unfold mulEQ; cbn. unfold funcomp.
      change shift with (add 1); rewrite !ren_plus_combine; cbn [plus].
      rewrite Ex, Ey, Ez. intros H. apply G_iff in H; (eauto 2).
    Qed.

  End Multiplication.

End EquationEquivalences.

(* ** Forward Direction **)
Section Forward.

  Variables (E: list deq).

  Definition gf n := lambda enc n (var 0).

  Lemma tab_typing {X} n (f: nat -> exp X) g k Gamma:
    (forall i, Gamma ⊢(n) f i : g i) -> Gamma ⊢₊(n) tab f k : tab g k.
  Proof.
    intros; induction k; cbn; (eauto 2).
    eapply orderlisttyping_app; (eauto 2).
  Qed.

  Lemma gf_typing Gamma n: Gamma ⊢(2) gf n : alpha → alpha.
  Proof.
    econstructor. eapply enc_typing. eauto.
  Qed.

  Lemma GT_typing Gamma m n: Gamma ⊢(2) T n m : alpha → alpha → alpha → alpha.
  Proof.
    do 3 econstructor. eapply lin_typing; [|eauto].
    rewrite repeated_tab. simplify.
    eapply tab_typing.
    intros; econstructor; cbn. econstructor.
    all: eauto using enc_typing.
  Qed.

  Definition enc_sol (sigma: nat -> nat) (x: fin) :=
    match partition_F_G x with
    | inl (exist _ x _) => gf (sigma x)
    | inr (exist _ (x,y,z) _) => T (sigma y) (sigma x)
    end.

  Lemma enc_sol_encodes theta h: encodes (enc_sol theta (F h)) (theta h).
  Proof.
    unfold enc_sol.
    destruct partition_F_G as [[x ?]|[((x,y),z) ?]].
    - eapply F_injective in e as ->.
      intros t delta. unfold gf. cbn; rewrite stepBeta; asimpl; (eauto 2).
    - exfalso; eapply disjoint_F_G; (eauto 2).
  Qed.

  Lemma enc_sol_T theta x y z: (enc_sol theta (G x y z)) = T (theta y) (theta x).
  Proof.
    unfold enc_sol.
    destruct partition_F_G as [[x' ?]|[((x',y'),z') ?]].
    - exfalso; eapply disjoint_F_G; (eauto 2).
    - now eapply G_injective in y0 as (-> & -> & ->).
  Qed.

  Lemma typing_forward sigma:
    (sigma ⊢⁺ₑ E) -> [] ⊩(2) enc_sol sigma : Gamma__deq E.
  Proof.
    eauto; intros ????; unfold enc_sol.
    destruct partition_F_G as [[]|[((x & y) & z) ?]]; subst.
    + eapply nth_Gamma__deq_F in H0 as ->. eapply gf_typing.
    + eapply nth_Gamma__deq_G in H0 as ->. eapply GT_typing.
  Qed.

  Lemma H10_SU: H10 E -> SOU ag 2 (H10_to_SOU  E).
  Proof.
    intros [sigma H].
    exists []. exists (enc_sol sigma).
    split. now eapply typing_forward.
    intros s t; change s with (fst (s,t)) at 2; change t with (snd (s,t)) at 3.
    remember (s,t) as e. clear Heqe s t.
    intros H'; cbn in *. eapply in_Equations in H' as (d & ? & ?).
      destruct d; cbn in *; intuition idtac; subst.
      all: try eapply forward_add. all: try eapply forward_consts.
      all: try eapply forward_mul.
      all: try eapply forward_vars.
      all: try eapply enc_sol_encodes.
      all: eapply H in H0; inv H0; (eauto 2).
      apply enc_sol_T.
    Qed.

End Forward.

(* ** Backward Direction **)
Section Backward.

  Definition decode_subst (sigma: fin -> exp ag) (N: forall x, normal (sigma x)) (x: fin) :=
    match dec_enc (N (F x)) with
    | inl  (exist _ n _) => n
    | inr _ => 0
    end.

  Lemma decode_subst_encodes (sigma: fin -> exp ag) N x n:
    encodes (sigma (F x)) n -> decode_subst sigma N x = n.
  Proof.
    intros H; unfold decode_subst.
    destruct dec_enc as [[m H1]|H1].
    - specialize (H a id); asimpl in H. rewrite H in H1. eapply enc_injective in H1 as []; (eauto 2).
    - exfalso. eapply H1. exists n. specialize (H a id); asimpl in H. now rewrite H.
  Qed.

  Lemma SU_H10 E: SOU ag 2 (H10_to_SOU E) -> H10 E.
  Proof.
    rewrite SOU_NSOU; (eauto 2). intros (Delta & sigma & T & EQ & N).
    exists (decode_subst sigma N). intros e H; pose (Q := eqs e).
    assert (forall p, p ∈ Q -> sigma • fst p ≡ sigma • snd p) as EQs; [|clear EQ].
    - intros [s t] G. eapply EQ.
      eapply in_Equations. eauto.
    - destruct e; econstructor; cbn in Q, EQs.
      all: specialize (EQs (varEQ x)) as EQx; mp EQx; intuition idtac; eapply backward_vars in EQx as [n EQx]; (eauto 2).
      2 - 3: specialize (EQs (varEQ y)) as EQy; mp EQy; intuition idtac; eapply backward_vars in EQy as [m EQy]; (eauto 2).
      2 - 3: specialize (EQs (varEQ z)) as EQz; mp EQz; intuition idtac; eapply backward_vars in EQz as [p EQz]; (eauto 2).
      all: repeat (erewrite decode_subst_encodes;[|eauto]).
      + eapply backward_consts; (eauto 4).
      + eapply backward_add; (eauto 1); eapply EQs; (eauto 5).
      + eapply backward_mult; (eauto 1); eapply EQs; intuition idtac.
  Qed.
End Backward.

Lemma Goldfarb': H10 ⪯ SOU ag 2.
Proof.
  exists H10_to_SOU; intros x; split.
  - eapply H10_SU.
  - eapply SU_H10.
Qed.

Definition nileq: eq ag := (lambda lambda a, lambda lambda a).
Definition conseqs e1 e2 :=
  match e1, e2 with
  | (lambda lambda s1, lambda lambda t1), (lambda lambda s2, lambda lambda t2) => (lambda lambda g s1 s2, lambda lambda g t1 t2)
  | _, _ => nileq
  end.

Notation foldeqs := (fold_right conseqs nileq).

Lemma conseqs_combine sigma s1 s2 t1 t2:
  sigma • (lambda lambda s1) ≡ sigma • (lambda lambda t1) /\ sigma • (lambda lambda s2) ≡ sigma • (lambda lambda t2) <-> sigma • (lambda lambda g s1 s2) ≡ sigma • (lambda lambda g t1 t2).
Proof.
  cbn; split.
  - intros [H1 H2]; do 2 (eapply equiv_lam_elim in H1; eapply equiv_lam_elim in H2). now rewrite H1, H2.
  - intros H1; do 2 eapply equiv_lam_elim in H1. Injection H1. Injection H. now rewrite H0, H2.
Qed.

Lemma foldeqs_lambda_lambda E:
  exists s t, foldeqs E = (lambda lambda s, lambda lambda t).
Proof.
  induction E as [|[s t]]; cbn; (eauto 2).
  - do 2 eexists; reflexivity.
  - destruct IHE as (s'&t'&IH).
    do 2 (destruct s; try solve [do 2 eexists; reflexivity]).
    do 2 (destruct t; try solve [do 2 eexists; reflexivity]).
    rewrite IH; do 2 eexists; reflexivity.
Qed.

Lemma foldeqs_correct sigma E:
  (forall s1 s2, (s1, s2) ∈ E -> (exists t, s1 = lambda lambda t) /\ (exists t, s2 = lambda lambda t)) ->
  (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) <->
  (sigma • fst (foldeqs E) ≡ sigma • snd (foldeqs E)).
Proof.
  induction E as [| [s t]]; simplify.
  - cbn; firstorder.
  - intros H. apply id in H as H'. specialize (H' s t) as ([t1 H1]&[t2 H2]); lauto; subst.
    cbn. specialize (foldeqs_lambda_lambda E) as (u&v&H'); rewrite H' in *.
    mp IHE; (eauto 2). intros; eapply H; firstorder. cbn in IHE.
    cbn; unfold left_side, right_side in *.
    split; [intros [H1 H2] % equiv_lstep_cons_inv| intros H1]; do 2 eapply equiv_lam_elim in H1.
    + destruct IHE as [IHE _]; rewrite H1; mp IHE; (eauto 1);
        do 2 eapply equiv_lam_elim in IHE; now rewrite IHE.
    + Injection H1. Injection H0. rewrite H3.
      destruct IHE as [_ ->]; (eauto 2). now rewrite H2.
Qed.

Lemma foldeqs_typing Gamma E:
  Gamma ⊢₊₊(2) E : repeat (alpha → alpha → alpha) (length E) -> Gamma ⊢₂(2) (foldeqs E) : alpha → alpha → alpha.
Proof.
  remember (repeat (alpha → alpha → alpha) (| E |)) as L. induction 1 in HeqL |- *; cbn.
  - repeat econstructor.
  - do 2 (destruct s; try solve [repeat econstructor]).
    do 2 (destruct t; try solve [repeat econstructor]).
    specialize (foldeqs_lambda_lambda E) as (u&v&H'); rewrite H' in *.
    cbn in HeqL. injection HeqL as -> ->. mp IHeqs_ordertyping; (eauto 2).
    inv H0. inv H4. inv H. inv H4. destruct IHeqs_ordertyping as [T1 T2]. inv T1. inv H4.
    inv T2. inv H4. repeat econstructor; (eauto 2).
Qed.

Lemma Goldfarb : H10 ⪯ OU 2 ag.
Proof.
  unshelve eexists.
  - intros E. unshelve econstructor.
    exact (Gamma__deq E). 1: eapply fst. 2: eapply snd.
    1 - 2: eapply foldeqs, (H10_to_SOU E).
    exact (alpha → alpha → alpha).
    all: eapply foldeqs_typing; cbn -[Gamma__deq].
    all: eapply H10_to_SOU.
  - intros E. split.
    + intros H % H10_SU. destruct H as (Delta & sigma & H1 & H2).
      exists Delta. exists sigma. intuition idtac. eapply foldeqs_correct, equiv_pointwise_eqs; (eauto 2).
      cbn. intros s1 s2 (d&H3&H4) % in_flat_map.
      destruct d; cbn in H4; intuition idtac.
      all: change s1 with (fst (s1, s2)); rewrite <-?H, <-?H0.
      all: change s2 with (snd (s1, s2)); rewrite <-?H, <-?H0.
      all: cbn; (eauto 2).
    + intros (Delta & sigma & T & EQ). eapply SU_H10. exists Delta, sigma.
      intuition idtac.  eapply equiv_eqs_pointwise; (eauto 1); eapply foldeqs_correct; (eauto 2).
      cbn. intros s1 s2 (d&H3&H4) % in_flat_map.
      destruct d; cbn in H4; intuition idtac.
      all: change s1 with (fst (s1, s2)); rewrite <-?H1, <-?H0.
      all: change s2 with (snd (s1, s2)); rewrite <-?H1, <-?H0.
      all: cbn; (eauto 2).
Qed.


From Coq Require Import Arith.PeanoNat.
From Domains Require Import Preamble Preorder Poset Dcpo.

(** The "upper naturals" *)

Definition UNat : Type :=
  {P : nat → Prop | ∀ m n : nat, m <= n → P m → P n}.

Definition UNat_defd : UNat → Prop :=
  λ x, ∃ k, sval x k.

Definition UNat_lt (M N : UNat) :=
  ∀ x, sval M x → sval N x.

Lemma UNat_ltR : ∀ x, UNat_lt x x.
Proof. by move=>?. Qed.

Lemma UNat_ltT : ∀ x y z, UNat_lt x y → UNat_lt y z → UNat_lt x z.
Proof. by move=> x y z xy yz u xu; apply/yz/xy. Qed.

HB.instance Definition UNat_preorder_axioms := PreorderOfType.Build UNat UNat_lt UNat_ltR UNat_ltT.

Lemma UNat_ltE : ∀ x y : UNat, (x ≤ y) → (y ≤ x) → x = y.
Proof.
  move=>x y xy yz.
  apply: eq_sig=>//.
  apply: funext=>k.
  by apply: propext; split; [apply: xy | apply: yz].
Qed.

HB.instance Definition UNat_poset_axioms := PosetOfPreorder.Build UNat UNat_ltE.

Definition UNat_dsum (x : UNat) (y : ∀ u, sval x u → UNat) : UNat.
Proof.
  unshelve esplit.
  - move=> k.
    by exact: (∃ u v (h : sval x u), sval (y u h) v ∧ u <= k ∧ v <= k).
  - abstract
     (by move=> m n mn /= [u][v][hu][hv][um vm];
      exists u, v, hu; do!split=>//; apply: (Nat.le_trans _ m)).
Defined.

Definition UNat_exists (I : Type) (y : I → UNat) : UNat.
Proof.
  unshelve esplit.
  - move=> k.
    by exact: (∃ x, sval (y x) k).
  - abstract
      (by move=> m n mn /= [x hx];
       exists x; apply: (proj2_sig (y x) m)).
Defined.

Lemma UNat_exists_is_lub : ∀ (A : Family UNat), is_lub A (UNat_exists _ A).
  move=> A; split=>/=.
  - by move=>i; move=>?; exists i.
  - move=> z zub; move=> x [i hxi].
    by apply: (zub i x).
Qed.

Lemma UNat_ltHasDLubs : ∀ (A : Family UNat), is_directed A → ∃ x, is_lub A x.
Proof.
  move=> A dir //=.
  exists (UNat_exists _ A).
  by apply: UNat_exists_is_lub.
Qed.

HB.instance Definition UNat_dcpo_axioms := DcpoOfPoset.Build UNat UNat_ltHasDLubs.

Definition UNat_bot : UNat.
Proof. by exists (λ _, False). Defined.

Lemma UNat_bot_is_bot : is_bottom UNat_bot.
Proof. by move=> ?. Qed.

Lemma UNat_ltHasBot : ∃ x : UNat, is_bottom x.
Proof. by exists UNat_bot; apply: UNat_bot_is_bot. Qed.

Lemma UNat_ltHasTop : ∃ x : UNat, is_top x.
Proof.
  by unshelve esplit; first by exists (λ _, True).
Qed.

HB.instance Definition UNat_pointed_poset_axioms :=
  PointedPosetOfPoset.Build UNat UNat_ltHasBot.

HB.instance Definition UNat_bounded_poset_axioms :=
  BoundedPosetOfPointedPoset.Build UNat UNat_ltHasTop.

Lemma UNat_lub_intro (A : Family UNat): ∀ u k ϕ, is_lub A ϕ → sval (A u) k → sval ϕ k.
Proof. by move=>????; apply: (lub_is_ub A). Qed.

Lemma UNat_lub_elim {P : UNat} {Q : nat → Prop} {A} (H : is_lub A P) : (∀ i k (z : sval (A i) k), Q k) → ∀ x (w : sval P x), Q x.
Proof.
  move=> J K.
  rewrite -(lub_unique _ _ _ (UNat_exists_is_lub _) H).
  by case=> ?; apply: J.
Qed.

Lemma UNat_bot_elim : ∀ A, ∀ z : UNat_defd ⊥, A z.
Proof.
  rewrite (_ : ⊥ = UNat_bot).
  - by apply/bottom_is_unique/UNat_bot_is_bot.
  - move=>? h.
    by exfalso; case: h.
Qed.

Lemma UNat_lub_elim_dep {P : UNat} {Q : ∀ x, sval P x → Prop} {A} (H : is_lub A P) : (∀ i k (z : sval (A i) k) w, Q k w) → ∀ x (w : sval P x), Q x w.
Proof.
  move=> J K.
  have L := eq_sym (lub_unique _ _ _ (UNat_exists_is_lub _) H).
  dependent destruction L.
  case=> ? X.
  by apply/J/X.
Qed.


Require Export kat_alph atoms gs gl.

Module KAT(X:KAT_Alph).

  Import X.
  Module Export M := GL(X).

  (** * Syntax of KAT terms *)

  Inductive kat : Type :=
  | kats : Z-> kat
  | katb : test -> kat
  | katu : kat -> kat -> kat
  | katc : kat -> kat -> kat
  | katst : kat -> kat.

  Notation "[ b ]?" := (katb b).
  Notation "` x" := (kats x)(at level 10).
  Notation "x + y" := (katu x y).
  Notation "x * y" := (katc x y).
  Notation "x #" := (katst x)(at level 11).

  Coercion katb : test >-> kat.

  Inductive kat_eq : kat -> kat -> Prop :=
    kat_eq_kats : forall x1 y1 : Z, x1 === y1 -> kat_eq (` x1) (` y1)
  | kat_eq_katb : forall x1 y1 : test,
                  x1 === y1 -> kat_eq ([x1]?) ([y1]?)
  | kat_eq_katu : forall x1 y1 x2 y2 : kat,
                  kat_eq x1 y1 -> kat_eq x2 y2 -> kat_eq (x1 + x2) (y1 + y2)
  | kat_eq_katc : forall x1 y1 x2 y2 : kat,
                  kat_eq x1 y1 -> kat_eq x2 y2 -> kat_eq (x1 * x2) (y1 * y2)
  | kat_eq_katst : forall x1 y1 : kat, kat_eq x1 y1 -> kat_eq (x1 #) (y1 #).

  (** [kat] as an ordered type *)

  Proposition kat_eq_leibniz:
    forall x y:kat, kat_eq x y -> x = y.
  Proof.
    induction 1;intros;try (subst;auto).
    - inv H.
    - apply leibniz_test in H; rewrite H;auto.
  Qed.

  Lemma kat_eq_inj_args :
    forall x₁ x₂ y₁ y₂, kat_eq (katc x₁ y₁) (katc x₂ y₂) ->
                        x₁ = x₂ /\ y₁ = y₂.
  Proof.
    intros. apply kat_eq_leibniz in H;injection H;auto.
  Qed.

  Global Instance test_eq_refl : Reflexive kat_eq.
  Proof.
    repeat red;intros;induction x;try constructor;auto.
  Qed.

  Global Instance test_eq_symm : Symmetric kat_eq.
  Proof.
    repeat red.
    induction 1;try reflexivity.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
  Qed.

  Global Instance test_eq_trans : Transitive kat_eq.
  Proof.
    repeat red.
    induction x;intros.
    - inv H.
    - apply kat_eq_leibniz in H.  rewrite H. assumption.
    - inv H;subst. inv H0;subst. constructor;eauto.
    - inv H;subst. inv H0;subst. constructor;eauto.
    - inv H;subst;inv H0;subst. constructor;eauto.
  Qed.

  Global Instance test_eq_Equiv : Equivalence test_eq.
  Proof.
    constructor;autotc.
  Qed.

  Inductive kat_lt : kat -> kat -> Prop :=
    kat_lt_kats_1 : forall x1 y1 : Z, x1 <<< y1 -> kat_lt (`x1) (`y1)
  | kat_lt_kats_katb : forall (x1 : Z) (y1 : test), kat_lt (`x1) ([y1]?)
  | kat_lt_kats_katu : forall (x1 : Z) (y1 y2 : kat),
                       kat_lt (`x1) (y1 + y2)
  | kat_lt_kats_katc : forall (x1 : Z) (y1 y2 : kat),
                       kat_lt (`x1) (y1 * y2)
  | kat_lt_kats_katst : forall (x1 : Z) (y1 : kat), kat_lt (`x1) (y1 #)
  | kat_lt_katb_1 : forall x1 y1 : test,
                    x1 <<< y1 -> kat_lt ([x1]?) ([y1]?)
  | kat_lt_katb_katu : forall (x1 : test) (y1 y2 : kat),
                       kat_lt ([x1]?) (y1 + y2)
  | kat_lt_katb_katc : forall (x1 : test) (y1 y2 : kat),
                       kat_lt ([x1]?) (y1 * y2)
  | kat_lt_katb_katst : forall (x1 : test) (y1 : kat),
                        kat_lt ([x1]?) (y1 #)
  | kat_lt_katu_1 : forall x1 y1 x2 y2 : kat,
                    kat_lt x1 y1 -> kat_lt (x1 + x2) (y1 + y2)
  | kat_lt_katu_2 : forall x1 y1 x2 y2 : kat,
                    kat_eq x1 y1 ->
                    kat_lt x2 y2 -> kat_lt (x1 + x2) (y1 + y2)
  | kat_lt_katu_katc : forall x1 x2 y1 y2 : kat, kat_lt (x1 + x2) (y1 * y2)
  | kat_lt_katu_katst : forall x1 x2 y1 : kat, kat_lt (x1 + x2) (y1 #)
  | kat_lt_katc_1 : forall x1 y1 x2 y2 : kat,
                    kat_lt x1 y1 -> kat_lt (x1 * x2) (y1 * y2)
  | kat_lt_katc_2 : forall x1 y1 x2 y2 : kat,
                    kat_eq x1 y1 ->
                    kat_lt x2 y2 -> kat_lt (x1 * x2) (y1 * y2)
  | kat_lt_katc_katst : forall x1 x2 y1 : kat, kat_lt (x1 * x2) (y1 #)
  | kat_lt_katst_1 : forall x1 y1 : kat, kat_lt x1 y1 -> kat_lt (x1 #) (y1 #).

  Global Instance kat_lt_trans : Transitive kat_lt.
  Proof.
    repeat red.
    induction x;intros.
    - inv H;subst;try (inv H0;subst;try (now constructor)).
      constructor. order.
    - inv H;subst;try (inv H0;subst;try (now constructor)).
      constructor. order.
    - inv H;subst.
      + inv H0;subst;try (now constructor).
        * constructor. eapply IHx1;eauto.
        * apply kat_eq_leibniz in H3;subst. constructor;auto.
      + apply kat_eq_leibniz in H3;subst. inv H0;try (now constructor). subst.
        apply kat_eq_leibniz in H3;subst. apply kat_lt_katu_2. reflexivity. order.
      + inv H0;subst;now constructor.
      + inv H0;subst;now constructor.
    - inv H;subst;try (now constructor).
      + inv H0;subst.
        * constructor;order.
        * apply kat_eq_leibniz in H3;subst. constructor;auto.
        * constructor.
      + apply kat_eq_leibniz in H3;subst. inv H0;subst.
        * constructor;auto.
        * apply kat_eq_leibniz in H3. subst. apply kat_lt_katc_2. reflexivity. order.
        * constructor.
      + inv H0. constructor.
    - inv H;subst. inv H0;subst. constructor;order.
  Qed.

  Global Instance kat_lt_string : StrictOrder kat_lt eq.
  Proof.
    constructor;autotc.
    induction 1;intro;try discriminate;try (now inv H0).
    - inv H0. subst. order.
    - inv H0. subst. order.
  Qed.

  Fixpoint kat_cmp (x y : kat) : comparison :=
    match x with
      | `x1 =>
        match y with
          | `y1 => compare x1 y1
          | katb _ => Lt
          | _ + _ => Lt
          | _ * _ => Lt
          | _ # => Lt
        end
      | katb x1 =>
        match y with
          | `_ => Gt
          | katb y1 => compare x1 y1
          | _ + _ => Lt
          | _ * _ => Lt
          | _ # => Lt
        end
      | x1 + x2 =>
        match y with
          | ` _ => Gt
          | katb _ => Gt
          | y1 + y2 =>
            match kat_cmp x1 y1 with
              | Eq => kat_cmp x2 y2
              | Lt => Lt
              | Gt => Gt
            end
          | _ * _ => Lt
          | _ # => Lt
        end
      | x1 * x2 =>
        match y with
          | ` _ => Gt
          | katb _ => Gt
          | _ + _ => Gt
          | y1 * y2 =>
            match kat_cmp x1 y1 with
              | Eq => kat_cmp x2 y2
              | Lt => Lt
              | Gt => Gt
            end
          | _ # => Lt
        end
      | x1 # =>
        match y with
          | ` _ => Gt
          | katb _ => Gt
          | _ + _ => Gt
          | _ * _ => Gt
          | y1 # => kat_cmp x1 y1
        end
    end.

  (* begin hide *)
  Functional Scheme kat_cmp_ind := Induction for kat_cmp Sort Prop.
  Functional Scheme kat_cmp_rec := Induction for kat_cmp Sort Set.
  (* end hide *)

  Lemma kat_cmp_eq :
    forall x y, kat_cmp x y = Eq -> x = y.
  Proof.
    intros.
    functional induction (kat_cmp x y);try discriminate.
    - apply compare_2 in H. inv H.
    - apply compare_2 in H. inv H.
    - apply IHc in e1; apply IHc0 in H. subst. auto.
    - apply IHc in e1; apply IHc0 in H. subst. auto.
    - apply IHc in H. subst. auto.
  Qed.

  Lemma kat_cmp_lt :
    forall x y, kat_cmp x y = Lt -> kat_lt x y.
  Proof.
    intros.
    functional induction (kat_cmp x y);try discriminate;try (now constructor).
    - constructor. apply compare_1 in H. auto.
    - apply kat_lt_katu_2. apply kat_cmp_eq in e1. subst. reflexivity. apply IHc0;auto.
    - constructor;eauto.
    - apply kat_cmp_eq in e1. subst. apply kat_lt_katc_2. reflexivity. eauto.
    - constructor;eauto.
    - constructor;eauto.
  Qed.

  Lemma kat_cmp_gt :
    forall x y, kat_cmp x y = Gt -> kat_lt y x.
  Proof.
    intros.
    functional induction (kat_cmp x y);try discriminate;try (now constructor).
    - constructor. apply compare_3 in H. auto.
    - apply compare_3 in H. constructor. assumption.
    - apply kat_lt_katu_2. apply kat_cmp_eq in e1. subst. reflexivity. apply IHc0;auto.
    - constructor;eauto.
    - apply kat_cmp_eq in e1. subst. apply kat_lt_katc_2. reflexivity. eauto.
    - constructor;eauto.
    - constructor;eauto.
  Qed.

  Global Instance katOrd : UsualOrderedType kat :=
  {
    SOT_lt := kat_lt ; SOT_cmp := kat_cmp
  }.
  Proof.
    intros.
    case_eq(kat_cmp x y);intros;constructor.
    - apply kat_cmp_eq;auto.
    - apply kat_cmp_lt;auto.
    - apply kat_cmp_gt;auto.
  Defined.

  (** The guarded language of a kat term [t]. *)

  Fixpoint kat2gl(t:kat) : gl :=
    match t with
      | kats x => gl_sy x
      | katb b => gl_atom b
      | katu t1 t2 => gl_union (kat2gl t1) (kat2gl t2)
      | katc t1 t2 => gl_conc (kat2gl t1) (kat2gl t2)
      | katst t1 => gl_star (kat2gl t1)
    end.

  Coercion kat2gl : kat >-> gl.

  Instance kat2gl_m : Proper(_eq ==> gl_eq) kat2gl.
  Proof.
    repeat red.
    intros.
    inv H.
    split;red;auto.
  Qed.

  (** * Results on sets of KAT expressions. Includes special concatenation to
        be used in partial derivatives of KAT terms. *)

  Open Scope set_scope.

  Definition fold_conc :=
    fun s r => (map (fun x => katc x r)) s.

  Global Transparent map.

  Instance right_prod :
    forall x0,
      Proper (_eq ==> _eq) (fun x2 : kat => katc x2 x0).
  Proof.
    intros.
    unfold Proper.
    red.
    intros.

    repeat red;intros.
    f_equal.
    simpl. inv H.
  Qed.

  Instance fold_conc_proper :
    forall x0,
      Proper (_eq ==> Equal ==> Equal)
             (fun (a : kat) (acc : set kat) => {katc a x0; acc}).
  Proof.
    repeat red;split;intros.
    inv H.
    subst.
    apply add_iff in H1.
    destruct H1.
    apply add_1;auto.
    rewrite <- H0.
    apply add_2;auto.
    inv H.
    subst.
    normalize_notations.
    apply add_iff in H1.
    destruct H1.
    apply add_1;auto.
    apply add_2;rewrite H0;auto.
  Qed.

  Lemma fold_conc_transpose :forall x0,
    transpose Equal (fun (a : kat) (acc : set kat) => {katc a x0; acc}).
  Proof.
    unfold transpose;
    split;intros;
    apply add_iff in H;
    destruct H;
      (try now (apply add_2;
        apply add_1;
          symmetry;auto));
    apply add_iff in H;
    destruct H;
      (try now (apply add_1;symmetry;auto));
      now (do 2 apply add_2;auto).
  Qed.

  Global Instance fold_conc_m : Proper (Equal ==> _eq ==> Equal) fold_conc.
  Proof.
    do 3 red;unfold fold_conc.
    induction x using set_induction;intros.
    unfold map.
    assert(Empty y).
    rewrite <- H0;assumption.
    rewrite fold_1b;auto.
    rewrite fold_1b;auto.
    reflexivity.
    unfold map.
    rewrite (@fold_2 kat _ _ _ x1 x2 x3
              _ _ Equal_ST _ _
              (fold_conc_proper x) (fold_conc_transpose x) H H0).
    assert(SetProperties.Add x3 x1 y).
    apply Add_Equal.
    apply Add_Equal in H0.
    rewrite <- H0;symmetry;auto.
    rewrite (@fold_2 kat _ _ _ x1 y x3
              _ _ Equal_ST _ _
              (fold_conc_proper y0) (fold_conc_transpose y0) H H3).
    apply add_m.
    normalize_notations.
    inv H2.
    unfold map in IHx1.
    eapply IHx1.
    reflexivity.
    assumption.
  Qed.

  Lemma fold_conc_empty : forall r:kat,
    fold_conc {} r === {}.
  Proof.
    unfold fold_conc.
    vm_compute;auto.
  Qed.

  Lemma fold_conc_singleton :
    forall x r,
      (fold_conc (singleton x) r) === singleton (katc x r).
  Proof.
    intros.
    vm_compute;auto.
  Qed.

  Instance fold_conc_proper_equal : forall r, Proper (_eq ==> Equal ==> Equal)
    (fun (a : kat) (acc : set kat) => {katc a r; acc}).
  Proof.
    repeat red;split;intros;
    apply add_iff in H1;
    destruct H1.
    rewrite <- H1.
    apply add_1.
    normalize_notations.
    inv H;subst.
    apply add_2.
    rewrite <- H0;auto.

    rewrite <- H1.
    apply add_1.
    inv H;subst.
    apply add_2.
    rewrite H0;auto.
  Qed.

  Lemma fold_conc_trans_equal : forall r,
    transpose Equal (fun (a : kat) (acc : set kat) => {katc a r; acc}).
  Proof.
    repeat red;intros.
    split;intros;auto with typeclass_instances sets.
    apply add_iff in H.
    destruct H.
    apply add_2.
    apply add_1.
    assumption.
    apply add_iff in H.
    destruct H.
    apply add_1;auto.
    apply add_2.
    apply add_2;auto.
    apply add_iff in H.
    destruct H.
    apply add_2;apply add_1;auto.
    apply add_iff in H.
    destruct H.
    apply add_1;auto.
    do 2 apply add_2.
    assumption.
  Qed.

  (* Introduction of element in dsr/dsl *)
  Lemma elem_conc_in_fold_conc : forall s x r,
    x \In s -> (katc x r) \In (fold_conc s r).
  Proof.
    induction s using set_induction.
    intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    inversion H0.
    intros.
    unfold fold_conc.
    eapply map_spec;auto with typeclass_instances.
    exists x0.
    split;auto.
  Qed.

 Lemma elem_conc_fold_conc_in : forall s x r,
    (katc x r) \In (fold_conc s r) -> x \In s.
  Proof.
    induction s using set_induction.
    intros.
    unfold fold_conc,map in H0;rewrite fold_1b in H0;
      auto.
    inversion H0.

    intros.
    unfold fold_conc,map in H1.
    generalize(@fold_2 kat _ _ _ s1 s2 x
              _ _ Equal_ST {}%set  _
              (fold_conc_proper _) (fold_conc_transpose r) H H0).
    intro.
    rewrite H2 in H1.
    clear H2.
    apply add_iff in H1.
    destruct H1.
    inversion H1.
    subst.
    apply H0;auto.
    eapply IHs1 in H1.
    apply H0;auto.
  Qed.

  Lemma elem_conc_nin_dsr : forall s x r,
    ~(x \In s) -> ~((katc x r) \In (fold_conc s r)).
  Proof.
    induction s using set_induction;intros.
    intro.
    eapply elem_conc_fold_conc_in in H1.
    contradiction.
    apply IHs1 with (r:=r) in H.
    intro.
    apply H1.
    apply elem_conc_fold_conc_in in H2.
    contradiction.
  Qed.

  Lemma elem_conc_dsr_nin : forall s x r,
    ~(katc x r) \In (fold_conc s r) ->
    ~x \In s.
  Proof.
    induction s using set_induction;intros.
    intro;apply H0.
    apply empty_is_empty_1 in H.
    rewrite H in H1.
    inversion H1.
    intro.
    apply H1.
    apply elem_conc_in_fold_conc.
    assumption.
  Qed.

   Lemma elem_conc_in_ex : forall s x r,
    x \In (fold_conc s r) -> exists y, y \In s /\ x === katc y r.
  Proof.
    intros.
    apply map_spec in H;auto with typeclass_instances.
  Qed.

   Lemma elem_conc_nin_ex : forall s x r,
    ~x \In (fold_conc s r) -> ~exists y, y \In s /\ x === katc y r.
  Proof.
    induction s using set_induction;intros.
    intro.
    destruct H1 as [y [H11 H12]].
    rewrite H12 in H0.
    apply H0.
    apply elem_conc_in_fold_conc.
    assumption.
    intro.
    destruct H2 as [y [H11 H12]].
    rewrite H12 in H1.
    apply H1.
    apply elem_conc_dsr_nin with (r:=r) in H1.
    contradiction.
  Qed.

  Lemma elem_conc_ex_nin : forall s x r,
    ~x \In s -> ~exists y, (katc y r) \In (fold_conc s r) /\ x === y.
  Proof.
    induction s using set_induction;intros.
    apply elem_conc_nin_dsr with (r:=r) in H0.
    intro.
    destruct H1 as [y [H11 H12]].
    unfold fold_conc in H11.
    eapply map_2 in H11;auto with typeclass_instances.
    destruct  H11.
    destruct H1.
    apply empty_is_empty_1 in H.
    rewrite H in H1.
    inversion H1.

    apply elem_conc_nin_dsr with (r:=r) in H1.
    intro.
    destruct H2 as [y [H11 H12]].
    apply H1;revert H11.
    apply In_m;try reflexivity.
    normalize_notations.
    inv H12;subst.
  Qed.

  Lemma fold_conc_add : forall s r x x0,
    x \In (fold_conc (add x0 s) r) -> x \In (add (katc x0 r) (fold_conc s r)).
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0 |- *.
    rewrite fold_conc_empty.
    rewrite <- singleton_equal_add in H0 |- *.
    rewrite fold_conc_singleton in H0.
    assumption.
    apply  elem_conc_in_ex in H1.
    destruct H1 as [y [H11 H12]].

    generalize(@fold_2 kat _ _ _ s1 s2 x
      _ _ Equal_ST {}%set  _
        (fold_conc_proper _) (fold_conc_transpose r) H H0).
    intro.
    unfold fold_conc,map.
    rewrite H1.

    apply add_iff in H11.
    rewrite H12.
    destruct H11.
    apply add_1.
    inv H2;subst;auto.

    apply add_2.

    apply elem_conc_in_fold_conc with (r:=r) in H2.
    unfold fold_conc,map in H2.
    rewrite H1 in H2.
    assumption.
  Qed.

  Lemma fold_add_conc : forall s r x x0,
    x \In (add (katc x0 r)  (fold_conc s r)) -> x \In (fold_conc (add x0 s) r).
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0 |- *.
    rewrite fold_conc_empty in H0.
    rewrite <- singleton_equal_add in H0 |- *.
    rewrite fold_conc_singleton.
    assumption.
    apply add_iff in H1.
    generalize(@fold_2 kat _ _ _ s1 s2 x
      _ _ Equal_ST {}%set  _
        (fold_conc_proper _) (fold_conc_transpose r) H H0).
    intro.
    destruct H1.
    rewrite <- H1.
    apply elem_conc_in_fold_conc.
    apply add_1.
    reflexivity.
    unfold fold_conc,map in H1.
    apply H2 in H1.
    clear H2.
    apply IHs1 in H1.
    apply elem_conc_in_ex with (r:=r) in H1.
    destruct H1 as [y [H11 H12]].
    rewrite H12.
    apply elem_conc_in_fold_conc with (r:=r).
    apply add_iff in H11.
    destruct H11.
    rewrite <- H1.
    apply add_2.
    apply H0;auto.
    apply add_2.
    apply H0;auto.
  Qed.

   Lemma fold_conc_add_eq : forall s r x,
    (fold_conc (add x s) r) === (add (katc x r) (fold_conc s r)).
  Proof.
    intros.
    split;intros.
    apply fold_conc_add;auto.
    apply fold_add_conc;auto.
  Qed.

  Lemma fold_conc_union : forall x y r a,
    a \In (fold_conc (x++y) r) -> a \In ((fold_conc x r)++(fold_conc y r)).
  Proof.
    induction x using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0 |- *.
    rewrite fold_conc_empty.
    apply union_3.
    rewrite empty_union_1 in H0;auto.
    vm_compute.
    intros.
    inversion x1.

    apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite union_add in H1.
    apply fold_conc_add in H1.
    rewrite H0.
    apply add_iff in H1.
    destruct H1.
    apply union_2.
    apply fold_add_conc.
    rewrite <- H1.
    apply add_1.
    constructor;auto.
    normalize_notations;order.
    normalize_notations;order.
    apply IHx1 in H1.
    apply union_iff in H1.
    destruct H1.
    apply union_2.
    apply fold_add_conc.
    apply add_2;auto.
    apply union_3.
    assumption.
  Qed.

   Lemma fold_union_conc : forall x y r a,
    a \In ((fold_conc x r)++(fold_conc y r)) -> a \In (fold_conc (x++y) r).
  Proof.
    induction x using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0 |- *.
    rewrite fold_conc_empty in H0.
    rewrite empty_union_1 in H0.
    vm_compute;assumption.
    vm_compute;intros.
    inversion x1.

    apply Add_Equal in H0.
    rewrite H0.
    rewrite union_add.
    apply fold_add_conc.
    apply union_iff in H1.
    rewrite H0 in H1.
    destruct H1.
    apply fold_conc_add in H1.
    apply add_iff in H1.
    destruct H1.
    rewrite <- H1.
    apply add_1.
    constructor;normalize_notations;auto.

    apply add_2.
    apply IHx1.
    apply union_2.
    assumption.

    apply add_2.
    apply IHx1.
    apply union_3.
    assumption.
  Qed.

  Lemma fold_conc_card : forall s r,
    cardinal (fold_conc s r) = cardinal s.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H.
    rewrite fold_conc_empty.
    reflexivity.

    generalize(@fold_2 kat _ _ _ s1 s2 x
      _ _ Equal_ST {}%set  _
        (fold_conc_proper _) (fold_conc_transpose r) H H0);intro.
    unfold fold_conc,map.
    rewrite H1.
    apply Add_Equal in H0.
    rewrite H0.
    rewrite add_cardinal_2.
    rewrite add_cardinal_2;try assumption.
    unfold fold_conc,map in IHs1.
    rewrite IHs1.
    abstract omega.
    apply elem_conc_nin_dsr with (r:=r) in H.
    assumption.
  Qed.

  Definition dsr (s:set kat)(r:kat): set kat :=
    match r with
      | katb ba0 => {}%set
      | katb ba1 => s
      | _ => fold_conc s r
    end.

   Notation "x [.] y" := (dsr x y)(at level 60).

   (*Hint Unfold dsr.*)

   (* Their functional inductive principles *)
   Functional Scheme dsr_ind := Induction for dsr Sort Prop.
   Functional Scheme dsr_rec := Induction for dsr Sort Set.

   Lemma dsr_re0 : forall s, (s [.] (katb ba0))==={}%set.
   Proof.
     intro;simpl;reflexivity.
   Qed.

   Lemma dsr_empty : forall r, ({}[.]r)==={}%set.
   Proof.
     induction r;simpl;
     try now(rewrite fold_conc_empty;reflexivity).
     destruct t;
       first [reflexivity | rewrite fold_conc_empty].
   Qed.

  Definition Not_0_1 (r:kat) := ~r === (katb ba0) /\ ~r === (katb ba1).
  Hint Unfold Not_0_1.

  Lemma dsr_singleton : forall x r, Not_0_1 r ->
    ({x}%set [.] r)=== {katc x  r}%set.
  Proof.
    induction r;simpl;intros;
    try (rewrite fold_conc_singleton);auto.
    destruct t;
      try rewrite fold_conc_singleton;auto.
    destruct H.
    elim H;auto.
    destruct H.
    elim H0;auto.
  Qed.

  Add Morphism dsr : dsr_mor.
  Proof.
    unfold dsr.
    intros.
    inv H0;subst. clear H0.
    induction y0.
    apply fold_conc_m. auto.
    reflexivity.
    destruct t;try (apply fold_conc_m);auto.
    reflexivity.
    apply fold_conc_m;auto.
    apply fold_conc_m;auto.
    apply fold_conc_m;auto.
  Qed.

  Lemma dsr_cases : forall s r,
    (s[.]r)==={}%set \/ (s[.]r)===s \/ (Not_0_1 r /\ (s[.]r)===(fold_conc s r)).
  Proof.
    destruct r.
    - right;right.
      split;auto.
      red;split;intro;
      inversion H.
    - case_eq t;intros;auto;
      try (right;right;split;auto);
      try now(red;split;intro;apply leibniz_kat in H;
              discriminate).
      red;split;intro. inv H0. inv H0.
      red;split;intro. inv H0. inv H0.
      red;split;intro. inv H0. inv H0.
      red;split;intro. inv H0. inv H0.
    - right;right. split.
      red;split;intro. inv H. inv H.
      unfold dsr;auto.
    - right;right;split;red;split;intro.
      inv H. inv H. unfold dsr in H. auto.
      unfold dsr;auto.
    - right;right;split;red;split;intro.
      inv H. inv H. unfold dsr in H. auto.
      unfold dsr;auto.
  Qed.

  Lemma elem_conc_dsr_in : forall s x r,
    Not_0_1 r -> x \In s -> (katc x r) \In (s[.]r).
  Proof.
    induction r;intros;try (unfold Not_0_1 in H;intuition);
      unfold dsr;
      try (now (apply elem_conc_in_fold_conc;
          assumption)).
    destruct t.
    elim H1;auto.
    elim H2;auto.
    apply elem_conc_in_fold_conc;assumption.
    apply elem_conc_in_fold_conc;assumption.
    apply elem_conc_in_fold_conc;assumption.
    apply elem_conc_in_fold_conc;assumption.
  Qed.

  Lemma elem_conc_in_dsr : forall s x r,
    Not_0_1 r -> (katc x r) \In (s[.]r) -> x \In s.
  Proof.
    induction r;intros;try (unfold Not_0_1 in H;intuition).
    eapply elem_conc_fold_conc_in in H0;assumption.
    destruct t.
    simpl in H0.
    inversion H0.
    elim H2;auto.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
    eapply elem_conc_fold_conc_in in H0;assumption.
  Qed.

  Lemma dsr_add : forall s x r,
    Not_0_1 r -> (({x;s})[.]r)===(add (katc x r) (s[.]r)).
  Proof.
    induction s using set_induction;intros.
    split;intro;
      apply empty_is_empty_1 in H;
        rewrite H in H1;
          rewrite H.
    rewrite dsr_empty.
    rewrite <- singleton_equal_add in H1 |- *.
    rewrite dsr_singleton in H1;
      assumption.
    rewrite dsr_empty in H1.
    rewrite <- singleton_equal_add in H1 |- *.
    rewrite dsr_singleton;
      assumption.
    functional induction (dsr s2 r);simpl.
    split;intro.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
    destruct H1.
    elim H1;auto.
    destruct H1.
    elim H2;auto.
    split;intro.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
    split;intro.
    apply Add_Equal in H0.
    apply fold_conc_add.
    assumption.
    apply add_iff in H2.
    destruct H2.
    rewrite <- H2.
    apply elem_conc_in_fold_conc.
    apply add_1;auto.
    apply fold_add_conc.
    apply add_2;
      auto.
    split;intro.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc.
    assumption.
    split;intros.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
    split;intros.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
    split;intros.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
    split;intros.
    apply fold_conc_add in H2.
    assumption.
    apply fold_add_conc in H2.
    assumption.
  Qed.

  Lemma dsr_empty_res : forall s r, Empty (s[.]r) -> Empty s \/ r === ba0.
  Proof.
    induction s using set_induction;intros.
    left;auto.
    apply Add_Equal in H0.
    rewrite H0 in H1 |- *.
    apply empty_is_empty_1 in H1.
    destruct(eq_dec r ba0);auto.
    destruct(eq_dec r ba1);auto.
    apply empty_is_empty_2 in H1.
    elim (H1 (katc x r));auto.
    rewrite H3 in H1.
    simpl in H1.
    elim (H1 x).
    apply add_1.
    reflexivity.

    left.
    apply empty_is_empty_2 in H1.
    elim H1 with (a:=(katc x r)).
    apply elem_conc_dsr_in.
    red;auto.
    apply add_1;auto.
  Qed.

  Lemma dsr_union : forall s x r,
    ((x++s)[.]r)===((x[.]r)++(s[.]r)).
  Proof.
    induction x using set_induction;intros.
    split;intro.
    apply empty_is_empty_1 in H.
    rewrite H.
    rewrite H in H0.
    rewrite dsr_empty.
    apply union_3.
    rewrite empty_union_1 in H0;auto.
    vm_compute.
    intros.
    inversion x1.
    apply union_iff in H0.
    destruct H0.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    apply dsr_empty in H0.
    inversion H0.
    generalize H;intro Hx;apply empty_is_empty_1 in H.
    rewrite H.
    rewrite empty_union_1;auto.
    vm_compute;intros.
    inversion x1.

    functional induction (dsr x2 r).
    simpl.
    split;intros.
    apply fold_conc_union in H1.
    assumption.
    apply fold_union_conc.
    assumption.

    simpl;rewrite empty_union_1;auto.
    red;intros;intro;inversion H1.

    simpl;reflexivity.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.

    simpl;split;intros;
    [apply fold_conc_union in H1|apply fold_union_conc];
    assumption.
  Qed.

  Lemma dsr_not_empty : forall s (r:kat),
    ~Empty s -> r =/= ba0 -> ~Empty (s[.]r).
  Proof.
    intros.
    intro.
    apply dsr_empty_res in H1.
    destruct H1;
    contradiction.
  Qed.

  (** Some counter-example based lemmas *)
  Lemma in_dsr_re0 : forall s,
    ~exists x, x \In (s[.]ba0).
  Proof.
    intros s H.
    destruct H.
    rewrite dsr_re0 in H.
    inversion H.
  Qed.

  Lemma in_dsr_re_sy : forall s a x,
    x \In (s[.]kats a) ->
    exists y, x === katc y (kats a) /\ y \In s.
  Proof.
    intros.
    simpl in H.
    apply elem_conc_in_ex in H.
    destruct H as [y [H11 H12] ].
    exists y.
    intuition.
  Qed.

   Lemma in_dsr_re_union : forall s x r1 r2,
    x \In (s[.](katu r1 r2)) ->
    exists y, x === katc y (katu r1 r2) /\ y \In s.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    rewrite dsr_empty in H0.
    inversion H0.

    generalize H0;intro H3;apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite dsr_add in H1.
    apply add_iff in H1.
    destruct H1.
    exists x.
    rewrite H1.
    split.
    reflexivity.
    rewrite H0.
    apply add_1;reflexivity.

    apply IHs1 in H1.
    destruct H1 as [y [H11 H12]].
    exists y.
    split;auto.
    rewrite H0;apply add_2.
    assumption.

    unfold Not_0_1.
    intuition;
      inversion H2.
  Qed.

  Lemma in_dsr_re_conc : forall s x r1 r2,
    x \In (s[.](katc r1 r2)) ->
    exists y, x === katc y (katc r1 r2) /\ y \In s.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    rewrite dsr_empty in H0.
    inversion H0.
    generalize H1;intro H3;apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite dsr_add in H1.
    apply add_iff in H1.
    destruct H1.
    exists x.
    rewrite H1.
    split;try reflexivity.
    rewrite H0;apply add_1;reflexivity.

    apply IHs1 in H1.
    destruct H1 as [y [H11 H12]].
    exists y.
    split;auto.
    rewrite H0;apply add_2;auto.

    unfold Not_0_1.
    intuition;
      inversion H2.
  Qed.

  Lemma in_dsr_re_star : forall s x r,
    x \In (s[.](katst r)) ->
    exists y, x === katc y (katst r) /\ y \In s.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    rewrite dsr_empty in H0.
    inversion H0.
    generalize H1;intro H3;apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite dsr_add in H1.
    apply add_iff in H1.
    destruct H1.
    exists x.
    rewrite H1.
    split;auto.
    rewrite H0.
    apply add_1;reflexivity.

    apply IHs1 in H1.
    destruct H1 as [y [H11 H12]].
    exists y.
    split;auto.
    rewrite H0;apply add_2;auto.

    unfold Not_0_1.
    intuition;
      inversion H2.
  Qed.

  Lemma in_dsr : forall s r x,
                   Not_0_1 r -> x \In (s[.]r) ->
                   exists y', y' \In s /\ x === katc y' r.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H1.
    rewrite dsr_empty in H1.
    inversion H1.
    apply Add_Equal in H0.
    rewrite H0 in H2.
    rewrite dsr_add in H2;auto.
    apply add_iff in H2.
    destruct H2.
    exists x.
    rewrite H2.
    split;auto.
    rewrite H0;apply add_1;auto.

    apply (IHs1 _ _ H1) in H2.
    do 2 destruct H2.
    exists x1.
    split;auto.
    rewrite H0;apply add_2;auto.
  Qed.

  (** dsr cardinality *)

  Theorem dsr_cardinal : forall s r,  (cardinal (s[.]r)) <= (cardinal s).
  Proof.
    intros s r;
      generalize(fold_conc_card s r);
        revert r.
    induction r;simpl;intro H.
    rewrite H.
    abstract omega.
    destruct t.
    rewrite cardinal_1.
    omega.
    red;intros;intro.
    inversion H0.
    omega.
    rewrite H;omega.
    rewrite H;omega.
    rewrite H;omega.
    rewrite H;omega.
    rewrite H;omega.
    rewrite H;omega.
    rewrite H;omega.
  Qed.

  Inductive SkatL : set kat -> gl :=
    | in_skat_lang :
      forall s w r,
        r \In s -> In _ (kat2gl r) w -> In _ (SkatL s) w.

  Notation "L[ s ]" := (SkatL s)(at level 0).

  Hint Constructors SkatL : gl_hints.

  Instance SkatL_m : Proper(_eq ==> gl_eq) SkatL.
  Proof.
    repeat red.
    induction x using set_induction;gl_goal.
    inv H1.
    subst.
    apply H0 in H2.
    econstructor.
    apply H2.
    assumption.
    inv H1.
    subst.
    econstructor.
    apply H0.
    apply H2.
    assumption.
    inv H2.
    subst.
    econstructor.
    apply H1.
    apply H3.
    assumption.
    inv H2.
    subst.
    econstructor.
    apply H1.
    apply H3.
    assumption.
  Qed.

  Instance kat2gl_m_eq : Proper (_eq ==> gl_eq) (fun a => kat2gl a).
  Proof.
    repeat red.
    split;red;intros;inv H.
  Qed.

  Lemma In_SkatL_elem :
    forall (s:set kat) (w:gstring),
      In _ (SkatL s) w  -> exists r, r \In s /\ In _ (kat2gl r) w.
  Proof.
    induction s using set_induction;intros.
    inversion_clear H0.
    exists r;auto.
    inversion_clear H1.
    apply Add_Equal in H0.
    rewrite H0 in H2.
    apply add_iff in H2.
    destruct H2.
    subst.
    exists r;split;auto.
    rewrite H0.
    rewrite H1.
    apply add_1.
    reflexivity.
    exists r;split.
    rewrite H0.
    apply add_2;auto.
    assumption.
  Qed.

  Lemma In_kat2gl_in_SkatL :
    forall w (r:kat),
      In _ (kat2gl r) w -> forall s, r \In s -> In _ (SkatL s) w.
  Proof.
    intros w r H s.
    induction s using set_induction;intros.
    econstructor.
    apply H1.
    assumption.
    econstructor.
    apply H2.
    assumption.
  Qed.

  Lemma SkatL_empty : gl_emp == L[{}].
  Proof.
    gl_goal.
    inv H.
    inv H.
    inv H0.
  Qed.

  Lemma SkatL_singleton :
    forall x:kat,
      L[{x}%set] == x.
  Proof.
    gl_goal.
    inversion_clear H.
    apply singleton_1 in H0.
    apply kat2gl_m_eq in H0.
    apply H0 in H1.
    assumption.

    econstructor.
    apply singleton_2.
    reflexivity.
    assumption.
  Qed.

  Lemma SkatL_union :
    forall x y:set kat,
      L[x ++ y] == gl_union L[x] L[y].
  Proof.
    gl_goal.
    inversion_clear H.
    apply union_iff in H0.
    destruct H0.
    constructor 1.
    econstructor.
    apply H.
    assumption.
    constructor 2;econstructor;auto.
    apply H;assumption.
    assumption.
    destruct H.
    destruct H.
    econstructor.
    apply union_2.
    apply H.
    assumption.
    destruct H.
    econstructor.
    apply union_3.
    apply H.
    assumption.
  Qed.

  Lemma SkatL_add :
    forall a x,
      L[{a;x}] == gl_union L[{a}%set] L[x].
  Proof.
    induction x using set_induction;intros.
    gl_goal.
    inversion_clear H0.
    apply add_iff in H1.
    destruct H1.
    subst.
    constructor.
    eapply SkatL_singleton.
    apply kat2gl_m_eq in H0.
    apply H0.
    assumption.
    elim (H r).
    assumption.
    destruct H0.
    apply SkatL_singleton in H0.
    constructor 1 with (r:=a).
    apply add_1;apply singleton_1;apply singleton_2;reflexivity.
    assumption.
    inversion_clear H0.
    econstructor 1 with (r:=r).
    apply add_2;assumption.
    assumption.
    apply Add_Equal in H0.
    rewrite H0.
    gl_goal.
    inversion_clear H1.
    apply add_iff in H2.
    destruct H2.
    constructor.
    eapply SkatL_singleton.
    apply kat2gl_m_eq in H1.
    apply H1.
    assumption.
    constructor 2.
    apply add_iff in H1.
    destruct H1.
    constructor 1 with r.
    rewrite <- H1.
    apply add_1;apply singleton_1;apply singleton_2;reflexivity.
    assumption.
    econstructor 1 with r.
    apply add_2.
    assumption.
    assumption.
    destruct H1.
    constructor 1 with (r:=a).
    inversion_clear H1.
    apply add_1.
    reflexivity.
    apply SkatL_singleton in H1.
    assumption.
    destruct H1.
    econstructor 1 with (r:=r).
    apply add_2;auto.
    assumption.
  Qed.

  Lemma  SkatL_fconc :
    forall s r,
      L[(fold_conc s r)%set] == gl_conc (L[s]) r.
  Proof.
    gl_goal.
    inversion_clear H.
    apply elem_conc_in_ex in H0.
    destruct H0.
    destruct H.
    apply kat2gl_m_eq in H0.
    apply H0 in H1.
    simpl in H1.
    inversion_clear H1.
    constructor.
    econstructor 1 with (r:=x0);auto.
    assumption.

    inversion_clear H.
    destruct H0.
    apply elem_conc_in_fold_conc with (r:=r) in H.
    econstructor.
    apply H.
    simpl.
    constructor;auto.
  Qed.

  Lemma SkatL_dsr :
    forall s r,
      L[dsr s r] == gl_conc L[s] r.
  Proof.
    gl_goal.
    inversion_clear H.
    destruct(eq_dec r (katb (ba0))).
    rewrite H in H0.
    simpl in H0.
    inversion H0.
    destruct(eq_dec r (katb (ba1))).
    rewrite H2 in H0;simpl in H0.
    apply kat2gl_m_eq in H2.
    assert( compatible x (gs_end (last x))).
    red.
    simpl.
    reflexivity.
    rewrite (fusion_prod_same_last x H3).
    constructor.
    econstructor.
    apply H0.
    assumption.
    apply H2;simpl.
    constructor.
    reflexivity.
    eapply conc_gl_atom_true_left.
    apply in_dsr in H0;auto.
    destruct H0.
    destruct H0.
    generalize H3;intro.
    apply kat2gl_m_eq in H4.
    apply H4 in H1.
    assert( compatible x (gs_end (last x))).
    red.
    simpl.
    reflexivity.
    rewrite (fusion_prod_same_last x H5).
    constructor.
    simpl in H1.
    inversion_clear H1.
    constructor;auto.
    econstructor.
    apply H0.
    assumption.
    constructor.
    reflexivity.

    inversion_clear H.
    inversion_clear H0.
    destruct(eq_dec r (katb ba0)).
    apply kat2gl_m_eq in H0.
    apply H0 in H1;inversion H1.
    inv H1.
    destruct(eq_dec r (katb ba1)).
    generalize H3;intros.
    apply kat2gl_m_eq in H4.
    apply H4 in H1.
    simpl in H1.
    eapply conc_gl_atom_true_left.
    constructor;auto.
    econstructor 1 with (r:=r0).
    rewrite H3.
    simpl.
    assumption.
    assumption.
    econstructor.
    apply elem_conc_dsr_in;auto.
    apply H.
    simpl;constructor;auto.
  Qed.

End KAT.