Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import vars.
Require Import env.
Require Import tactics.
Require Import qualifiers.
Require Import lambda_diamond.
Require Import examples_infra.

(* Require Import examples_infra. *)
Require Import NatSets.
Require Import setfacts.
Import NatSet.F.

Import OpeningNotations.
Local Open Scope opening.
Import QualNotations.
Local Open Scope qualifiers.

(* ### Examples ### *)

Notation " { a | b } ==> { c | d }"  := (TFun b d a c)
(at level 10, format "'[' '[hv' '{' a  '/' '|'  b '}' ']' '/  '  '==>'  '[hv' '{' c  '/' '|'  d '}' ']' ']'").

Section QPoly.

  Example idfun := (tabs #1).

  Example idfun_ty : forall {T}, closed_ty 0 0 0 T -> has_type [] {♦} [] idfun ({ T | {♦} } ==> { T | #!1 }) ∅.
    intros. unfold idfun.
    apply t_abs; ccrush.
    eapply t_var; ccrush.
  Qed.

  Example idfun_app1 : has_type [] {♦} [] (tapp idfun tunit) TUnit ∅.
    dep_app (∅) (∅) #!1.
    eapply t_app_fresh with (d1':=∅) (df':=∅); ccrush.
    apply idfun_ty; auto.
  Qed.

  Example idfun_app2 : has_type [] {♦} [] (tapp idfun (tref tunit)) (TRef ∅ TUnit) {♦}.
    dep_app (∅) ({♦}) #!1.
    eapply t_app_fresh with (d1':={♦}) (df':=∅); eauto; ccrush.
    apply idfun_ty; auto.
    change_qual ({♦} ⊔ ∅). apply t_ref; auto.
  Qed.

  Section FakeId.
    Variable (alloc : tm).
    Context (t_alloc : forall {Γ φ Σ T},
                       closed_ty 0 (‖Γ‖) (‖Σ‖) T ->
                       has_type Γ φ Σ alloc T {♦})
            (cl_alloc : closed_tm 0 0 0 alloc).

    (* fakeid example cannot be typed the same as the identity function *)
    Example fakeid := (tabs alloc).

    (* fakeid can't be typed as id *)
    Example fakeid_nt : forall {T}, closed_ty 0 0 0 T -> has_type [] {♦} [] fakeid ({ T | {♦} } ==> { T | #!1 }) ∅.
      intros. unfold fakeid in *.
      apply t_abs; ccrush.
      (* we can't apply t_alloc *)
      Fail apply t_alloc.
      (* and neither can we use subtyping in this context to deduce T {♦} <: T $!1 *)
    Abort.

  End FakeId.

  (** Church encodings *)
  Section Church.

    Section Bool.
      (* Church true, respectively pi1: λa.λb.a *)
      Example church_true := (tabs (tabs #3)).
      (* Type scheme for pi1 := (x:A^a) -> ((y:B^b) -> A^x)^{x}. *)
      Example church_true_T A a B b := {A | a} ==> {{B | b} ==> {A | #! 3} | #! 1}.
      (* Church false, respectively pi2: λa.λb.b  *)
      Example church_false := (tabs (tabs #1)).
      (* Type scheme for pi2 := (x:A^a) -> ((y:B^b) -> B^y)^{}. *)
      Example church_false_T A a B b := {A | a} ==> {{B | b} ==> {B | #! 1} | ∅}.

      Variables (Γ : tenv) (φ : qual) (Σ : senv) (A B : ty) (a b : qual).
      Context (phiwf : closed_qual 0 (‖Γ‖) (‖Σ‖) φ)
              (Awf   : closed_ty 0 (‖Γ‖) (‖Σ‖) A)
              (Bwf   : closed_ty 0 (‖Γ‖) (‖Σ‖) B)
              (awf   : closed_qual 0 (‖Γ‖) (‖Σ‖) a)
              (bwf   : closed_qual 0 (‖Γ‖) (‖Σ‖) b)
              .

      (** Γ|Σ ⊢ᵠ λa.λb.a : (x:A^a) -> ((y:B^b) -> A^x)^{x} *)
      Example church_true_ht : has_type Γ φ Σ church_true (church_true_T A a B b) ∅.
        intros. unfold church_true. unfold church_true_T.
        apply t_abs; ccrush.
        apply t_abs; ccrush.
        eapply t_var; ccrush.
      Qed.

      (** Typing with the less precise A^a requires that a is not fresh!
          Γ|Σ ⊢ᵠ λa.λb.a : ((x:A^a) -> ((y:B^b) -> A^a)^{x})^{}
          This type is required for using it as a projection on the TPair1 type below *)
      Example church_true_ht' : ♦∉ a -> has_type Γ φ Σ church_true ({A | a} ==> {{B | b} ==> {A | a } | #! 1}) ∅.
        intros. unfold church_true. eapply t_sub; auto. eapply church_true_ht.
        unfold church_true_T.
        apply s_fun; ccrush.
        * apply stp_refl; ccrush.
        * apply s_fun; ccrush.
          apply qstp_refl; ccrush.
          apply stp_refl; ccrush. apply qstp_refl; ccrush.
          apply stp_refl; ccrush. eapply qs_qvar; ccrush.
      Qed.

      Example church_true_ht'' : ♦∉ a -> has_type Γ φ Σ church_true ({A | a} ==> {{B | b} ==> {A | a } | #! 1}) (∅).
        intros. eapply t_sub. eapply church_true_ht'; eauto.
        apply stp_refl; ccrush. all: auto.
      Qed.

      (* This type is used for the projection on the TPair2 type with implicitly reachability polymorphic eliminations below *)
      Example church_true_ht''' : ♦∉ a -> has_type Γ φ Σ church_true ({A | a} ==> {{B | b} ==> {A | a } | #!0 ⊔ #!1}) (∅).
        intros. eapply t_sub. eapply church_true_ht''; eauto.
        apply s_fun; ccrush; auto. apply stp_refl; ccrush.
        apply stp_refl; ccrush. apply qs_sq; ccrush. all: ccrush; auto.
      Qed.

      Example church_false_ht : has_type Γ φ Σ church_false (church_false_T A a B b) ∅.
        intros. unfold church_false. unfold church_false_T.
        apply t_abs; ccrush.
        apply t_abs; ccrush.
        eapply t_var; ccrush.
      Qed.

      (* This type is required for using it as a projection on the TPair1 type below *)
      Example church_false_ht' : ♦∉ b -> has_type Γ φ Σ church_false ({A | a} ==> {{B | b} ==> {B | b} | #!1 }) ∅.
        intros. unfold church_false. eapply t_sub; auto. eapply church_false_ht.
        unfold church_false_T.
        apply s_fun; ccrush.
        * apply stp_refl; ccrush.
        * apply s_fun; ccrush.
          apply qs_sq; ccrush.
          apply stp_refl; ccrush. apply qstp_refl; ccrush.
          apply stp_refl; ccrush. eapply qs_qvar; ccrush.
      Qed.

      (* This type is used for the projection on the TPair2 type with implicitly reachability polymorphic eliminations below *)
      Example church_false_ht''' : ♦∉ b -> has_type Γ φ Σ church_false ({A | a} ==> {{B | b} ==> {B | b } | #!0 ⊔ #!1}) (∅).
        intros. eapply t_sub. eapply church_false_ht'; eauto.
        apply s_fun; ccrush; auto.
        apply stp_refl; ccrush. apply stp_refl; ccrush. apply qs_sq; ccrush. all: ccrush; auto.
      Qed.
    End Bool.

    Section Pair.

      Variables (Γ : tenv) (φ : qual) (Σ : senv) (A B : ty) (a b : qual).
      Context (phiwf : closed_qual 0 (‖Γ‖) (‖Σ‖) φ)
              (Awf   : closed_ty 0 (‖Γ‖) (‖Σ‖) A)
              (Bwf   : closed_ty 0 (‖Γ‖) (‖Σ‖) B)
              (awf   : closed_qual 0 (‖Γ‖) (‖Σ‖) a)
              (bwf   : closed_qual 0 (‖Γ‖) (‖Σ‖) b)
              (aobs  : a ⊑ φ)
              (bobs  : b ⊑ φ)
              .

      (* Church pairs, to the extent we can model them without support for type abstraction *)
      (* Pair introduction *)
      Example pair := (tabs (tabs (tabs (tapp (tapp #1 #5) #3)))).
      (* Pair destructors *)
      Example fst := (tabs (tapp #1 church_true)).
      Example snd := (tabs (tapp #1 church_false)).

      (* Version constraining the elimination to {a,b}, effectively restricting it to the projections.
        Pair[A^a,B^b]_C^c := ((x : A^a) -> ((y : B^b) -> C^c)^x)^{} -> C^c *)
      Example TPair1 A a B b C c := {{A | a} ==> {{B | b} ==> {C | c} | #!1} | ∅ } ==> {C | c}.

      (* Version implicitly polymorphic over the elimination's captured variables, as in the paper:
          Pair[A^a,B^b]_C^c := (f(x : A^a) -> ((y : B^b) -> C^c)^f,x)^{a,b,♦} -> C^c *)
      Example TPair2 A a B b C c := {{A | a} ==> {{B | b} ==> {C | c} | #!0 ⊔ #!1} | a ⊔ b ⊔ {♦}} ==> {C | c}.

      (* Γ|Σ ⊢ᵠ pair : ( (x : A^a) -> ((y : B^b) -> (Pair1[A^x,B^y]_C^c)^c,x,y)^c,x)^c *)
      Example t_pair1 : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ a -> ♦∉ b -> ♦∉ c ->
        senv_saturated Σ a -> senv_saturated Σ b -> senv_saturated Σ c ->
        (* lacking object-level type abstraction, the elimination's qualifier c leaks into the outer layers of qualifiers in the constructor: *)
        has_type Γ φ Σ pair ({A | a} ==> {{B | b} ==> {TPair1 A #!3 B #!3 C c | (c ⊔ #!3 ⊔ #!1) } | (c ⊔ #!1) }) (c).
        intros. unfold pair.
        apply t_abs; ccrush. unfold TPair1. ccrush.
        apply t_abs; ccrush. auto.
        apply t_abs; ccrush.
        change_qual (c ⊔ $!(S (‖ Γ ‖)) ⊔ $!(S (S (S (‖ Γ ‖))))); auto.
        dep_app ($!(S (‖Γ‖))) ($!(S (S ( S (‖Γ‖))))).
        apply t_app with (T1:=B); ccrush.
        * dep_app ($! (S (S (S (S (S (‖ Γ ‖))))))) $!(S (‖Γ‖)) #!1.
          apply t_app with (T1:=A); ccrush.
          + eapply t_var; ccrush.
          + eapply t_var; ccrush.
        * eapply t_var; ccrush.
      Qed.

      (* Γ|Σ ⊢ᵠ pair : ( (x : A^a) -> ((y : B^b) -> (Pair1[A^a,B^b]_C^c)^a,b,c)^a,c)^c *)
      Example t_pair1' : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ a -> ♦∉ b -> ♦∉ c ->
        senv_saturated Σ a -> senv_saturated Σ b -> senv_saturated Σ c ->
        (* lacking object-level type abstraction, the elimination's qualifier c leaks into the outer layers of qualifiers in the constructor: *)
        has_type Γ φ Σ pair ({A | a} ==> {{B | b} ==> {TPair1 A a B b C c | (a ⊔ b ⊔ c) } | (a ⊔ c) }) (c).
        intros. eapply t_sub; auto.
        * eapply @t_pair1 with (C:=C) (c:=c); ccrush.
        * apply s_fun. 1, 2 : unfold TPair1; ccrush. ccrush. (* automate!*) apply stp_refl; ccrush.
          cleanup; try lia. apply s_fun. 1,2 : unfold TPair1; ccrush.
          + rewrite (@qlub_commute a). apply qs_cong; ccrush.
            eapply qs_qvar; ccrush.
          + (* automate *) apply stp_refl; ccrush. apply qs_sq; ccrush.
          + cleanup; try lia. apply s_fun; ccrush.
            - replace (c ⊔ qset false (union (singleton (S (‖ Γ ‖))) (singleton (S (S (S (‖ Γ ‖)))))) {}N {}N)
              with    (($!(S (‖Γ‖)) ⊔ $!(S (S (S (‖Γ‖))))) ⊔ c).
              rewrite (@qlub_assoc a b). apply qs_cong_r; crush.
              eapply qs_trans with (d2 := a ⊔ $!(S (S (S (‖Γ‖))))).
              ** apply qs_cong_r; ccrush. eapply qs_qvar; ccrush.
              ** apply qs_cong; ccrush. eapply qs_qvar; ccrush.
              ** destruct c. ccrush.
            - apply s_fun; ccrush.
              ** apply stp_refl; ccrush. eapply qs_qvar; ccrush.
              ** apply s_fun; ccrush. apply qstp_refl; ccrush.
                 apply stp_refl; ccrush. eapply qs_qvar; ccrush.
                 apply stp_refl; ccrush. apply qstp_refl; ccrush.
            - apply stp_refl; ccrush. apply qstp_refl; ccrush.
      Qed.

      Example TPair2_ A a B b v C c := {{A | a} ==> {{B | b} ==> {C | c} | #!0 ⊔ #!1} | v ⊔ {♦}} ==> {C | c}.

        (* Γ|Σ ⊢ᵠ pair : ( (x : A^a) -> ((y : B^b) -> (Pair2[A^x,B^y]_C^c)^x,y,c)^x,c)^c *)
      Example t_pair2 : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ a -> ♦∉ b -> ♦∉ c ->
        senv_saturated Σ a -> senv_saturated Σ b -> senv_saturated Σ c ->
        (* lacking object-level type abstraction, the elimination's qualifier c leaks into the outer layers of qualifiers in the constructor: *)
        has_type Γ φ Σ pair ({A | a} ==> {{B | b} ==> {TPair2_ A #!3 B #!3 (a ⊔ b) C c | (c ⊔ #!3 ⊔ #!1) } | (c ⊔ #!1) }) (c).
        intros. unfold pair.
        apply t_abs; ccrush. unfold TPair2_. ccrush.
        apply t_abs; ccrush. auto.
        apply t_abs; ccrush. change_qual (c ⊔ $!(S (‖ Γ ‖)) ⊔ $!(S (S (S (‖ Γ ‖))))); auto.
        dep_app ($!(S (S (S (S (S (‖ Γ ‖)))))) ⊔ $!(S (‖Γ‖))) ($!(S (S ( S (‖Γ‖))))).
        apply t_app with (T1:=B); ccrush.
        * dep_app ($!(S (S (S (S (S (‖ Γ ‖))))))) ($!(S (‖Γ‖))) (qset false {}N (union (singleton 0) (singleton 1)) {}N).
          apply t_app with (T1:=A); ccrush.
          + eapply t_var; ccrush.
          + eapply t_var; ccrush.
          + destruct c. ccrush.
        * eapply t_var; ccrush.
      Qed.

       (* Γ|Σ ⊢ᵠ pair : ( (x : A^a) -> ((y : B^b) -> (Pair2[A^a,B^b]_C^c)^a,b,c)^a,c)^c *)
      Example t_pair2' : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ a -> ♦∉ b -> ♦∉ c ->
        senv_saturated Σ a -> senv_saturated Σ b -> senv_saturated Σ c ->
        (* lacking object-level type abstraction, the elimination's qualifier c leaks into the outer layers of qualifiers in the constructor: *)
        has_type Γ φ Σ pair ({A | a} ==> {{B | b} ==> {TPair2 A a B b C c | (a ⊔ b ⊔ c) } | (a ⊔ c) }) (c).
        intros. eapply t_sub; auto.
        * eapply @t_pair2 with (C:=C) (c:=c); ccrush.
        * apply s_fun. 1, 2 : unfold TPair2; unfold TPair2_; ccrush. ccrush. (* automate!*) apply stp_refl; ccrush.
          cleanup; try lia. apply s_fun. 1,2 : unfold TPair2; unfold TPair2_; ccrush.
          + rewrite (@qlub_commute a c). apply qs_cong; ccrush.
            eapply qs_qvar; ccrush.
          + (* automate *) apply stp_refl; ccrush. apply qs_sq; ccrush.
          + cleanup; try lia. apply s_fun; ccrush.
            - replace (c ⊔ qset false (union (singleton (S (‖ Γ ‖))) (singleton (S (S (S (‖ Γ ‖)))))) {}N {}N)
              with    (($!(S (‖Γ‖)) ⊔ $!(S (S (S (‖Γ‖))))) ⊔ c).
              rewrite (@qlub_assoc a b). apply qs_cong_r; crush.
              eapply qs_trans with (d2 := a ⊔ $!(S (S (S (‖Γ‖))))).
              ** apply qs_cong_r; ccrush. eapply qs_qvar; ccrush.
              ** apply qs_cong; ccrush. eapply qs_qvar; ccrush.
              ** destruct c. ccrush.
            - apply s_fun; ccrush.
              ** apply qstp_refl; ccrush. rewrite (@qlub_assoc a b). auto.
              ** apply stp_refl; ccrush. eapply qs_qvar; ccrush.
              ** apply s_fun; ccrush. apply qstp_refl; ccrush.
                 apply stp_refl; ccrush. eapply qs_qvar; ccrush.
                 apply stp_refl; ccrush. apply qstp_refl; ccrush.
            - apply stp_refl; ccrush. apply qstp_refl; ccrush.
      Qed.

      (* Assert that the projection functions are compatible with each pair type *)
      Example t_fst1 : forall {q},
        closed_qual 0 (‖Γ‖) (‖Σ‖) q ->
        ♦∉ a ->
        senv_saturated Σ a ->
        (* lacking object-level type abstraction, we pre-instantiate the pair *)
        has_type Γ φ Σ fst ({(TPair1 A a B b A a) | q} ==> {A | a}) (a).
        intros. unfold fst. apply t_abs; ccrush; auto.
        unfold TPair1. ccrush.
        dep_app ($!(S(‖Γ‖))) (∅).
        eapply t_app. eapply t_var; ccrush.
        apply church_true_ht'; ccrush.
        all : ccrush.
      Qed.

      Example t_snd1 : forall {q},
        closed_qual 0 (‖Γ‖) (‖Σ‖) q ->
        ♦∉ b ->
        senv_saturated Σ b ->
        (* lacking object-level type abstraction, we pre-instantiate the pair *)
        has_type Γ φ Σ snd ({(TPair1 A a B b B b) | q} ==> {B | b}) (b).
        intros. unfold snd. apply t_abs; ccrush; auto.
        unfold TPair1. ccrush.
        dep_app ($!(S(‖Γ‖))) (∅).
        eapply t_app. eapply t_var; ccrush.
        apply church_false_ht'; ccrush.
        all : ccrush.
      Qed.

      Example t_fst2 : forall {q},
        closed_qual 0 (‖Γ‖) (‖Σ‖) q ->
        ♦∉ a ->
        ♦∉ b ->
        ♦∉ q ->
        q ⊑ φ ->
        saturated Γ Σ a ->
        saturated Γ Σ b ->
        saturated Γ Σ q ->
        (* lacking object-level type abstraction, we pre-instantiate the pair *)
        has_type Γ φ Σ fst ({(TPair2 A a B b A a) | q} ==> {A | a}) (q ⊔ a ⊔ b).
        intros. unfold fst. apply t_abs; ccrush; auto.
        unfold TPair2. ccrush.
        dep_app (q) (∅).
        eapply t_app_fresh with (T1:=({A | a} ==> {{B | b} ==> {A | a} | #! 0 ⊔ #! 1})) (d1':= ∅) (df':=q); try solve [ccrush].
        * dom_equals ({♦}). destruct q. qdec.
          eapply t_sub with (T1:=TPair2 A a B b A a) (d1:=$!(S (‖Γ‖))); ccrush.
          - unfold TPair2. eapply t_var; ccrush.
          - eapply s_fun; ccrush.
            unfold TPair2. eapply qs_qvar; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
        * apply church_true_ht'''; ccrush.
      Qed.

      Example t_snd2 : forall {q},
        closed_qual 0 (‖Γ‖) (‖Σ‖) q ->
        ♦∉ a ->
        ♦∉ b ->
        ♦∉ q ->
        q ⊑ φ ->
        saturated Γ Σ a ->
        saturated Γ Σ b ->
        saturated Γ Σ q ->
        (* lacking object-level type abstraction, we pre-instantiate the pair *)
        has_type Γ φ Σ snd ({(TPair2 A a B b B b) | q} ==> {B | b}) (q ⊔ a ⊔ b).
        intros. unfold snd. apply t_abs; ccrush; auto.
        unfold TPair2. ccrush.
        dep_app (q) (∅).
        eapply t_app_fresh with (T1:=({A | a} ==> {{B | b} ==> {B | b} | #! 0 ⊔ #! 1})) (d1':= ∅) (df':=q); try solve [ccrush].
        * dom_equals ({♦}). destruct q. qdec.
          eapply t_sub with (T1:=TPair2 A a B b B b) (d1:=$!(S (‖Γ‖))); ccrush.
          - unfold TPair2. eapply t_var; ccrush.
          - eapply s_fun; ccrush.
            unfold TPair2. eapply qs_qvar; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
        * apply church_false_ht'''; ccrush.
      Qed.

      Context (ta tb : tm)
              (ht_ta : has_type Γ φ Σ ta A a)
              (ht_tb : has_type Γ φ Σ tb B b)
              (nf_a  : ♦∉ a)
              (nf_b  : ♦∉ b)
              (sat_a : saturated Γ Σ a)
              (sat_b : saturated Γ Σ b).

      Example pair_ab := (tapp (tapp pair ta) tb).

      Example pair_intro1 : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ c -> senv_saturated Σ c ->
        has_type Γ φ Σ pair_ab (TPair1 A a B b C c) (a ⊔ b ⊔ c).
        intros. unfold TPair1. unfold pair_ab.
        dep_app (a ⊔ c) b.
        apply t_app with (T1:=B); ccrush.
        dep_app (c) (a).
        apply t_app with (T1:=A); ccrush; auto.
        fold (TPair1 A a B b C c). apply t_pair1'; ccrush.
      Qed.

      Example pair_intro2 : forall {C c},
        closed_ty 0 (length Γ) (length Σ) C ->
        closed_qual 0 (length Γ) (length Σ) c ->
        c ⊑ φ -> ♦∉ c -> senv_saturated Σ c ->
        has_type Γ φ Σ pair_ab (TPair2 A a B b C c) (a ⊔ b ⊔ c).
        intros. unfold TPair2. unfold pair_ab.
        dep_app (a ⊔ c) b.
        apply t_app with (T1:=B); crush; auto.
        dep_app (c) (a).
        apply t_app with (T1:=A); crush.
        fold (TPair2 A a B b C c). apply t_pair2'; ccrush. all : ccrush.
      Qed.

      (* Elimination on TPair1 *)
      Example pair1_elim1 : has_type Γ φ Σ (tapp fst pair_ab) A a.
        dep_app (a) (a ⊔ b ⊔ a).
        eapply t_app; try solve [ccrush].
        * eapply t_fst1; ccrush.
        * apply pair_intro1; ccrush.
      Qed.

      (* Elimination on TPair1 *)
      Example pair1_elim2 : has_type Γ φ Σ (tapp snd pair_ab) B b.
        dep_app (b) (a ⊔ b ⊔ b).
        eapply t_app; try solve [ccrush].
        * eapply t_snd1; ccrush.
        * apply pair_intro1; ccrush.
      Qed.

      (* Elimination on TPair2 *)
      Example pair2_elim1 : has_type Γ φ Σ (tapp fst pair_ab) A a.
        dep_app ((a ⊔ b ⊔ a) ⊔ a ⊔ b) (a ⊔ b ⊔ a).
        eapply t_app; try solve [ccrush].
        * eapply t_fst2; ccrush.
        * apply pair_intro2; ccrush.
      Qed.

      (* Elimination on TPair2 *)
      Example pair2_elim2 : has_type Γ φ Σ (tapp snd pair_ab) B b.
        dep_app ((a ⊔ b ⊔ b) ⊔ a ⊔ b)  (a ⊔ b ⊔ b).
        eapply t_app; try solve [ccrush].
        * eapply t_snd2; ccrush.
        * apply pair_intro2; ccrush.
      Qed.

      (* TPair2 elimination behaves like a case expression on the pair with arbitrary capabilities *)
      Section CapabilityPoly.
        Context (c0 c1 : id)
                (t_c1 : has_type Γ φ Σ $c1 ({B | b } ==> {TUnit | ∅ }) $!c1)
                (t_c0 : has_type Γ φ Σ $c0 ({A | a} ==> {TUnit | ∅}) $!c0)
                (t_c1' : forall {Γ φ}, has_type Γ φ Σ $c1 ({B | b } ==> {TUnit | ∅ }) $!c1)
                (t_c0' : forall {Γ φ}, has_type Γ φ Σ $c0 ({A | a} ==> {TUnit | ∅}) $!c0)
                (cl_c0 : closed_qual 0 (‖Γ‖) (‖Σ‖) $!c0)
                (cl_c1 : closed_qual 0 (‖Γ‖) (‖Σ‖) $!c1)
                (c0visible : $!c0 ⊑ φ)
                (c1visible : $!c1 ⊑ φ)
                (c0_overlap: (a ⊔ b ⊔ ∅) ⋒ $!c0 ⊑ (a ⊔ b ⊔ {♦}))
                (c1_overlap: (a ⊔ b ⊔ ∅) ⋒ $!c1 ⊑ (a ⊔ b ⊔ {♦}) )
                (* For simplicity, assume that those capabilities have an empty qualifier.*)
                (sat_c0 : saturated Γ Σ $!c0)
                (sat_c1 : saturated Γ Σ $!c1)
                .

        (** { a => b => c0(a) } *)
        Example use_pair_c0 := (tabs (tabs (tapp $c0 #3))).
        (** { a => b => c1(b) } *)
        Example use_pair_c1 := (tabs (tabs (tapp $c1 #1))).

        Example t_use_pair_c0 : has_type Γ φ Σ use_pair_c0 ({A | a} ==> {{B | b} ==> {TUnit | ∅ } | #!0 ⊔ #!1 }) ($!c0).
          unfold use_pair_c0. apply t_abs; ccrush. auto.
          (* self-type abstraction *)
          apply t_sub with (T1:= ({B | b} ==> {TUnit | ∅})) (d1:=(($!c0 ⊔ $!‖Γ‖) ⊔ $!(S (‖Γ‖)))).
          * assert (Hcl0: closed_qual 0 (S (S (‖Γ‖))) (‖Σ‖) $!c0). eapply closed_qual_monotone; eauto.
            apply t_abs; ccrush.
            change_qual ($♦c0 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖))); ccrush.
            change_qual ($!c0 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖))). auto.
            dep_app ($!c0) ($!(S (‖ Γ ‖))).
            apply t_app with (T1:=A); try solve [ccrush].
            + eapply t_sub. eapply t_c0'.
              apply s_fun; ccrush. apply qs_sq; auto; ccrush.
              apply stp_refl; ccrush. eapply qs_qvar; ccrush. ccrush. auto.
            + eapply t_var; ccrush.
              change_qual ($♦c0 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖)) ⊔ $!(S (S (‖Γ‖))) ⊔ $!(S (S (S (‖Γ‖))))); ccrush.
          * apply stp_refl; crush.
            replace (($!c0 ⊔ $!‖Γ‖) ⊔ $!(S (‖Γ‖))) with ($!(S (‖Γ‖)) ⊔ (($!c0) ⊔ $!‖Γ‖)).
            replace (qset false (union (singleton (‖ Γ ‖)) (singleton (S (‖ Γ ‖)))) {}N {}N) with ($!(S(‖Γ‖)) ⊔ $!‖Γ‖).
            apply qs_cong; crush. eapply qs_self; ccrush. all : ccrush.
          * ccrush.
          * change_qual ($!(‖Γ‖) ⊔ $!(S (‖Γ‖))). auto.
        Qed.

        Example t_use_pair_c1 : has_type Γ φ Σ use_pair_c1 ({A | a} ==> {{B | b} ==> {TUnit | ∅ } | #!0 ⊔ #!1 }) ($!c1).
          unfold use_pair_c1. apply t_abs; ccrush. auto.
          (* self-type abstraction *)
          apply t_sub with (T1:= ({B | b} ==> {TUnit | ∅})) (d1:=(($!c1 ⊔ $!‖Γ‖) ⊔ $!(S (‖Γ‖)))).
          * assert (Hcl1: closed_qual 0 (S (S (‖Γ‖))) (‖Σ‖) $!c1). eapply closed_qual_monotone; eauto.
            apply t_abs; ccrush.
            change_qual ($♦c1 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖))); ccrush.
            change_qual ($!c1 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖))). auto.
            dep_app ($!c1) ($!(S (S (S (‖ Γ ‖))))).
            apply t_app with (T1:=B); try solve [ccrush].
            + eapply t_sub. eapply t_c1'.
              apply s_fun; ccrush. apply qs_sq; auto; ccrush.
              apply stp_refl; ccrush. eapply qs_qvar; ccrush. ccrush. auto.
            + eapply t_var; ccrush.
              change_qual ($♦c1 ⊔ $!(‖Γ‖) ⊔ $!(S (‖Γ‖)) ⊔ $!(S (S (‖Γ‖))) ⊔ $!(S (S (S (‖Γ‖))))); ccrush.
          * apply stp_refl; crush.
            replace (($!c1 ⊔ $!‖Γ‖) ⊔ $!(S (‖Γ‖))) with ($!(S (‖Γ‖)) ⊔ ($!c1 ⊔ $!‖Γ‖)).
            replace (qset false (union (singleton (‖ Γ ‖)) (singleton (S (‖ Γ ‖)))) {}N {}N) with ($!(S(‖Γ‖)) ⊔ $!‖Γ‖).
            apply qs_cong; crush. eapply qs_self; ccrush. all : ccrush.
          * ccrush.
          * change_qual ($!(‖Γ‖) ⊔ $!(S (‖Γ‖))). auto.
        Qed.

        Example elim_pair_c0 : has_type Γ φ Σ (tapp pair_ab use_pair_c0) TUnit (∅).
          dep_app (a ⊔ b ⊔ ∅) ($!c0).
          eapply t_app_fresh with (T1:={A | a} ==> {{B | b} ==> {TUnit | ∅} | #! 0 ⊔ #! 1}) (d1':=$! c0) (df':=a ⊔ b ⊔ ∅); try solve [ccrush].
          * specialize (@pair_intro2 TUnit (∅)) as t_p. unfold TPair2 in t_p.
            eapply t_sub. eapply t_p. 1-5,7,8 : ccrush.
            apply s_fun. ccrush. ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush.
          * apply t_use_pair_c0.
        Qed.

        Example elim_pair_c1 : has_type Γ φ Σ (tapp pair_ab use_pair_c1) TUnit (∅).
          dep_app (a ⊔ b ⊔ ∅) ($!c1).
          eapply t_app_fresh with (T1:={A | a} ==> {{B | b} ==> {TUnit | ∅} | #! 0 ⊔ #! 1}) (d1':=$!c1) (df':=a ⊔ b ⊔ ∅); try solve [ccrush].
          * specialize (@pair_intro2 TUnit (∅)) as t_p. unfold TPair2 in t_p.
            eapply t_sub. eapply t_p. 1-5,7,8 : ccrush.
            apply s_fun. ccrush. ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush. apply qs_sq; ccrush.
            apply stp_refl; ccrush.
          * apply t_use_pair_c1.
        Qed.

      End CapabilityPoly.
    End Pair.

  End Church.

  Section DerivedSyntax.

    (** Sequential composition *)
    Definition seq (t1 t2 : tm): tm := (tapp (tapp (tabs (tabs #1)) t1) t2).

    Lemma t_seq : forall Γ φ Σ t1 T1 q1 t2 T2 q2,
        has_type Γ φ Σ t1 T1 q1 ->
        has_type Γ φ Σ t2 T2 q2 ->
        ♦∉ q1 ->
        ♦∉ q2 ->
        senv_saturated Σ q1 ->
        senv_saturated Σ q2 ->
        has_type Γ φ Σ (seq t1 t2) T2 q2.
      intros. unfold seq.
      dep_app (∅) q2 #!1. apply t_app with (T1:=T2); eauto; ccrush.
      * dep_app (∅) (q1).
        eapply t_app with (T1:=T1); ccrush.
        - apply t_abs; ccrush.
          apply t_abs; ccrush.
          eapply t_var; ccrush.
    Qed.

    (** val/let bindings  *)
    Definition val (t1 t2 : tm): tm := (tapp (tabs t2) t1).

    Lemma t_val : forall Γ φ df Σ t1 T1 q1 t2 T2 q2,
      closed_tm 2 (length Γ) (length Σ) t2 ->
      closed_ty 0 (‖Γ‖) (‖Σ‖) (TFun q1 q2 T1 T2) ->
      closed_qual 2 (length Γ) (length Σ) q2 ->
      closed_qual 0 (length Γ) (length Σ) df ->
      has_type Γ φ Σ t1 T1 q1 ->
      df ⊑ φ ->
      (q2 <~ᵈ ∅ ; ∅) ⊑ φ ->
      ♦∉ df ->
      ♦∉ q1 ->
      (* senv_saturated Γ Σ q1 -> *)
      senv_saturated Σ df ->
      senv_saturated Σ (q2 <~ᵈ ∅ ; ∅) ->
      not_free 0 T2 ->
      has_type ((false, T1, q1) :: (true, {T1 | q1} ==> {T2 | q2}, df):: Γ) (df ⊔ $!(S (length Γ)) ⊔ {♦}) Σ (open_tm' Γ t2) (open_ty' Γ T2) (openq' Γ q2) ->
      has_type Γ φ Σ (val t1 t2) (T2 <~ᵀ ∅ ; q1) (q2 <~ᵈ df ; q1).
      intros. unfold val. specialize (has_type_closed H3). intuition.
      eapply t_app; eauto; crush.
      apply t_abs; ccrush.
      unfold_open in H11.
      eapply @weaken_flt with (φ:=df ⊔ $! (S (length Γ)) ⊔ {♦}); ccrush.
    Qed.

    Lemma t_val_fresh : forall Γ φ df Σ t1 T1 q1 t2 T2 q2,
      closed_tm 2 (length Γ) (length Σ) t2 ->
      closed_ty 0 (‖Γ‖) (‖Σ‖) (TFun q1 q2 T1 T2) ->
      closed_qual 2 (length Γ) (length Σ) q2 ->
      closed_qual 0 (length Γ) (length Σ) df ->
      has_type Γ φ Σ t1 T1 q1 ->
      df ⊑ φ ->
      (q2 <~ᵈ ∅ ; ∅) ⊑ φ ->
      ♦∉ df ->
      saturated Γ Σ df ->
      saturated Γ Σ q1 ->
      senv_saturated Σ (q2 <~ᵈ ∅ ; ∅) ->
      not_free 0 T2 ->
      (♦∈ q1 -> not_free 1 T2) ->
      has_type ((false, T1, df ⋒ q1) :: (true, {T1 | df ⋒ q1} ==> {T2 | q2}, df):: Γ) (df ⊔ $!(S (length Γ)) ⊔ {♦}) Σ (open_tm' Γ t2) (open_ty' Γ T2) (openq' Γ q2) ->
      has_type Γ φ Σ (val t1 t2) (T2 <~ᵀ ∅ ; q1) (q2 <~ᵈ df ; q1).
      intros. unfold val. specialize (has_type_closed H3). intuition.
      eapply t_app_fresh with (d1':=q1) (df':=df); eauto; ccrush.
      apply t_abs; ccrush. constructor; ccrush. inversion H0; subst. auto. inversion H7. auto.
      unfold_open in H12.
      eapply @weaken_flt with (φ:=df ⊔ $! (S (length Γ)) ⊔ {♦}); ccrush. eapply has_type_filter; eauto.
    Qed.

    Lemma open_val : forall {k t t1 t2}, open_rec_tm k t (val t1 t2) = (val (open_rec_tm k t t1) (open_rec_tm (S (S k)) t t2)).
      intros. unfold val. simpl. auto.
    Qed.

  End DerivedSyntax.

  Section Closures.
    (* { val y = new Ref(unit); { x => y } } *)
    Example escaping_closure := (tapp (tabs (tabs #3)) (tref tunit)).

    (* The type of the let binding's body:
        (val y = _; { x => y }) :: (y : Ref[Unit^{}]^{}) => f(Unit => Ref[Unit^{}]^f)^y
     *)
    Example esc_ty_let : has_type [] {♦} [] (tabs (tabs #3)) ({TRef ∅ TUnit | {♦}} ==> { {TUnit | ∅}  ==> {TRef ∅ TUnit | #!0 } | #! 1}) ∅.
      apply t_abs; ccrush. repeat (constructor; ccrush).
      apply t_abs; ccrush. repeat (constructor; ccrush).
      eapply t_sub with (d1:=$!1 ⊔ $!2).
      * eapply t_sub. eapply t_var; ccrush.
        eapply stp_refl; ccrush. eapply qs_sq; ccrush. ccrush. eauto.
      * apply stp_refl; crush.
        eapply qs_self; ccrush.
      * ccrush.
      * ccrush.
    Qed.

    (* escaping_closure :: f(Unit => Ref[Unit]^f)^{} *)
    Example esc_ty : has_type [] {♦} [] escaping_closure ({TUnit | ∅}  ==> {TRef ∅ TUnit | #!0}) {♦}.
      unfold escaping_closure. dep_app (∅) ({♦} ⊔ ∅) #!1.
      eapply t_app_fresh with (T1:=TRef ∅ TUnit) (d1':={♦}) (df':=∅); crush.
      * cleanup. apply esc_ty_let.
      * eapply t_ref; ccrush.
      * ccrush.
      * ccrush.
    Qed.

  End Closures.

  Section ScopedCapabilities.

    Section TryCatch.
      (** Assume a Nothing type, a.k.a. the empty type, being a subtype of all types: *)
      Variable (Nothing : ty).
      Context (s_nothing : forall Γ Σ T q1 q2, qstp Γ Σ q1 q2 -> stp Γ Σ Nothing q1 T q2)
              (cl_nothing : closed_ty 0 0 0 Nothing).
      (** Assume an effects as capabilities model. The capability type for throwing (Unit-valued) exceptions is a function Unit => Nothing: *)
      Context (CanThrow := {TUnit | ∅} ==> {Nothing | ∅})
              (cl_canthrow : closed_ty 0 0 0 CanThrow).
      (** Assume we can allocate fresh capabilities for throwing exceptions: *)
      Variable (mkThrow : tm).
      Context (t_mkThrow : forall Γ φ Σ, closed_qual 0 (length Γ) (length Σ) φ -> has_type Γ φ Σ mkThrow CanThrow ∅).

      (** The try combinator, this one allocates a fresh capability and passes it to the given block:
            def try_(block) = val throw = mkThrow; block(throw)
      *)
      Example try_ := (tabs (val mkThrow (tapp #3 #1))).

      (** The type of the try combinator, encoding polymorphism as metalevel quantification.
              try : forall A. ((CanThrow^♦ => A^a)^♦ => A^a)^∅
        *)
      Example try_ty : forall A a Γ φ Σ,
          closed_qual 0 (length Γ) (length Σ) φ ->
          closed_ty 0 (length Γ) (length Σ) A ->
          closed_qual 0 (length Γ) (length Σ) a ->
          saturated Γ Σ a ->
          a ⊑ φ -> ♦∉ a ->
          has_type Γ φ Σ try_ ({{CanThrow | {♦} } ==> {A | a} | {♦} } ==> {A | a}) a.
        intros. unfold try_. specialize (t_mkThrow _ _ _ H) as H'.
        apply t_abs; ccrush.
        dep_app (a ⊔ $!(S (‖Γ‖))) (∅).
        eapply t_val with (T1:=CanThrow); try solve [ccrush].
        * apply t_mkThrow; ccrush.
        * apply saturated_senv_qlub; ccrush.
        * cleanup. dep_app ($!(S (‖Γ‖))) ($!(S (S (S (‖Γ‖))))).
          eapply t_app_fresh
          with (T1:=CanThrow) (d1':= $! (S (S (S (‖ Γ ‖))))) (df' := $! (S (‖ Γ ‖)) ⊔ {♦}); ccrush.
          - eapply t_var; ccrush.
          - eapply t_var; ccrush.
      Qed.

      Variable (Σ : senv).
      Context (c1 := 0) (Γ := [((false,TRef ∅ TUnit),∅)]).
      (** This block
            { throw => !c1 ; throw () }
        demonstrates a legal use of capabilities. *)
      Example nonescaping := (tabs (seq !($c1) (tapp #1 tunit))).

      (** Using the nonescaping block with try is indeed well-typed. *)
      Example nonescaping_ok : has_type Γ $!c1 Σ (tapp try_ nonescaping) TUnit ∅.
        unfold nonescaping. subst c1.
        dep_app (∅) ($!0).
        assert (Hf : closed_qual 0 (length Γ) (length Σ) $!0); crush. apply t_mkThrow in Hf.
        eapply t_app_fresh with (d1':=$!0) (df':=∅); ccrush.
        * eapply try_ty; ccrush.
        * subst Γ. apply t_abs; ccrush.
          apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
          + apply t_deref with (d:=$!0); ccrush.
            eapply t_var; ccrush.
          + apply t_sub with (T1:=Nothing) (d1:=∅); ccrush.
            dep_app ($!2) (∅).
            eapply t_app with (T1:=TUnit); ccrush.
            - subst CanThrow. eapply t_var; ccrush.
            - apply t_base; ccrush.
      Qed.

      (** In contrast, this block
              { throw => !c1 ; { () => throw () } }
        returns a closure over the capability, which is rejected by try. *)
      Example escaping := (tabs (seq !($c1) (tabs (tapp #3 tunit)))).
      (** First, the type of escaping indeed leaks the capability:
              escaping : ((c: CanThrow^{♦}) => (Unit => Unit)^{c})^{c1}
        *)
      Example escaping_ty : has_type Γ $!c1 Σ escaping ({CanThrow | {♦}} ==> {{TUnit | ∅} ==> {TUnit | ∅} | #!1}) $!c1.
        unfold escaping. subst c1. subst Γ.
        apply t_abs; ccrush.
        apply t_seq with (T1:=TUnit) (q1:=∅); ccrush.
        * apply t_deref with (d:=$!0); ccrush.
          eapply t_var; ccrush.
        * apply t_abs; ccrush.
          apply t_sub with (T1:=Nothing) (d1:=∅); ccrush.
          dep_app ($!2) (∅).
          eapply t_app with (T1:=TUnit); ccrush.
          - subst CanThrow. eapply t_var; ccrush.
          - apply t_base; ccrush.
        Qed.
      (** Now suppose we could type the following application: *)
      Example escaping_bad : exists S q, has_type Γ $!c1 Σ (tapp try_ escaping) S q.
        eexists. eexists. eapply t_app_fresh with (df:=∅). 4: eapply escaping_ty. cleanup.
        * (* We have a typing mismatch: *)
          (* suppose we can pick those qualifiers so that they don't overlap *)
          dom_equals ({♦}). admit.
          Fail eapply try_ty.
          (* try_ requires that the block `escaping` returns a disjoint function, but the type of `escaping` is
            dependent on its capability argument.  *)
      Abort.
    End TryCatch.

    Section Borrowing.
      (**
          borrow[A^a,B^b] : ((x : A^a) => ((block: (A^a => B^b)^♦) => B^b)^{x,a,b})^a,b
      *)
      Example borrow := (tabs (tabs (tapp #1 #3))).
      Example TBorrow A a B b := ({A | a} ==> {{{A | a} ==> {B | b} | {♦}} ==> {B | b} | a ⊔ b ⊔ #!1}).
      Example t_borrow : forall {Γ φ Σ A a B b},
        closed_qual 0 (length Γ) (length Σ) φ ->
        closed_ty 0 (length Γ) (length Σ) A ->
        closed_qual 0 (length Γ) (length Σ) a ->
        senv_saturated Σ a -> ♦∉ a -> a ⊑ φ ->
        closed_ty 0 (length Γ) (length Σ) B ->
        closed_qual 0 (length Γ) (length Σ) b ->
        senv_saturated Σ b -> ♦∉ b -> b ⊑ φ ->
        has_type Γ φ Σ borrow (TBorrow A a B b) (a ⊔ b).
        intros. unfold borrow. unfold TBorrow.
        apply t_abs; ccrush. eauto.
        apply t_abs; ccrush. eauto.
        dep_app $!(S (S (S (length Γ)))) a.
        eapply t_app with (T1:=A); ccrush.
        * eapply t_var; ccrush.
        * eapply t_sub; ccrush. eapply t_var; ccrush.
          apply stp_refl; ccrush.
          eapply qs_qvar; ccrush.
      Qed.

      (* Γ = c1 : Ref[Unit]^{c1} *)
      Context (c1 := 0)
              (Γ := [(false, TRef ∅ TUnit, ∅)])
              (φ := $!c1)
              (Σ : senv).

      (** An OK use of borrow:
              borrow(c1) { c2 => !c2 }
        *)
      Example borrow_ok  := (tapp (tapp borrow $c1) (tabs !(#1))).
      Example borrow_ok_ty : has_type Γ φ Σ borrow_ok TUnit ∅.
        unfold borrow_ok. subst c1. subst Γ. subst φ.
        dep_app (∅ ⊔ ∅) (∅).
        eapply t_app_fresh with (T1:=({(TRef ∅ TUnit) | ∅} ==> {TUnit | ∅})) (df':=∅ ⊔ ∅) (d1':=∅); ccrush.
        * dep_app (∅ ⊔ ∅) (∅) (∅ ⊔ ∅ ⊔ #!1).
          apply t_app with (T1:=(TRef ∅ TUnit)); crush.
          + apply t_borrow; ccrush.
          + eapply t_sub. eapply t_var; ccrush. all : eauto.
            apply stp_refl; ccrush. eapply qs_qvar; ccrush.
          + ccrush.
        * apply t_abs; ccrush.
          eapply t_deref; ccrush.
          eapply t_var; ccrush.
      Qed.

      (** A bad use of borrow:
              borrow(c1) { c2 => !c1 } // error c1 not directly accessible
        *)
      Example borrow_bad := (tapp (tapp borrow $c1) (tabs !($c1))).
      (* first, consider the type of the block : *)
      Example borrow_bad_block_ty : has_type Γ φ Σ (tabs !($c1)) ({TRef ∅ TUnit | ∅} ==> {TUnit | ∅}) $!c1.
        subst c1. subst Γ. subst φ.
        apply t_abs; ccrush.
        eapply t_deref; ccrush.
        eapply t_var; ccrush.
      Qed.
      (* now suppose this is typable: *)
      Example borrow_bad_ty : exists S q, has_type Γ φ Σ borrow_bad S q.
        eexists. eexists. unfold borrow_bad.
        (* both the function and argument of the application alias c1... *)
        apply t_app_fresh with (T1:={(TRef ∅ TUnit) | ∅} ==> {TUnit | ∅}) (df':=$!c1) (d1':=$!c1). (* ... which means the block function expected by borrow(c1) must alias c1 too *)
        4 : eapply borrow_bad_block_ty. cleanup.
        (* Borrow's type requires that the block is separate having just the {♦} qualifier, but the current type
           demands the qualifier {♦,c1} (overlap with c1 allowed). We also cannot use subsumption to shrink this to {♦}, due to the negative occurrence.
           Hence, we are stuck. *)
      Abort.

    End Borrowing.

  End ScopedCapabilities.

End QPoly.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finfun finset bigop.
Require Import Reals Fourier.
Require Import Reals_ext log2 ssr_ext Rbigop proba entropy Rssr ceiling divergence log_sum v_source_code uniquely_decodable.

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

Local Open Scope tuple_ext_scope.
Local Open Scope proba_scope.
Local Open Scope reals_ext_scope.
Local Open Scope entropy_scope.
Local Open Scope divergence_scope.

(* post compose *)

Section log_sum_ord.
Variable A : finType.
Variable n: nat.
Variable f g: nat -> R+.
Hypothesis f_dom_by_g : f << g.

Lemma log_sum_inequality_ord_add1:
  \rsum_(i| i \in 'I_n) f i.+1 * (log (f i.+1 / g i.+1)) >=
  (\rsum_(i| i \in 'I_n) f i.+1) * (log ((\rsum_(i| i \in 'I_n) f i.+1) / (\rsum_(i| i \in 'I_n) g i.+1))).
Proof.
have Rle0f_add1: forall (x : [finType of 'I_n]), 0 <= f x.+1 by move=> ?; apply:(Rle0f f).
have Rle0g_add1: forall (x : [finType of 'I_n]), 0 <= g x.+1 by move=> ?; apply:(Rle0f g).
have f_dom_by_g1 : (mkPosFun Rle0f_add1) << (mkPosFun Rle0g_add1).
  by rewrite /dom_by=>?; apply:f_dom_by_g.
have H:forall h, \rsum_(a | a \in [set: 'I_n]) h a.+1 = \rsum_(a | a \in  'I_n) h a.+1.
  by move=>?; apply:eq_bigl=>?; rewrite in_setT.
rewrite -!H -(H (fun i => f i * log (f i / g i))); apply: Rle_ge.
apply: (log_sum [set: 'I_n] (mkPosFun Rle0f_add1) (mkPosFun Rle0g_add1) f_dom_by_g1).
Qed.

Lemma log_sum_inequality_ord_add1':
  \rsum_(i| i \in 'I_n) f i.+1 * (log (f i.+1) - log (g i.+1)) >=
  (\rsum_(i| i \in 'I_n) f i.+1) * (log (\rsum_(i| i \in 'I_n) f i.+1) - log (\rsum_(i| i \in 'I_n) g i.+1)).
Proof.
rewrite [X in X >= _](_ : _ = \rsum_(i | i \in 'I_n) f i.+1 * log (f i.+1 / (g i.+1))).
  rewrite [X in _ >= X](_ : _ =  (\rsum_(i | i \in 'I_n) f i.+1) *
   (log ((\rsum_(i | i \in 'I_n)f i.+1) / (\rsum_(i | i \in 'I_n) g i.+1)))).
      by apply: log_sum_inequality_ord_add1.
  have :0 <= \rsum_(i | i \in 'I_n) f i.+1 by apply: Rle_big_0_P_g=>i _; apply: Rle0f.
  case=>[Hf | <-]; last by rewrite !mul0R.
  have : 0 <= \rsum_(i | i \in 'I_n) g i.+1 by apply: Rle_big_0_P_g=>i _; apply: Rle0f.
  case=>[Hg |].
    rewrite log_mult//; last by apply: Rinv_0_lt_compat.
    by rewrite log_Rinv.
  have Rle0g_add1: forall (x : ordinal_finType n), 0 <= g x.+1 by move=> ?; apply:(Rle0f g).
  move/(Req_0_rmul_inv (fun i => i \in 'I_n) _ Rle0g_add1)=>eq_g_0.
  have : 0 = \rsum_(i | i \in 'I_n) f i.+1.
    by apply:Req_0_rmul=>i _; apply:esym; apply: (@f_dom_by_g i.+1); rewrite -eq_g_0.
  by move=>tmp; move:Hf; rewrite -tmp; move/Rlt_not_eq.
apply: eq_bigr=>i _.
case:(Rle0f f i.+1)=>[fpos|<-]; last by rewrite !mul0R.
  case:(Rle0f g i.+1)=>[gpos|]; last by  move/esym/(@f_dom_by_g i.+1)->; rewrite !mul0R.
  rewrite log_mult//; last by apply: Rinv_0_lt_compat.
  by rewrite log_Rinv.
Qed.

End log_sum_ord.

Section Ordinal.
Variable T : finType.
Variable f : T -> nat.

Definition inordf t := inord (f t) : [finType of 'I_(\max_t f t).+1].

Lemma inordfE:  (fun t : T => nat_of_ord (inordf t)) =1 f .
Proof.
move=>t.
rewrite /inordf.
apply: inordK; by apply: leq_bigmax.
Qed.

End Ordinal.
Prenex Implicits inordf.

Section Big_pow.
End Big_pow.

Section Bigop_Lemma.
Variable A : finType.

Lemma rsum_mulRC (h : A -> R) g P: \rsum_(i| P i) h i * g i = \rsum_(i| P i) g i * h i.
Proof.
by apply: eq_bigr=>? _; rewrite mulRC.
Qed.

Variable P : dist A.
Variable n : nat.
Variable f : A -> seq bool.
Hypothesis f_inj : injective f.

Lemma big_seq_tuple (F : seq bool -> R): (0 < #|A|)%nat ->
  \big[Rplus/0]_(i <- [seq f i | i <- index_enum A] | size i == n) F i =
  \big[Rplus/0]_(i : n.-tuple bool | tval i \in codom f) F i.
Proof.
move Hpick : [pick x | x \in [set: A] ] => p Anon0.
move: Hpick; case: (pickP _)=>[defaultA _ _ | abs]; last first.
  suff : False by [].
  move:Anon0.
  rewrite -cardsT card_gt0; case/set0Pn => ?.
  by rewrite abs.
rewrite big_map.
 pose dummy := [tuple of nseq n false].
 pose h (i : n.-tuple bool) := odflt defaultA [pick a | f a == i].
 pose h' a : n.-tuple bool := insubd dummy (f a).
 have H a : odflt defaultA [pick a0 | f a0 == f a ] = a.
 - case: pickP => /=; last by move/(_ a); rewrite eqxx.
   by move => a0 /eqP /f_inj ->.
 - rewrite (reindex_onto h h'); last first.
   + move => a sizefa. rewrite /h' /h insubdK //.
   + apply: esym.
     apply: eq_big => i; last by move/codomP => [a fa]; rewrite /h fa H.
     apply/idP/andP.
     * move/codomP => [a fa]. rewrite /h fa H.
       split; first by rewrite -fa size_tuple eqxx.
       by rewrite /h' -fa valKd.
     * rewrite /h /h' => [] [sizefhi /eqP <-]; rewrite insubdK //.
       exact: codom_f.
Qed.

Lemma big_seq_tuple' (F : seq bool -> R): (0 < #|A|)%nat ->
  (forall i, F i = if i \in codom f then F i else 0)->
  \big[Rplus/0]_(i in {: n.-tuple bool}) F i =
  \big[Rplus/0]_(i| size (f i) == n) F (f i).
Proof.
move=>Anon0 Fi0.
rewrite -(big_map f (fun i0 => size i0 == n) (fun x => F x)) /=.
rewrite big_seq_tuple //.
rewrite (eq_bigr (fun a => if (tval a \in codom f) then F a else 0))=>[|i _].
  rewrite -big_mkcondr/=.
  by apply: eq_bigl=>//.
case:ifP=>//.
by rewrite Fi0; move->.
Qed.

Lemma big_ord_exclude0 (h:nat -> R): h 0%nat = 0 ->
    \rsum_(i | i \in 'I_n.+1) h i = \rsum_(i | i \in 'I_n) h i.+1.
Proof.
move=>H.
rewrite -(big_mkord xpredT _) -(big_mkord xpredT (fun i => h i.+1)).
by rewrite big_ltn// H add0R big_add1.
Qed.

Variable x : R.
Hypothesis neq_x_1 : x <> 1.

Lemma big_pow1 : \rsum_(i | i \in 'I_n) x ^ i.+1 = x * (1 - (x ^ n)) / (1 - x).
Proof.
apply: (Rplus_eq_reg_l 1).
rewrite /Rdiv {1}[in RHS](Rinv_r_sym (1 - x)); last by apply:Rminus_eq_contra; apply: nesym.
rewrite Rmult_plus_distr_l mulR1 -Rmult_plus_distr_r addRA /Rminus [in RHS]addRC -addRA.
rewrite Rplus_opp_l addR0 (addRC _ 1) Ropp_mult_distr_r_reverse.
rewrite -(big_mkord xpredT (fun i => x ^ i.+1)) (_ : n = n.+1.-1) //.
rewrite -(big_add1 _ _ _ _  xpredT)-{1}(pow_O x) -big_ltn//.
by rewrite big_mkord -sum_f_R0_rsum tech3.
Qed.

Lemma log_pow r: 0 < r -> log (r ^ n) = (INR n) * log r.
Proof.
elim:n=> [|n' IH lt_0_r]; first by rewrite log_1 mul0R.
rewrite log_mult//;last by apply:pow_lt.
by rewrite IH // -addn1 addRC plus_INR Rmult_plus_distr_r mul1R.
Qed.

End Bigop_Lemma.

Section Entropy_lemma.

Variable A : finType.
Variable P : dist A.
Variable n : nat.

Lemma entropy_TupleDist : `H (P `^ n) = (INR n) * `H P.
Proof.
elim:n=>[|n0 IH].
  rewrite /entropy /= /TupleDist.f rsum_0tuple /=.
  by rewrite big_ord0 log_1 mulR0 mul0R Ropp_0.
rewrite S_INR Rmult_plus_distr_r mul1R -IH.
rewrite /entropy -big_head_behead /= /TupleDist.f /=.
rewrite -Ropp_plus_distr; apply:Ropp_eq_compat.
rewrite [X in X = _](_ :_ = \rsum_(i | i \in A) P i * log (P i) *
          (\rsum_(j in {: n0.-tuple A}) (\rmul_(i0<n0) P j \_ i0)) +
           \rsum_(i | i \in A) P i * \rsum_(j in {: n0.-tuple A})
          (\rmul_(i0<n0) P j \_ i0) * log (\rmul_(i0<n0) P j \_ i0)); last first.
  rewrite -big_split /=.
  apply:eq_bigr=> i _.
  rewrite -mulRA -Rmult_plus_distr_l (mulRC (log (P i))) (big_distrl (log (P i)) _ _) /=.
  rewrite -big_split /= big_distrr/=.
  apply: eq_bigr=>i0 _.
  rewrite big_ord_recl tnth0 -mulRA.
  case:(Rle0f P i)=>[ pi_pos| <-]; last by rewrite !mul0R.
  apply:Rmult_eq_compat_l.
  rewrite -Rmult_plus_distr_l.
  rewrite  (@eq_bigr _ _ _ _ _ _ (fun x => P [tuple of i :: i0] \_ (lift ord0 x)) (fun x => P i0 \_ x))=>[|i1 _]; last first.
    by rewrite (tnth_nth (tnth_default i0 i1)) /tnth lift0 /=.
  case: (Req_dec 0 (\rmul_(i'<n0) P i0 \_ i'))=>[<-|rmul_non0].
    by rewrite !mul0R.
  have rmul_pos: 0 < \rmul_(i1<n0) P i0 \_ i1.
    apply:Rlt_le_neq=>//.
    by apply:Rle_0_big_mult=>?; apply:Rle0f.
  by rewrite log_mult // !Rmult_plus_distr_l mulRA mulRA.
rewrite TupleDist.f1 -big_distrl /= mulR1 [in RHS]addRC.
apply:Rplus_eq_compat_l.
by rewrite -big_distrl/= pmf1 mul1R.
Qed.

End Entropy_lemma.

Section le_entroPN_logeEX.

Variable (A : finType) (P : dist A) (f : A -> seq bool).
Let X := mkRvar P (INR \o size \o f).
Definition Nmax := (\max_(a| a \in A) size (f a)).
Definition I_lmax := [finType of 'I_Nmax.+1].
Hypothesis f_uniq : uniquely_decodable f.

Lemma Xnon0 x : 0 <> X x.
Proof.
rewrite /X/=; case:(Req_dec 0 (INR (size (f x))))=>// H.
move:H; rewrite (_ : 0 = INR 0)//; move/INR_eq.
move/esym /size0nil=>fx_nil.
move:(@f_uniq [::] ([:: x])).
rewrite /extension /= fx_nil cat0s=>H.
have nil: [::] = [::] by[].
by move:(H (nil bool)).
Qed.

Lemma Xpos a: 0 < X a.
Proof.
move/nesym/INR_not_0:(@Xnon0 a)=>H.
apply: lt_0_INR; apply/ltP.
move:(leq0n (size (f a))); rewrite /X/= leq_eqVlt.
by move=>tmp; move:tmp H; case/orP=>// /eqP ->.
Qed.

Lemma Rle0Pr (i : I_lmax) : 0 <= Pr[X = (INR i)]. Proof. by apply:le_0_Pr. Qed.

Definition pmfN := mkPosFun Rle0Pr.

Lemma pmf1N : \rsum_(i | i \in I_lmax) pmfN i = 1.
Proof.
rewrite -(pmf1 P).
rewrite [in RHS](partition_big (inordf (size \o f)) (fun i => i \in I_lmax)) //=.
apply:eq_bigr=> i _; apply:eq_bigl=>i0.
rewrite /= inE.
apply/eqP/eqP=>[/INR_eq H|<-]; last by rewrite inordfE.
apply: ord_inj.
by rewrite -H inordfE.
Qed.

Definition PN := mkDist pmf1N.

Lemma EX_ord : `E X = \rsum_(i | i \in I_lmax) (INR i) * PN i.
Proof.
rewrite /E_leng_cw/Ex_alt (partition_big (inordf (size \o f)) (fun i => i \in I_lmax)) //=.
apply:eq_bigr=> i _.
rewrite /@pr /Pr mulRC big_distrl /=.
rewrite [in RHS]rsum_mulRC.
apply: congr_big=>[//| x| x]; last by move/eqP<-; rewrite inordfE.
rewrite inE; apply/eqP/eqP; first by move<-; rewrite inordfE.
by move/INR_eq=>H; apply: ord_inj; rewrite -H inordfE.
Qed.

Lemma le_1_EX : 1 <= `E X.
Proof.
rewrite -(pmf1 P).
apply:Rle_big_P_f_g=>i _.
rewrite -{1}(mul1R ( P i)).
apply:Rmult_le_compat_r; first by apply:Rle0f.
rewrite (_ : 1 = INR 1) //; move: (Xpos i).
by rewrite /= (_ : 0 = INR 0)//; move/INR_lt/lt_le_S/le_INR.
Qed.

Lemma EX_pos: 0 < `E X.
Proof. by apply:(Rlt_le_trans _ _ _ Rlt_0_1 le_1_EX). Qed.

Lemma EX_non0: `E X  <> 0.
Proof. by apply:nesym; apply:Rlt_not_eq; apply: EX_pos. Qed.

Lemma entroPN_0 : `E X  = 1 -> `H PN = 0.
Proof.
move=>EX_1.
have eq_0_P: forall a, X a <> 1 -> 0 = P a.
  move:EX_1.
  rewrite /Ex_alt /= -{1}(pmf1 P)=>EX1 a Xnon1.
  have : forall i : A, i \in A -> P i <= INR (size (f i)) * P i.
    move=> i _; rewrite -{1}(mul1R ( P i)).
    apply:Rmult_le_compat_r; first apply:Rle0f.
    rewrite (_ : 1 = INR 1) //; move: (Xpos i); rewrite /= (_ : 0 = INR 0) //.
    by move/INR_lt/lt_le_S/le_INR.
  move/Rle_big_eq=>H.
  case: (Req_dec (P a) 0)=>//.
  have: INR (size (f a)) * P a = P a by rewrite (H EX1 a).
  rewrite -{2}(mul1R (P a)).
  by move/Rmult_eq_reg_r=>tmp /tmp.
rewrite /entropy Ropp_eq_0_compat //.
rewrite {2}(Req_0_rmul (fun i => i \in I_lmax) (fun i => 0))//.
apply:eq_bigr=> i _; rewrite /= /@pr /Pr.
case (Req_dec (INR i) 1)=>[->| neq0].
  rewrite [X in _ * log X = _](_ : _ = 1); first by rewrite log_1 mulR0.
  rewrite -{2}(pmf1 P).
  rewrite [in RHS](bigID (fun a => a \in [set x | INR (size (f x)) == 1])) /=.
  rewrite [X in _ = _ + X](_ : _ = 0); first by rewrite addR0.
  apply: esym; apply: Req_0_rmul=>j.
  rewrite inE; move/eqP.
  by apply: (eq_0_P j).
rewrite [X in X * _ = _](_ : _ = 0); first by rewrite mul0R.
apply: esym; apply:Req_0_rmul=>j.
rewrite inE; move/eqP=>eq_Xj_i.
move:neq0; rewrite -eq_Xj_i.
by apply: (eq_0_P j).
Qed.

Lemma le_entroPN_logeEX':
  `H PN <= `E X  * log (`E X ) - (`E X  - 1) * log((`E X ) -1).
Proof.
move: EX_pos EX_non0=>EX_pos EX_non0.
move/Rle_lt_or_eq_dec:le_1_EX=>[lt_EX_1| eq_E_0]; last first.
  rewrite -eq_E_0 /Rminus Rplus_opp_r mul0R Ropp_0 addR0 mul1R log_1.
  by move/esym/entroPN_0:eq_E_0->; apply:Rle_refl.
have lt_0_EX_1 : 0 < `E X  - 1.
  apply:(Rplus_lt_reg_r 1).
  by rewrite addR0 addRC -addRA Rplus_opp_l addR0.
pose alp := (`E X  - 1) / `E X .
have gt_alp_1 : alp < 1.
    apply:(Rmult_lt_reg_r (`E X )); first by apply:(Rlt_trans _ _ _ (Rlt_0_1)).
    rewrite /alp mul1R -mulRA -Rinv_l_sym // mulR1.
    by apply:Rgt_lt; apply:(tech_Rgt_minus _ _ (Rlt_0_1)).
have lt_0_alp : 0 < alp.
  rewrite /alp.
  by apply:Rlt_mult_inv_pos=>//.
have EX_pos' : 0 < 1 - (`E X  - 1) * / `E X .
  rewrite Rmult_plus_distr_r -Rinv_r_sym // Ropp_mult_distr_l_reverse mul1R /Rminus.
  rewrite Ropp_plus_distr addRA Ropp_involutive addRC Rplus_opp_r addR0.
  by apply: Rinv_0_lt_compat.
have max_pos: (0 < \max_(a in A) size (f a))%coq_nat.
  apply:ltP.
  move/card_gt0P:(dist_support_not_empty P)=>[a _].
  apply:(bigmax_sup a)=> //.
  by move:(Xpos a); rewrite /X /= (_ : 0 = INR 0)//;move/INR_lt/ltP.

rewrite [X in _ <= X](_ :_ = log ( alp / (1 - alp)) - (log alp) * `E X ); last first.
  rewrite /alp /Rdiv !log_mult  //; last first.
      by apply: Rinv_0_lt_compat.
    by apply: Rinv_0_lt_compat.
  rewrite !log_Rinv //.
  rewrite Rmult_plus_distr_r /Rminus [in RHS]addRC (addRC _ (- log (`E X ) * `E X )).
  rewrite Ropp_plus_distr !Ropp_mult_distr_l_reverse Ropp_involutive mulRC -addRA.
  apply: Rplus_eq_compat_l.
  rewrite Rmult_plus_distr_r mulRC Ropp_plus_distr -Ropp_mult_distr_l_reverse.
  apply: Rplus_eq_compat_l.
  rewrite Ropp_mult_distr_l_reverse Ropp_involutive mul1R -addRA -{1}(addR0 (log (`E X  + -1))).
  apply: Rplus_eq_compat_l.
  rewrite Rmult_plus_distr_r -Rinv_r_sym // Ropp_mult_distr_l_reverse mul1R.
  rewrite  Ropp_plus_distr Ropp_involutive (addRC 1 _) (addRC (-1) _).
  by rewrite -addRA Rplus_opp_l addR0 log_Rinv //Ropp_involutive Rplus_opp_l.

apply:(Rle_trans _  (log (alp * (1 - (alp ^ (\max_(a| a \in A) size (f a)))) / (1 - alp))
                     - log alp * `E X ) _); last first.
  apply:Rplus_le_compat_r.
  apply:log_increasing_le.
    apply:Rmult_lt_0_compat; last by  apply: Rinv_0_lt_compat ; apply:Rgt_lt; apply:Rgt_minus.
    apply:Rmult_lt_0_compat=> //.
    apply:Rgt_lt; apply:Rgt_minus; apply:Rlt_gt.
    have : 0 <= alp < 1 by apply:conj=> //; first apply:Rlt_le.
     by move/(pow_lt_1_compat _ _ ):max_pos=>tmp; move/tmp/proj2.
  rewrite /Rdiv -mulRA.
  apply:Rmult_le_compat_l; first by apply:Rlt_le.
  rewrite -{2}(mul1R (/ (1 - alp))) ; apply:Rmult_le_compat_r.
    by apply:Rlt_le; apply:Rinv_0_lt_compat; apply:Rgt_lt; apply:Rgt_minus; apply:Rlt_gt.
  rewrite -{2}(addR0 1) /Rminus; apply:Rplus_le_compat; first by apply:Rle_refl.
  apply:Rge_le; apply:Ropp_0_le_ge_contravar.
  by apply:pow_le; apply:Rlt_le.

rewrite EX_ord -big_pow1; last by apply:Rlt_not_eq.
rewrite mulRC (big_morph _ (morph_mulRDl _) (mul0R _)).
apply:(Rplus_le_reg_r (\rsum_(i|i \in I_lmax) INR i * Pr[X = (INR i)] * log alp)).
rewrite -addRA Rplus_opp_l addR0.
rewrite  (@eq_bigr _ _ _ I_lmax _ _ _ (fun i => Pr[X = (INR i)] * log (alp ^ i))); last first.
  by move=> i _; rewrite log_pow // [in RHS]mulRC -mulRA (mulRC _ (log alp)) mulRA.
rewrite /entropy addRC; move:Ropp_minus_distr; rewrite/Rminus; move<-.
rewrite -(Ropp_involutive (log _)).
apply:Ropp_le_contravar; apply:Rge_le.
rewrite (big_morph _ morph_Ropp Ropp_0).
rewrite -big_split /=.
rewrite [X in X >= _](_ : _ =  \rsum_(i|i\in I_lmax)
      Pr[X = (INR i)] * (log Pr[X = (INR i)] - log (alp ^ i))); last first.
  by apply:eq_bigr=>i _; rewrite Rmult_plus_distr_l Ropp_mult_distr_r_reverse.
rewrite -Rminus_0_l -(mul1R (0 - _)).

have pmf1': \rsum_(i | i\in 'I_(\max_(a in A) size (f a))) Pr[X = (INR i.+1)] = 1.
  rewrite -pmf1N /=.
  rewrite (@big_ord_exclude0 _ (fun x => Pr[X = (INR x)])); first by[].
  apply:esym; apply:Req_0_rmul=> i.
  rewrite inE; move/eqP=> Xi_0.
  by move/Rlt_not_eq:(Xpos i); rewrite Xi_0.
rewrite -{2}log_1 -pmf1'.
have Rle0Pr (i : nat): 0 <= Pr[X = (INR i)] by apply:Rle_big_0_P_g=>? _;  apply:(Rle0f P).
have Rle0alpi (i : nat): 0 <= alp ^ i by apply:pow_le; apply:Rlt_le.
pose h := mkPosFun Rle0Pr.
pose g := mkPosFun Rle0alpi.
have dom_by_hg:  h << g.
  move=> i; move/pow0_inv=>alp0.
  by move:lt_0_alp; rewrite alp0;move/Rlt_not_eq.
rewrite /I_lmax/=/Nmax.
rewrite (@big_ord_exclude0 _ (fun i => Pr[X = (INR i)] * (log Pr[X = (INR i)] - log (alp ^ i)))); last first.
  rewrite /@pr/Pr.
  have ->: [set x | X x == INR 0] = set0; last by rewrite big_set0 mul0R.
  apply/setP=>i; rewrite inE/=in_set0.
  by apply/eqP; apply: nesym; apply: Rlt_not_eq; apply: Xpos.
by move: (log_sum_inequality_ord_add1' (\max_(a in A) size (f a)) dom_by_hg).
Qed.

Lemma le_entroPN_logeEX : `H PN <= log (`E X ) + log (exp 1).
Proof.
move: EX_pos EX_non0=>EX_pos EX_non0.
move/Rle_lt_or_eq_dec:le_1_EX=>[? | eq_EX_1]; last first.
  rewrite -eq_EX_1 log_1 add0R.
  by move/esym/entroPN_0:eq_EX_1->; apply:log_exp1_Rle_0.
have EX_1 : 0 < `E X  - 1.
  apply:(Rplus_lt_reg_r 1).
  by rewrite addR0 addRC -addRA Rplus_opp_l addR0.
have neq_EX1_0 :(`E X  + -1) <> 0.
  by apply:nesym; apply:Rlt_not_eq.
apply:(Rle_trans _ (`E X  * log (`E X ) - (`E X  - 1) * log((`E X ) -1)) _).
  by apply: le_entroPN_logeEX'.
rewrite -{1}(Rplus_minus 1 (`E X)).
rewrite Rmult_plus_distr_r mul1R /Rminus -addRA; apply:Rplus_le_compat_l.
rewrite -Ropp_mult_distr_r_reverse -Rmult_plus_distr_l -(mul1R (log (exp 1))).
rewrite -{3}(Rplus_minus (`E X ) 1) -Ropp_minus_distr'.
apply:div_diff_ub=>//; first by apply:Rlt_le.
by apply:Rlt_le; apply:(Rlt_trans _ _ _ (Rlt_0_1)).
Qed.

End le_entroPN_logeEX.

Section v_scode_converse'_1tuple.

Variable A : finType.
Variable P : dist A.
Variable n : nat.
Variable f : A -> seq bool.
Local Notation "'I_lmax'" := (I_lmax f).
Let X := mkRvar P (INR \o size \o f).
Local Notation "'PN'" := (PN P f).
Hypothesis f_uniq: uniquely_decodable f.

Definition Pf (i : seq bool) := if [ pick x | f x == i ] is Some x then P x else 0.

Lemma Rle0Pf i : 0 <= Pf i.
Proof.
rewrite /Pf.
case:pickP=>[x _ | _ ]; first apply:Rle0f.
apply: Rle_refl.
Qed.

Lemma pmf1_Pf : \rsum_(m| m \in I_lmax) \rsum_(a in {: m.-tuple bool}) Pf a = 1.
Proof.
move:(uniq_dec_inj f_uniq)=> f_inj.
rewrite -(pmf1 P) (partition_big (inordf (size \o f)) (fun i => i \in I_lmax)) //=.
apply:eq_bigr=>i _.
rewrite (big_seq_tuple' i f_inj (dist_support_not_empty P)) /Pf=>[|x].
  apply:eq_big=>[x| x].
    apply/eqP/eqP=>[H|<-]; first by apply: ord_inj; rewrite -H inordfE.
    by  rewrite inordfE.
  by case:(pickP ) =>[? /eqP /f_inj ->| /(_ x)]; last rewrite eqxx.
case:(pickP ) =>[? /eqP <-| _ ]; first by rewrite codom_f.
by case:ifP.
Qed.

Definition Pf' (m : I_lmax) (a : m.-tuple bool) :=  Pf a / (PN m).

Lemma Rle0Pf' (m : I_lmax) : PN m <> 0 -> forall (a : m.-tuple bool) , 0 <= Pf' a.
Proof.
move=> PNnon0 a; rewrite /Pf'.
apply:(Rmult_le_reg_r (PN m)).
  apply:Rlt_le_neq; first by apply:le_0_Pr.
  by apply:nesym.
rewrite mul0R /Rdiv -mulRA -Rinv_l_sym // mulR1.
rewrite /Pf; case:pickP=>[? _ | ? ]; first by apply:Rle0f.
by apply:Rle_refl.
Qed.

Lemma pmf1_Pf' m : PN m <> 0 -> \rsum_(a | a \in {: m.-tuple bool}) Pf' a = 1.
Proof.
move:(uniq_dec_inj f_uniq)=>f_inj.
move=>PNnon0.
rewrite -big_distrl /=.
apply:(Rmult_eq_reg_r (PN m))=>//.
rewrite -mulRA -Rinv_l_sym // mul1R mulR1 /=.
rewrite /@pr /Pr (eq_bigr (fun x => Pf (f x)))=>[|a ain]; last first.
  rewrite /Pf.
  case:pickP; first by move=>x /eqP/ f_inj ->.
  by move/(_ a); rewrite eqxx.
rewrite (eq_bigl (fun x =>  size (f x) == m) _)=>[|a]; last first.
rewrite inE /X/=.
apply/eqP/eqP=>[/INR_eq | ->] //.
rewrite (big_seq_tuple' m f_inj (dist_support_not_empty P)) /Pf=>[//|i0].
case:(pickP ) => // ?; first by move/eqP <-; rewrite codom_f.
by case:ifP.
Qed.

Lemma disjoints_set1 h: \rsum_(a | a \in [set : I_lmax]) h a =
 \rsum_(a | a \in [set x | PN x == 0]) h a + \rsum_(a | a \in [set x | PN x != 0]) h a.
Proof.
rewrite (rsum_union [set x : I_lmax | PN x != 0] [set x : I_lmax | PN x == 0]).
    by rewrite addRC.
  rewrite disjoints_subset.
  rewrite (_ : ~: [set x | PN x != 0] = [set x | PN x == 0])//.
  apply/setP=>i.
  rewrite !inE.
  by case:(PN i == 0); rewrite -negb_involutive_reverse.
by rewrite setUC; apply/setP=> ?; rewrite !inE orbN.
Qed.

Lemma rewrite_HP_with_Pf : `H P =
 - \rsum_(m| m \in I_lmax) \rsum_(a in {: m.-tuple bool}) Pf a * log (Pf a).
Proof.
move:(uniq_dec_inj f_uniq)=> f_inj.
apply:Ropp_eq_compat.
rewrite [in LHS](partition_big (inordf (size \o f)) (fun i => i \in I_lmax)) //=.
apply:eq_bigr=>i _.
rewrite (eq_bigr (fun i0 => Pf (f i0) * log (Pf (f i0))))=>[|a]; last first.
  rewrite /Pf.
  case:(pickP _) => [x0 /eqP /f_inj->|] //.
  move/(_ a); by rewrite eqxx.
rewrite (eq_bigl (fun x=> size (f x) == i) _) =>[|x]; last first.
  apply/eqP/eqP=>[<-| H]; first by rewrite inordfE.
  by apply/ord_inj; rewrite inordfE.
rewrite (@big_seq_tuple' _ i _ f_inj (fun a => Pf a * log (Pf a)) (dist_support_not_empty P))//.
rewrite /Pf; move=>i0.
case:(pickP ) => // x; first by move/eqP <-; rewrite codom_f.
by case:ifP; rewrite mul0R.
Qed.

Lemma rewrite_HP_with_PN : `H P = - \rsum_(m| m \in [set x | PN x != 0]) PN m *
                           (\rsum_(a in {: m.-tuple bool}) Pf' a * (log (Pf' a) + log (PN m))).
Proof.
rewrite rewrite_HP_with_Pf.
apply:Ropp_eq_compat.
rewrite (eq_bigl (fun m => m \in [set : I_lmax]) _)=>[|?]; last by rewrite /= in_setT.
rewrite disjoints_set1.
rewrite [Y in Y + _ = _](_ : _ = 0); last first.
  apply:esym; apply: Req_0_rmul=>i.
  rewrite inE /@pr /Pr/= =>/eqP/Rle_big_eq_0=>H.
  have {H}H: forall j : A, j \in [set x | INR (size (f x)) == INR i] -> P j = 0.
    by apply:H=> ? ?; apply:Rle0f.
  apply:Req_0_rmul=>i0 i_in.
  rewrite /Pf.
  case:pickP=>[x /eqP fx_j|?]; last by rewrite mul0R.
  have ->: P x = 0; last by rewrite mul0R.
  apply:H.
  by rewrite inE fx_j size_tuple.
rewrite add0R.
apply:eq_bigr=>i.
rewrite inE ;move/eqP=>Pr_non0.
rewrite big_distrr /=.
apply:eq_bigr=>i0 _.
rewrite [in RHS]mulRC /Rdiv -mulRA -mulRA.
case: (Req_dec (Pf i0) 0)=>[->| /nesym Pfi0_non0]; first by rewrite !mul0R.
apply:Rmult_eq_compat_l.
rewrite mulRC -mulRA.
rewrite -Rinv_r_sym // mulR1 log_mult.
    rewrite log_Rinv; first by rewrite -addRA Rplus_opp_l addR0.
    apply:Rlt_le_neq; first by apply:le_0_Pr.
    by apply:nesym.
  apply:Rlt_le_neq=>//.
  rewrite /Pf; case:pickP=>[? _ | ? ]; first by apply:Rle0f.
  by apply:Rle_refl.
apply:Rinv_0_lt_compat.
apply:Rlt_le_neq; first by apply:le_0_Pr.
by apply:nesym.
Qed.

Lemma rewrite_HP_with_HPN : `H P =  \rsum_(m| m \in [set x : I_lmax | PN x != 0])
PN m * (- \rsum_(a in {: m.-tuple bool}) Pf' a *
(log ((Pf' a)))) + `H PN.
Proof.
move:(uniq_dec_inj f_uniq)=>f_inj.
rewrite {2}/entropy (eq_bigl (fun m => m \in [set : I_lmax]) (fun x=> _ * log _))=>[|?]; last by rewrite /= in_setT.
rewrite disjoints_set1.
rewrite [Y in  _ = _ + - ( Y + _)](_ :_ = 0); last first.
  apply:esym; apply: Req_0_rmul=>i.
  rewrite inE /PN /==>/eqP->.
  by rewrite mul0R.
rewrite add0R rewrite_HP_with_PN !(big_morph _ morph_Ropp Ropp_0) -big_split/=.
apply:eq_bigr=>i.
rewrite inE =>/eqP=>Pr_non0.
rewrite Ropp_mult_distr_r_reverse -Ropp_plus_distr; apply:Ropp_eq_compat.
rewrite -Rmult_plus_distr_l; apply:Rmult_eq_compat_l.
rewrite -[Y in _ = _ + Y]mul1R -(pmf1_Pf' Pr_non0) big_distrl/= -big_split/=.
by apply:eq_bigr=>? _; by rewrite Rmult_plus_distr_l.
Qed.

Lemma apply_max_HPN : `H P <= `E X  + `H PN.
Proof.
move:(uniq_dec_inj f_uniq)=>f_inj.
rewrite rewrite_HP_with_HPN addRC (addRC _ (`H _)).
apply:Rplus_le_compat_l.
rewrite EX_ord.
rewrite (eq_bigl (fun m => m \in [set : I_lmax]) (fun x=> INR x * _ ))=>[|?]; last by rewrite /= in_setT.
rewrite disjoints_set1.
rewrite [Y in _ <= Y + _ ](_ :_ = 0).
  rewrite add0R.
  apply:Rle_big_P_f_g=>i.
  rewrite mulRC inE; move/eqP=>H.
  apply:Rmult_le_compat_r; first by apply:le_0_Pr.
  pose pmf_Pf' := mkPosFun (Rle0Pf' H).
  have pmf1'_Pf' : \rsum_(a in {: i.-tuple bool}) pmf_Pf' a = 1 by apply: (pmf1_Pf' H).
  pose distPf := mkDist pmf1'_Pf'.
  move:(entropy_max distPf).
  rewrite card_tuple/= card_bool -INR_pow_expn log_pow (_ : INR 2 = 2)//.
    by rewrite log_2 mulR1.
  by apply:Rlt_R0_R2.
apply:esym; apply: Req_0_rmul=>i.
rewrite inE /PN /==>/eqP->.
by rewrite mulR0.
Qed.

Lemma apply_le_HN_logE_loge: `H P <= `E X  + log ((exp 1) * (`E X )).
Proof.
apply:(Rle_trans _ _ _ apply_max_HPN).
apply:Rplus_le_compat_l.
rewrite mulRC (log_mult (EX_pos P f_uniq) (exp_pos 1)).
by apply:(le_entroPN_logeEX _ f_uniq).
Qed.

End v_scode_converse'_1tuple.

Section v_scode_converse'_ntuple.

Variable A : finType.
Variable n:nat.
Variable f : var_enc A n.
Variable P : dist A.
Hypothesis f_uniq : uniquely_decodable f.

Lemma converse_case1 : E_leng_cw f P < (INR n) * (log (INR #|A|)) ->
`H (P `^ n) <= E_leng_cw f P + log ((exp 1) * (INR n) * (log (INR #|A|))).
Proof.
move=>H.
apply:(Rle_trans _ _ _ (apply_le_HN_logE_loge (P `^ n) f_uniq)).
apply:Rplus_le_compat_l.
apply:log_increasing_le.
  apply:(Rmult_lt_0_compat _ _ (exp_pos 1)).
  apply: (EX_pos (P `^ n) f_uniq).
rewrite -mulRA; apply:Rmult_le_compat_l; first by apply:Rlt_le; apply:exp_pos.
by apply:Rlt_le.
Qed.

Lemma converse_case2 :  (INR n) * (log (INR #|A|)) <= E_leng_cw f P ->
 `H (P `^ n) <= E_leng_cw f P.
Proof.
move=> H.
rewrite entropy_TupleDist.
apply: (Rle_trans (INR n * `H P) (INR n * log (INR #|A|)) _); last by apply: H.
apply: Rmult_le_compat_l; last by apply: entropy_max.
by rewrite (_ : 0 = INR 0) //; apply:le_INR; apply/leP; apply:leq0n.
Qed.

End v_scode_converse'_ntuple.

Section Extend_encoder.

Variable A : finType.
Variable n m:nat.
Variable f : var_enc A n.
Variable P : dist A.
Hypothesis f_uniq : uniquely_decodable f.
Hypothesis m_non0 : 0 <> (INR m).
Let fm (x : (m.-tuple {: n.-tuple A})) := extension f x.

Lemma fm_uniq : uniquely_decodable fm.
Proof.
pose m' := m.-1.
have mpos: m = m'.+1.
  case/Rdichotomy:m_non0; first by rewrite (_ : 0 = INR 0)//; move/INR_lt/(S_pred _ 0).
  by rewrite (_ : 0 = INR 0)//; move/Rgt_lt/INR_lt/ltP.
have: extension f \o (flatten \o map (@tval m _)) =1 extension fm.
   by elim => //= ta sta; rewrite /extension /= map_cat flatten_cat => <-.
apply: eq_inj.
apply: inj_comp => //.
rewrite mpos.
 elim => /= [| ta1 sta1 IHsta1]; case => [| ta2 sta2] //=.
 - by case: (tupleP ta2).
 - by case: (tupleP ta1).
 - move/eqP.
   rewrite eqseq_cat; last by rewrite !size_tuple.
   by move/andP => [/eqP /val_inj -> /eqP /IHsta1 ->].
Qed.

Lemma ELC_TupleDist : E_leng_cw fm (P `^ n) = (INR m) * E_leng_cw f P.
Proof.
rewrite /E_leng_cw /Ex_alt /=  /fm /TupleDist.f.
pose X := mkRvar (P `^ n) (INR \o size \o f).
elim:m=>[| m']; first by rewrite rsum_0tuple /= !mul0R.
elim:m'=>[_ |m'' _ IH].
  rewrite mul1R -/(Ex_alt X) -E_rvar2tuple1.
  apply:eq_bigr=>i _.
  rewrite /= /TupleDist.f big_ord_recl big_ord0 mulR1.
  apply:Rmult_eq_compat_r.
  case:(tupleP i)=> ? ?; by rewrite /extension tuple0 /= theadE cats0.
pose fm1 (x :[finType of ((m''.+1).-tuple {: n.-tuple A})]) := extension f x.
pose Xm1 := mkRvar ((P `^ n) `^ (m''.+1)) (INR \o size \o fm1 ).
pose fm2 (x :[finType of ((m''.+2).-tuple {: n.-tuple A})]) := extension f x.
pose Xm2 := mkRvar ((P `^ n) `^ (m''.+2)) (INR \o size \o fm2 ).
have X_Xm1_Xm2: Xm2 \= X \+ Xm1.
  apply:conj=>[|x /=]; first by apply:joint_prod_n.
  rewrite  -plus_INR plusE -size_cat.
  case:(tupleP x)=> ? ?; by rewrite theadE.
rewrite -/(Ex_alt Xm2) (E_linear_2 X_Xm1_Xm2) -(mul1R (`E X)).
by rewrite /Ex_alt IH -Rmult_plus_distr_r addRC -addn1 S_INR.
Qed.

End Extend_encoder.

Section v_scode_converse'.

Variable A : finType.
Variable P : dist A.
Variable n : nat.
Variable f : var_enc A n.
Hypothesis f_uniq : uniquely_decodable f.

Let alp := exp 1 * log (INR #|{: n.-tuple A}|).
Let m eps:= Zabs_nat (floor (exp (INR (maxn (Zabs_nat (ceil ((ln alp) + INR n * eps * ln 2)))
                                  (maxn (Zabs_nat (ceil (4 /(INR n * eps * ln 2)))) 1))))).

Lemma mpos eps: 0 <> INR n -> 0 < INR (m eps).
Proof.
rewrite /m =>nnon0.
rewrite (_ : 0 = INR 0)//; apply: lt_INR.
rewrite {1}(_ : 0%nat = Z.abs_nat 0)//; apply:Zabs_nat_lt; apply:conj=>//.
apply: lt_0_IZR.
apply: (Rlt_trans _ (exp (INR (maxn (Z.abs_nat (ceil (ln alp + INR n * eps * ln 2)))
                 (maxn (Z.abs_nat (ceil (4 / (INR n * eps * ln 2))))
                    1))) -1) _); last by apply: (floor_bottom _).
apply: (Rplus_lt_reg_r 1).
rewrite addR0 addRC /Rdiv -addRA Rplus_opp_l addR0 -{1}exp_0.
apply: exp_increasing.
rewrite (_ : 0 = INR 0)//; apply: lt_INR; apply: ltP.
apply: (@leq_trans ((maxn (Z.abs_nat (ceil (4 * / (INR n * eps * ln 2)))) 1))); last by apply: leq_maxr.
by apply: (@leq_trans 1); last by apply: leq_maxr.
Qed.

Lemma le_eps eps: 0 <> INR n -> 1 <= INR n * log (INR #|A|) -> 0 < eps ->
  log (INR (m eps) * alp) * / INR (m eps) * / INR n <= eps.
Proof.
move=> nnon0 eps_pos cardA_non1.
pose x := (INR (maxn (Z.abs_nat (ceil (ln alp + INR n * eps * ln 2)))
                     (maxn (Z.abs_nat (ceil (4 / (INR n * eps * ln 2)))) 1))).
pose Y := (eps * INR n * ln 2).
have npos: 0 < INR n.
  by case/Rdichotomy:nnon0=>//; rewrite (_ : 0 = INR 0)// => /INR_lt/ltP.
have xpos : 0 < x.
  rewrite (_ : 0 = INR 0)//; apply: lt_INR; apply/leP.
  apply: (@leq_trans ((maxn (Z.abs_nat (ceil (4 * / (INR n * eps * ln 2)))) 1))); last by apply: leq_maxr.
  by apply: (@leq_trans 1); last by apply: leq_maxr.
have mpos': (0 < floor (exp x))%Z.
  apply: lt_IZR.
  apply: (Rlt_trans _ (exp x - 1) _); last by apply: floor_bottom.
  apply: (Rplus_lt_reg_r 1).
  rewrite addR0 addRC /Rminus -addRA Rplus_opp_l addR0 -exp_0.
  by apply: exp_increasing=>//.
have le_1_alp: 1 <= alp.
  rewrite /alp -(mulR1 1).
  apply: (Rmult_le_compat _ _ _ _ Rle_0_1 Rle_0_1).
  rewrite mulR1.
  apply: (Rle_trans _ 2); last by apply: two_e.
  by rewrite -{1}(addR0 1); apply: (Rplus_le_compat_l _ _ _ Rle_0_1).
  rewrite card_tuple -INR_pow_expn log_pow //.
  by rewrite (_ : 0 = INR 0)//; apply: lt_INR; apply/ltP; apply: dist_support_not_empty.
have alppos: 0 < alp.
  apply: (Rlt_le_trans _ 1 _ Rlt_0_1)=>//.
have Ypos: 0 < Y.
  apply: Rmult_lt_0_compat; last by apply:ln_2_pos.
  by apply: Rmult_lt_0_compat=>//.
apply: (Rmult_le_reg_r (INR (m eps) * INR n)).
  apply: Rmult_lt_0_compat=>//; by apply: (mpos eps nnon0).
rewrite -mulRA (mulRC (/ INR n) _ ) -mulRA -mulRA -Rinv_r_sym; last by apply: nesym.
rewrite mulR1 -(Rinv_l_sym _ (nesym (Rlt_not_eq _ _ (mpos eps nnon0)))) mulR1.
apply: (Rle_trans _ ((x ^ 2 / 2 - 1) * eps * (INR n)) _); last first.
  rewrite -mulRA mulRC -mulRA; apply: Rmult_le_compat_l; first by apply: Rlt_le.
  rewrite mulRC; apply: Rmult_le_compat_r; first by apply: Rlt_le.
  apply: (Rle_trans _ (exp x - 1) _).
    apply: (Rplus_le_reg_r 1).
    rewrite -addRA Rplus_opp_l addR0 -addRA Rplus_opp_l addR0.
    by rewrite (_ : 2 = INR 2 `!)//; apply: (exp_lb 2); apply: pos_INR.
  rewrite INR_Zabs_nat; last first.
    by apply: le_IZR; apply: Rlt_le; apply: IZR_lt.
  by apply: Rlt_le; apply: floor_bottom.
rewrite INR_Zabs_nat; last by apply: le_IZR; apply: Rlt_le; apply: IZR_lt.
rewrite log_mult//; last by rewrite (_ :0 = IZR 0)//; apply: IZR_lt.
apply: (Rmult_le_reg_r (ln 2) _ _ ln_2_pos).
rewrite Rmult_plus_distr_r /log/Rdiv -mulRA -(Rinv_l_sym _ (nesym (Rlt_not_eq _ _(ln_2_pos)))).
rewrite mulR1 -(mulRA _ (/ ln 2) _) -(Rinv_l_sym _ (nesym (Rlt_not_eq _ _ (ln_2_pos)))) mulR1.
apply: (Rle_trans _ (x + ln alp) _).
  apply: Rplus_le_compat_r.
  rewrite -(ln_exp x).
  apply: ln_increasing_le; last by apply: floor_upper.
  apply: (Rlt_trans _ (exp x - 1) _); last by apply: floor_bottom.
  apply: (Rplus_lt_reg_r 1).
  rewrite addR0 addRC -addRA Rplus_opp_l addR0 -exp_0.
  apply: exp_increasing=>//.
apply: (Rle_trans _ (2 * x - (eps * INR n * ln 2))).
  rewrite double /Rminus -addRA.
  apply: Rplus_le_compat_l.
  apply: (Rplus_le_reg_r (eps * INR n * ln 2)).
  rewrite -addRA Rplus_opp_l addR0 mulRC mulRA mulRC (mulRC _ eps) mulRA.
  apply: (Rle_trans _ (IZR (ceil (ln alp +  INR n * eps * ln 2)))); first by apply: ceil_bottom.
  rewrite -INR_Zabs_nat; first by apply: le_INR; apply/leP; apply: leq_maxl.
  apply: le_IZR.
  apply: (Rle_trans _ (ln alp + Y)); last by rewrite /Y (mulRC eps); apply: ceil_bottom.
  apply: Rplus_le_le_0_compat; last by apply: Rlt_le.
  by rewrite -(ln_exp 0) exp_0; apply: ln_increasing_le=> //; apply: Rlt_0_1.
rewrite -(mulRA _ eps) -(mulRA _ (eps * INR n)).
rewrite (Rmult_plus_distr_r (x ^ 2 * / 2) _ (eps * INR n * ln 2)).
rewrite Ropp_mult_distr_l_reverse mul1R /Rminus.
apply: Rplus_le_compat_r.
apply: (Rmult_le_reg_r (/ Y * 2 * / x)).
  apply: Rlt_mult_inv_pos=>//.
  apply: Rmult_lt_0_compat; last by apply: Rlt_0_2.
  by apply: Rinv_0_lt_compat.
rewrite mulRC -mulRA (mulRC (/ x)) -mulRA -mulRA -(Rinv_r_sym _ (nesym (Rlt_not_eq _ _ xpos))).
rewrite mulR1 mulRC mulRA mulRA (mulRC _ (/x)) /=mulR1 mulRA (mulRC _ 2).
rewrite -(mulRA _ Y) -(Rinv_r_sym _ (nesym (Rlt_not_eq _ _ Ypos))).
rewrite mulR1 (mulRC 2) !mulRA -(mulRA _ _ 2) -!Rinv_l_sym; last first.
  by apply: (nesym (Rlt_not_eq _ _ xpos)).
  by apply: (nesym (Rlt_not_eq _ _ Rlt_0_2)).
rewrite mulR1 mul1R.
apply: (Rle_trans _ (INR (maxn (Z.abs_nat (ceil (4 * / (INR n * eps * ln 2)))) 1))); last by apply: le_INR; apply: leP; apply: leq_maxr.
apply: (Rle_trans _ (INR (Z.abs_nat (ceil (4 * / (INR n * eps * ln 2)))))); last by apply: le_INR; apply: leP; apply: leq_maxl.
rewrite INR_Zabs_nat.
  apply: (Rle_trans _ ( (4 * / (INR n * eps * ln 2)))); last by apply: ceil_bottom.
  rewrite (mulRC (INR n)); by apply: Rle_refl.
apply:le_IZR.
apply: (Rle_trans _ ( (4 * / (INR n * eps * ln 2)))); last by apply: ceil_bottom.
apply: Rle_mult_inv_pos; first by apply: (Rlt_le _ _ (Rmult_lt_0_compat _ _ Rlt_0_2 Rlt_0_2)).
by rewrite (mulRC (INR n)).
Qed.

Theorem v_scode_converse' :
  E_leng_cw f P >= (INR n) * `H P.
Proof.
case: (Req_dec 0 (INR n))=>[<-|nnon0].
  rewrite mul0R.
  apply:Rle_ge; apply: Rlt_le.
  apply: (EX_pos (P `^ n) f_uniq).
apply:Rle_ge.
have npos: 0 < INR n.
  by case/Rdichotomy:nnon0=>//; rewrite (_ : 0 = INR 0)// => /INR_lt/ltP.
apply: (Rmult_le_reg_r (/ INR n)).
  by apply: Rinv_0_lt_compat.
rewrite (mulRC (INR n)) -mulRA -Rinv_r_sym; last by apply: nesym.
rewrite mulR1.
apply:le_epsilon=>eps epspos.
pose fm (x : ((m eps).-tuple {: n.-tuple A})) := extension f x.
case:(Rle_or_lt  ((INR (m eps)) * (log (INR #|{: n.-tuple A}|)))(E_leng_cw fm (P `^ n))).
  move/(@converse_case2 _ _ fm (P `^ n)).
  rewrite !entropy_TupleDist ELC_TupleDist.
  move/(Rmult_le_reg_l _ _ _ (mpos eps nnon0))=>H.
  apply: (Rle_trans _ (E_leng_cw f P / (INR n)))=>//.
    apply: (Rmult_le_reg_r (INR n)).
      by case/Rdichotomy:nnon0=>//; rewrite (_ : 0 = INR 0)// => /INR_lt/ltP.
    rewrite mulRC -mulRA -Rinv_l_sym; last by apply: nesym.
    by rewrite mulR1.
  by rewrite -{1}(addR0 (E_leng_cw f P / (INR n))); apply:  Rplus_le_compat_l; apply: Rlt_le.
have mnon0: INR (m eps) <> 0.
  by apply: (nesym (Rlt_not_eq _ _ (mpos eps nnon0))).
move=>case2.
move:(@converse_case1 _ _ _ (P `^ n) (fm_uniq f_uniq (Rlt_not_eq _ _ (mpos eps nnon0))) case2).
rewrite !entropy_TupleDist ELC_TupleDist /Ex_alt /= -!mulRA mulRA.
move/(Rmult_le_compat_r _ _ _  (Rlt_le _ _ (Rinv_0_lt_compat _ (mpos eps nnon0)))).
rewrite -mulRA -mulRA mulRC mulRA -mulRA -Rinv_l_sym//.
rewrite mulR1 Rmult_plus_distr_r (mulRC (INR (m eps))) -mulRA -Rinv_r_sym// mulR1.
move/(Rmult_le_compat_r _ _ _  (Rlt_le _ _ (Rinv_0_lt_compat _ npos))).
rewrite (mulRC (INR n)) -mulRA -Rinv_r_sym; last by apply: nesym.
rewrite mulR1 Rmult_plus_distr_r=>H.
apply: (Rle_trans _ _ _ H).
apply: Rplus_le_compat_l.
rewrite mulRA (mulRC (exp 1)) -(mulRA (INR (m eps))).
apply: le_eps=>//.
move:case2.
rewrite ELC_TupleDist mulRC (mulRC (INR (m eps))) card_tuple  -INR_pow_expn log_pow; last first.
  by rewrite (_ : 0 = INR 0)//; apply: lt_INR; apply/ltP; apply: dist_support_not_empty.
move/(Rmult_lt_reg_r _ _ _ (mpos eps nnon0))=>H'.
apply: (Rle_trans _ (E_leng_cw f P)).
by apply: (le_1_EX (P `^ n) f_uniq).
by apply: Rlt_le.
Qed.

End v_scode_converse'.

Section v_scode_converse.

Variable A : finType.
Variable P : dist A.
Variable n : nat.
Variable f : var_enc A n.
Hypothesis f_uniq : uniquely_decodable f.

Theorem v_scode_converse :
  E_leng_cw f P >= INR n * `H P.
Proof.
  by apply:v_scode_converse'=>//.
Qed.

End v_scode_converse.


Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.
Require Import Undecidability.SOL.PA2.
From Undecidability.SOL.Reductions Require Import H10p_to_SOL.
From Undecidability.H10 Require Import H10p_undec.

Lemma undecidable_PA2_valid : undecidable PA2_valid.
Proof.
   apply (undecidability_from_reducibility H10p_undec).
   exists encode_problem. intros e. apply H10p_to_PA2_validity.
Qed.

Lemma undecidable_PA2_satis: undecidable PA2_satis.
Proof.
   apply (undecidability_from_reducibility H10p_undec).
   exists encode_problem. intros e. apply H10p_to_PA2_satisfiability.
Qed.


Require Export SystemFR.WFLemmas.
Require Export SystemFR.BaseType.
Require Export SystemFR.Tactics.
Require Export SystemFR.TWFLemmas.
Require Export SystemFR.AnnotatedTermLemmas.
Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.

Require Export SystemFR.ListUtils.

Lemma wf_base_type:
  forall X A B,
    base_type X A B ->
    forall k,
      wf A k ->
      wf B k.
Proof.
  induction 1; steps.
Qed.

#[export]
Hint Immediate wf_base_type: wf.

Ltac t_wf_base_type :=
  match goal with
  | H: base_type ?X ?A ?B |- wf ?B ?k => apply wf_base_type with X A
  end.

#[export]
Hint Extern 50 => t_wf_base_type: wf.

Lemma twf_base_type:
  forall X A B,
    base_type X A B ->
    forall k,
      twf A k ->
      twf B k.
Proof.
  induction 1; steps.
Qed.

#[export]
Hint Immediate twf_base_type: twf.

Ltac t_twf_base_type :=
  match goal with
  | H: base_type ?X ?A ?B |- twf ?B ?k => apply twf_base_type with X A
  end.

#[export]
Hint Extern 50 => t_twf_base_type: twf.

Lemma annotated_base_type:
  forall X A B,
    base_type X A B ->
    is_annotated_type A ->
    is_annotated_type B.
Proof.
  induction 1; steps.
Qed.

Ltac t_annotated_base_type :=
  match goal with
  | H: base_type ?X ?A ?B |- is_annotated_type ?B => apply annotated_base_type with X A
  end.

#[export]
Hint Extern 50 => t_annotated_base_type: annot.

Lemma pfv_base_type:
  forall X A B,
    base_type X A B ->
    forall x tag,
      x ∈ pfv B tag ->
      x ∈ pfv A tag.
Proof.
  induction 1; repeat step || list_utils.
Qed.

Ltac t_pfv_base_type :=
  match goal with
  | H1: base_type ?X ?A ?B, H2: ?Y ∈ pfv ?B ?tag |- _ => apply (pfv_base_type _ _ _ H1) in H2
  end.

#[export]
Hint Extern 50 => t_pfv_base_type: fv.

Lemma pfv_base_type_subset:
  forall X A B,
    base_type X A B ->
    forall S tag,
      subset (pfv A tag) S ->
      subset (pfv B tag) S.
Proof.
  unfold subset; steps; eauto using pfv_base_type.
Qed.

Ltac t_pfv_base_type_subset :=
  match goal with
  | H: base_type ?X ?A ?B |- subset (pfv ?B ?tag) ?S =>
      apply (pfv_base_type_subset _ _ _ H S tag)
  end.

Lemma pfv_base_type2:
  forall X A B,
    base_type X A B ->
    X ∈ pfv B type_var ->
    False.
Proof.
  induction 1; repeat step || list_utils.
Qed.

#[export]
Hint Extern 1000 => apply False_ind; eapply pfv_base_type2; eassumption: fv.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.StringOperations.

Global Set Implicit Arguments.

Lemma nat_of_ascii_small x
: Ascii.nat_of_ascii x < 256.
Proof.
  apply Compare_dec.leb_complete.
  revert x.
  intros [[] [] [] [] [] [] [] []]; lazy; reflexivity.
Qed.

Lemma substring_correct3 {s : string} m (H : length s <= m)
  : substring 0 m s = s.
Proof.
  revert m H.
  induction s; simpl.
  { intros; destruct m; trivial. }
  { intros; destruct m.
    { apply Lt.lt_n_0 in H.
      destruct H. }
    { rewrite IHs; trivial.
      apply Le.le_S_n; trivial. } }
Qed.

Lemma substring_correct3' {s : string}
  : substring 0 (length s) s = s.
Proof.
  apply substring_correct3; reflexivity.
Qed.

Lemma substring_correct0 {s : string} {n}
  : substring n 0 s = ""%string.
Proof.
  revert n; induction s; intro n; destruct n; simpl; trivial.
Qed.

Lemma substring_correct0' {s : string} {n m} (H : length s <= n)
  : substring n m s = ""%string.
Proof.
  revert n m H; induction s; simpl; intros n m H.
  { destruct n, m; trivial. }
  { destruct n, m; trivial.
    { apply le_Sn_0 in H; destruct H. }
    { rewrite IHs; eauto with arith. }
    { rewrite IHs; eauto with arith. } }
Qed.

Lemma substring_correct4 {s : string} {n m m'}
      (H : length s <= n + m) (H' : length s <= n + m')
  : substring n m s = substring n m' s.
Proof.
  revert n m m' H H'.
  induction s; simpl in *.
  { intros; destruct m, m', n; trivial. }
  { intros; destruct m, m', n; trivial; simpl in *;
    try (apply Lt.lt_n_0 in H; destruct H);
    try (apply Lt.lt_n_0 in H'; destruct H');
    try apply Le.le_S_n in H;
    try apply Le.le_S_n in H';
    try solve [ try rewrite plus_comm in H;
                try rewrite plus_comm in H';
                simpl in *;
                rewrite !substring_correct0' by auto with arith; trivial ].
    { apply f_equal.
      apply IHs; trivial. }
    { apply IHs; trivial. } }
Qed.

Lemma string_concat_empty_r {s} : (s ++ "" = s)%string.
Proof.
  induction s; simpl; f_equal; trivial.
Qed.

Lemma string_concat_empty_l {s} : ("" ++ s = s)%string.
Proof.
  reflexivity.
Qed.

Lemma substring_concat {x y z} {s : string}
  : (substring x y s ++ substring (x + y) z s)%string = substring x (y + z) s.
Proof.
  revert x y z.
  induction s; simpl; intros.
  { destruct (y + z), x, y, z; reflexivity. }
  { destruct x, y, z; try reflexivity; simpl;
    rewrite ?plus_0_r, ?substring_correct0, ?string_concat_empty_r;
    try reflexivity.
    { apply f_equal.
      apply IHs. }
    { rewrite IHs; simpl; reflexivity. } }
Qed.

Lemma substring_concat' {y z} {s : string}
  : (substring 0 y s ++ substring y z s)%string = substring 0 (y + z) s.
Proof.
  rewrite <- substring_concat; reflexivity.
Qed.

Lemma substring_concat0 {s1 s2 : string}
  : substring 0 (length s1) (s1 ++ s2) = s1.
Proof.
  induction s1; simpl.
  { rewrite substring_correct0; trivial. }
  { rewrite IHs1; trivial. }
Qed.

Lemma concat_length {s1 s2 : string}
  : length (s1 ++ s2) = length s1 + length s2.
Proof.
  induction s1.
  { reflexivity. }
  { simpl.
    rewrite IHs1; reflexivity. }
Qed.

Lemma substring_concat_length {s1 s2 : string}
  : substring (length s1) (length s2) (s1 ++ s2) = s2.
Proof.
  induction s1; simpl.
  { rewrite substring_correct3'; trivial. }
  { erewrite substring_correct4.
    { exact IHs1. }
    { rewrite concat_length; reflexivity. }
    { rewrite concat_length; reflexivity. } }
Qed.

Lemma substring_length {s n m}
  : length (substring n m s) = (min (length s) (m + n)) - n.
Proof.
  revert n m; induction s; intros.
  { destruct n, m; reflexivity. }
  { simpl.
    destruct n, m; simpl; trivial; rewrite IHs; simpl;
    try lia;
    rewrite (plus_comm m (S n)); simpl;
    rewrite (plus_comm n m); simpl;
    reflexivity. }
Qed.

Lemma substring_substring {s n m n' m'}
  : substring n m (substring n' m' s) = substring (n + n') (min m (m' - n)) s.
Proof.
  revert n m n' m'.
  induction s; intros.
  { destruct n, m, n', m'; reflexivity. }
  { destruct n', m';
    rewrite <- ?plus_n_O, <- ?minus_n_O, ?Min.min_0_r, ?Min.min_0_l;
    destruct n, m;
    trivial; simpl;
    rewrite ?IHs, ?substring_correct0, <- ?plus_n_O, <- ?minus_n_O;
    simpl;
    try reflexivity.
    rewrite (plus_comm _ (S _)); simpl.
    rewrite (plus_comm n n').
    reflexivity. }
Qed.

Lemma substring1_get {n str}
  : substring n 1 str
    = option_rect (fun _ => String.string) (fun a => String.String a ""%string) ""%string (get n str).
Proof.
  revert n; induction str; intro n.
  { destruct n; reflexivity. }
  { destruct n; simpl.
    { destruct str; reflexivity. }
    { rewrite <- IHstr; reflexivity. } }
Qed.

Lemma substring_min {x x' y y' z str} (H : substring x y str = substring x' y' str)
  : substring x (min y z) str = substring x' (min y' z) str.
Proof.
  pose proof (fun y x => @substring_substring str 0 z x y) as H'; simpl in *.
  setoid_rewrite Nat.sub_0_r in H'.
  setoid_rewrite Min.min_comm in H'.
  rewrite <- !H', H; reflexivity.
Qed.

Lemma get_string_of_list str n
: String.get n (string_of_list str) = List.nth_error str n.
Proof.
  revert n; induction str as [|ch str IHstr]; intros;
  destruct n as [|n]; simpl in *; auto.
Qed.

Lemma length_list_of_string str
: List.length (list_of_string str) = String.length str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma length_string_of_list ls
: String.length (string_of_list ls) = List.length ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma list_of_string_substring n m str
: StringOperations.list_of_string (String.substring n m str) = List.take m (List.drop n (StringOperations.list_of_string str)).
Proof.
  revert n m; induction str as [|?? IHstr];
  intros [|?] [|?];
  simpl;
  rewrite ?IHstr;
  reflexivity.
Qed.

Lemma list_of_string_of_list ls
: list_of_string (string_of_list ls) = ls.
Proof.
  induction ls; simpl; rewrite ?IHls; reflexivity.
Qed.

Lemma string_of_list_of_string str
: string_of_list (list_of_string str) = str.
Proof.
  induction str; simpl; rewrite ?IHstr; reflexivity.
Qed.

Lemma get_list_of_string str n
: List.nth_error (list_of_string str) n = String.get n str.
Proof.
  rewrite <- get_string_of_list, string_of_list_of_string; reflexivity.
Qed.

Lemma substring_min_length str x y
: substring x (min y (length str)) str = substring x y str.
Proof.
  apply Min.min_case_strong; try reflexivity.
  intro H.
  apply substring_correct4; lia.
Qed.

Lemma string_copy_length n ch
: String.length (string_copy n ch) = n.
Proof.
  induction n; simpl; eauto.
Qed.

Fixpoint split_string (s : string) : (string * string) :=
  match s with
  | EmptyString => ("", "")
  | String a s' => if Ascii.ascii_dec a "." then ("", s')
                   else (let (s1, s2) := split_string s' in
                         (String a s1, s2))
  end%string.

Lemma split_string_ValidDomainName_length :
  forall d,
    d <> ""%string
    -> lt (String.length (snd (split_string d))) (String.length d).
Proof.
  induction d; simpl; intros; try congruence.
  destruct (Ascii.ascii_dec a "."); simpl; eauto.
  destruct d; simpl in *; eauto.
  destruct (if Ascii.ascii_dec a0 "." then (""%string, d)
               else (let (s1, s2) := split_string d in (String a0 s1, s2))).
  simpl in *.
  etransitivity.
  apply IHd.
  congruence.
  eauto with arith.
Qed.

Lemma well_founded_string_length
  : well_founded (fun y r : string => lt (String.length y) (String.length r)%nat).
Proof.
  unfold well_founded; intro; induction a; econstructor.
  - destruct y; simpl; lia.
  - intros; destruct y; simpl; intros.
    + econstructor; destruct y; simpl; lia.
    + econstructor; intros.
      eapply IHa; simpl in *; lia.
Qed.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 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 General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module Ordered.

Section RawMixin.

Structure mixin_of (T : eqType) :=
  Mixin {ordering : rel T;
         _ : irreflexive ordering;
         _ : transitive ordering;
         _ : forall x y, [|| ordering x y, x == y | ordering y x]}.

End RawMixin.

(* the class takes a naked type T and returns all the *)
(* relatex mixins; the inherited ones and the added ones *)
Section ClassDef.

Record class_of (T : Type) := Class {
   base : Equality.class_of T;
   mixin : mixin_of (Equality.Pack base)}.

Local Coercion base : class_of >-> Equality.class_of.

Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce an ordered type out of the inherited mixins *)
(* equalize m0 and m by means of a phantom; will be exploited *)
(* further down in the definition of OrdType *)
Definition pack b (m0 : mixin_of (EqType T b)) :=
  fun m & phant_id m0 m => Pack (@Class T b m) T.

Definition eqType := Equality.Pack class.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical Structure eqType.
Notation ordType := Ordered.type.
Notation OrdMixin := Mixin.
Notation OrdType T m := (@pack T _ m _ id).
Definition ord T : rel (sort T) := (ordering (mixin (class T))).
Notation "[ 'ordType' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'ordType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'ordType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'ordType' 'of' T ]") : form_scope.
End Exports.
End Ordered.
Export Ordered.Exports.

Prenex Implicits ord.

Section Lemmas.
Variable T : ordType.

Lemma irr : irreflexive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma trans : transitive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma total (x y : T) : [|| ord x y, x == y | ord y x].
Proof. by case: T x y=>s [b [m]]. Qed.

Lemma nsym (x y : T) : ord x y -> ord y x -> False.
Proof. by move=>E1 E2; move: (trans E1 E2); rewrite irr. Qed.

End Lemmas.

Section Totality.
Variable K : ordType.

CoInductive total_spec (x y : K) : bool -> bool -> bool -> Type :=
| total_spec_lt of ord x y : total_spec x y true false false
| total_spec_eq of x == y : total_spec x y false true false
| total_spec_gt of ord y x : total_spec x y false false true.

Lemma totalP x y : total_spec x y (ord x y) (x == y) (ord y x).
Proof.
case H1: (x == y).
- by rewrite (eqP H1) irr; apply: total_spec_eq.
case H2: (ord x y); case H3: (ord y x).
- by case: (nsym H2 H3).
- by apply: total_spec_lt H2.
- by apply: total_spec_gt H3.
by move: (total x y); rewrite H1 H2 H3.
Qed.
End Totality.

Section NatOrd.
Lemma irr_ltn_nat : irreflexive ltn. Proof. by move=>x; rewrite /= ltnn. Qed.
Lemma trans_ltn_nat : transitive ltn. Proof. by apply: ltn_trans. Qed.
Lemma total_ltn_nat : forall x y, [|| x < y, x == y | y < x].
Proof. by move=>*; case: ltngtP. Qed.

Definition nat_ordMixin := OrdMixin irr_ltn_nat trans_ltn_nat total_ltn_nat.
Canonical Structure nat_ordType := OrdType nat nat_ordMixin.
End NatOrd.

Section ProdOrd.
Variables K T : ordType.

(* lexicographic ordering *)
Definition lex : rel (K * T) :=
  fun x y => if x.1 == y.1 then ord x.2 y.2 else ord x.1 y.1.

Lemma irr_lex : irreflexive lex.
Proof. by move=>x; rewrite /lex eq_refl irr. Qed.

Lemma trans_lex : transitive lex.
Proof.
move=>[x1 x2][y1 y2][z1 z2]; rewrite /lex /=.
case: ifP=>H1; first by rewrite (eqP H1); case: eqP=>// _; apply: trans.
case: ifP=>H2; first by rewrite (eqP H2) in H1 *; rewrite H1.
case: ifP=>H3; last by apply: trans.
by rewrite (eqP H3)=>R1; move/(nsym R1).
Qed.

Lemma total_lex : forall x y, [|| lex x y, x == y | lex y x].
Proof.
move=>[x1 x2][y1 y2]; rewrite /lex /=.
case: ifP=>H1.
- rewrite (eqP H1) eq_refl -pair_eqE /= eq_refl /=; exact: total.
rewrite (eq_sym y1) -pair_eqE /= H1 /=.
by move: (total x1 y1); rewrite H1.
Qed.

Definition prod_ordMixin := OrdMixin irr_lex trans_lex total_lex.
Canonical Structure prod_ordType := Eval hnf in OrdType (K * T) prod_ordMixin.
End ProdOrd.

Section SumOrd.
Variables L R : ordType.

(* lexicographic ordering of sums, preferring left first *)
Definition sumlex : rel (L + R) :=
  fun x y =>
    match x, y with
    | inl x', inl y' => ord x' y'
    | inr x', inr y' => ord x' y'
    | inl _, _ => true
    | _, _ => false
    end.

Lemma irr_sumlex : irreflexive sumlex.
Proof.
  by case ; move=> a ; rewrite /sumlex irr.
Qed.

Lemma trans_sumlex : transitive sumlex.
Proof.
  do !case=>// ;
  do 2!(intro ; case) ;
  do ?apply: trans ; easy.
Qed.

Lemma total_sumlex : forall x y, [|| sumlex x y, x == y | sumlex y x].
Proof.
  do !case=>// ; move=> foo ; case ; do ? apply: total ; easy.
Qed.

Definition sum_ordMixin := OrdMixin irr_sumlex trans_sumlex total_sumlex.
Canonical Structure sum_ordType := Eval hnf in OrdType (L + R) sum_ordMixin.
End SumOrd.

Section FinTypeOrd.
Variable T : finType.

Definition ordf : rel T :=
  fun x y => index x (enum T) < index y (enum T).

Lemma irr_ordf : irreflexive ordf.
Proof. by move=>x; rewrite /ordf ltnn. Qed.

Lemma trans_ordf : transitive ordf.
Proof. by move=>x y z; rewrite /ordf; apply: ltn_trans. Qed.

Lemma total_ordf : forall x y, [|| ordf x y, x == y | ordf y x].
Proof.
move=>x y; rewrite /ordf; case: ltngtP=>//= H; rewrite ?orbT ?orbF //.
have [H1 H2]: x \in enum T /\ y \in enum T by rewrite !mem_enum.
by rewrite -(nth_index x H1) -(nth_index x H2) H eq_refl.
Qed.

Definition fin_ordMixin := OrdMixin irr_ordf trans_ordf total_ordf.
End FinTypeOrd.

(* notation to let us write I_n instead of (ordinal_finType n) *)
Notation "[ 'fin_ordMixin' 'of' T ]" :=
  (fin_ordMixin _ : Ordered.mixin_of [eqType of T]) (at level 0).

Definition ordinal_ordMixin n := [fin_ordMixin of 'I_n].
Canonical Structure ordinal_ordType n := OrdType 'I_n (ordinal_ordMixin n).


(** This file contains some example programs that I can verify
 **)
Require Import Coq.Strings.String.
Require Import McExamples.Hoare.Imp.

Module TestCases (Import Imp : ImpLang).

  Local Notation "x ;; y" := (Seq x y) (at level 30, y at next level).
  Local Notation "x <- y" := (Assign x%string y) (at level 20).
  Local Notation "$ x" := (iVar x%string) (at level 5).
  Let iConst' : nat -> iexpr := iConst.
  Local Coercion iConst' : nat >-> iexpr.

  Local Open Scope string_scope.

  Definition Add1 : icmd :=
    "x"    <- (iPlus $"x" 1).

  Definition Swap : icmd :=
    "temp" <- $"x" ;;
           "x"    <- $"y" ;;
           "y"    <- $"temp".

  Fixpoint Swap_n (ls : list (string * string)) : icmd :=
    match ls with
    | nil => Skip
    | cons (x,y) ls =>
      Seq (Assign "temp" (iVar x))
          (Seq (Assign x (iVar y))
               (Seq (Assign y (iVar "temp"))
                    (Swap_n ls)))
    end.

(*
  Fixpoint Swap_ptr_n (ls : list (string * string)) : icmd :=
    match ls with
    | nil => Skip
    | cons (x,y) ls =>
      Seq (Read "temp1" (iVar x))
          (Seq (Read "temp2" (iVar y))
               (Seq (Assign x (iVar "temp2"))
                    (Seq (Assign y (iVar "temp1"))
                         (Swap_ptr_n ls))))
    end.
*)

  Definition IfZero : icmd :=
    If $"x"
       ("y" <- 1)
       ("y" <- 0).

  (*
Definition While : icmd :=
  While (iLt $"x" 10)
        ("x" <- iPlus $"x" 1).
   *)

  Fixpoint adds (n : nat) :=
    match n with
    | 0 => Skip
    | 1 => (Assign "x" (iPlus (iVar "x") (iConst 1)))
    | S n => Seq (Assign "x" (iPlus (iVar "x") (iConst 1))) (adds n)
    end%string.

  Fixpoint skips (n : nat) :=
    match n with
    | 0 => Skip
    | S n => Seq Skip (skips n)
    end%string.
End TestCases.


Require Import STLCNew LibLN.
Require Import Coq.Program.Tactics.

(**** Values in the cbv STLC ****)

Inductive STValue : SExp -> Prop :=
  | STValue_Lam :
      forall t1, STTerm (STLam t1) -> STValue (STLam t1)
  | STValue_Lit : forall n, STValue (STLit n)
  | STValue_Unit : STValue STUnit
  | STValue_Pair : forall v1 v2, STValue v1 -> STValue v2 -> STValue (STPair v1 v2).

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  STValue e -> STTerm e.
Proof.
  induction 1; autos*.
Qed.

Hint Resolve value_regular.

Definition relation := SExp -> SExp -> Prop.

(** Call-by-value **)
Inductive STred : relation :=
  | red_beta : forall t1 t2,
      STTerm (STLam t1) ->
      STValue t2 ->
      STred (STApp (STLam t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      STTerm t2 ->
      STred t1 t1' ->
      STred (STApp t1 t2) (STApp t1' t2)
  | red_app_2 : forall t1 t2 t2',
      STValue t1 ->
      STred t2 t2' ->
      STred (STApp t1 t2) (STApp t1 t2')
  | red_pair_1 : forall t1 t1' t2,
      STTerm t2 ->
      STred t1 t1' ->
      STred (STPair t1 t2) (STPair t1' t2)
  | red_pair_2 : forall t1 t2 t2',
      STValue t1 ->
      STred t2 t2' ->
      STred (STPair t1 t2) (STPair t1 t2')
  | red_proj1_1 : forall t1 t1',
      STred t1 t1' ->
      STred (STProj1 t1) (STProj1 t1')
  | red_proj1_2 : forall t1 t2,
      STValue (STPair t1 t2) ->
      STred (STProj1 (STPair t1 t2)) t1
  | red_proj2_1 : forall t1 t1',
      STred t1 t1' ->
      STred (STProj2 t1) (STProj2 t1')
  | red_proj2_2 : forall t1 t2,
      STValue (STPair t1 t2) ->
      STred (STProj2 (STPair t1 t2)) t2.

(** Full reduction **)
Inductive fullred : relation :=
  | fullred_beta : forall t1 t2,
      body t1 ->
      STTerm t2 ->
      fullred (STApp (STLam t1) t2) (t1 ^^ t2)
  | fullred_abs : forall L t1 t1',
      (forall x, x \notin L -> fullred (open t1 (STFVar x)) (open t1' (STFVar x))) ->
      fullred (STLam t1) (STLam t1')
  | fullred_app_1 : forall t1 t1' t2,
      STTerm t2 ->
      fullred t1 t1' ->
      fullred (STApp t1 t2) (STApp t1' t2)
  | fullred_app_2 : forall t1 t2 t2',
      STTerm t1 ->
      fullred t2 t2' ->
      fullred (STApp t1 t2) (STApp t1 t2')
  | fullred_pair_1 : forall t1 t1' t2,
      STTerm t2 ->
      fullred t1 t1' ->
      fullred (STPair t1 t2) (STPair t1' t2)
  | fullred_pair_2 : forall t1 t2 t2',
      STTerm t1 ->
      fullred t2 t2' ->
      fullred (STPair t1 t2) (STPair t1 t2')
  | fullred_proj1_1 : forall t1 t1',
      fullred t1 t1' ->
      fullred (STProj1 t1) (STProj1 t1')
  | fullred_proj1_2 : forall t1 t2,
      STTerm (STPair t1 t2) ->
      fullred (STProj1 (STPair t1 t2)) t1
  | fullred_proj2_1 : forall t1 t1',
      fullred t1 t1' ->
      fullred (STProj2 t1) (STProj2 t1')
  | fullred_proj2_2 : forall t1 t2,
      STTerm (STPair t1 t2) ->
      fullred (STProj2 (STPair t1 t2)) t2.

Hint Constructors STred fullred STTerm.

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

(* ********************************************************************** *)
(** * Infrastructure *)

Lemma fullred_regular : forall e e',
  fullred e e' -> STTerm e /\ STTerm e'.
Proof.
  induction 1; destruct_conjs; split; eauto; try inverts* H;
  apply_fresh STTerm_Lam as x; forwards* H2 : H0 x.
Qed.

Hint Extern 1 (STTerm ?t) =>
  match goal with
  | H: fullred t _ |- _ => apply (proj1 (fullred_regular H))
  | H: fullred _ t |- _ => apply (proj2 (fullred_regular H))
  end.

Hint Constructors has_type_st STred STValue.

(* ********************************************************************** *)
(** * Proofs *)

(** Call-by-value STLC with Pairs: Safety and Progress **)

Definition preservation_statement_stlc := forall E t t' T,
  has_type_st E t T ->
  STred t t' ->
  has_type_st E t' T.

Definition progress_statement_stlc := forall t T,
  has_type_st empty t T -> STValue t \/ exists t', STred t t'.

Lemma preservation_result_stlc : preservation_statement_stlc.
Proof.
  introv Typ. gen t'.
  induction Typ; intros t' Red; inverts* Red.
  inversions Typ1. pick_fresh x. rewrite* (@subst_intro x).
    apply_empty* typing_subst.
  inverts* Typ.
  inverts* Typ.
Qed.

Lemma progress_result_stlc : progress_statement_stlc.
Proof.
  introv Typ. gen_eq E: (empty:ctx). lets Typ': Typ.
  induction Typ; intros; substs*.
  - false* binds_empty_inv.
  - right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
    inverts* Typ1; inverts* Val1.
    + exists* (STApp t1 t2').
    + exists* (STApp t1' t2).
  - destruct~ IHTyp1 as [Val1 | [t1' Red1]];
    destruct~ IHTyp2 as [Val2 | [t2' Red2]]; autos*.
  - destruct~ IHTyp as [Val | [t' Red]]; autos*.
    right.
    inverts* Typ; [ false* binds_empty_inv | | | ]; inverts* Val.
  - destruct~ IHTyp as [Val | [t' Red]]; autos*.
    right.
    inverts* Typ; [ false* binds_empty_inv | | | ]; inverts* Val.
Qed.

Lemma preservation_for_full_reduction : forall E t t' T,
  has_type_st E t T ->
  t -->> t' ->
  has_type_st E t' T.
Proof.
  introv Typ. gen t'.
  induction Typ; intros t' Red; inversions Red; eauto.
  apply_fresh* STTyLam as x.
  inversions Typ1. pick_fresh x.
    rewrite* (@subst_intro x). apply_empty* typing_subst.
  inverts* Typ.
  inverts* Typ.
Qed.

(* ********************************************************************** *)
(** Definition of the reflexive-symmetric-transitive closure of a relation *)

Inductive equiv_ (R : relation) : relation :=
  | equiv_refl : forall t,
      STTerm t ->
      equiv_ R t t
  | equiv_sym: forall t t',
      equiv_ R t t' ->
      equiv_ R t' t
  | equiv_trans : forall t2 t1 t3,
      equiv_ R t1 t2 -> equiv_ R t2 t3 -> equiv_ R t1 t3
  | equiv_step : forall t t',
      R t t' -> equiv_ R t t'.

Notation "R 'equiv'" := (equiv_ R) (at level 69).

(* ********************************************************************** *)
(** Definition of the reflexive-transitive closure of a relation *)

Inductive star_ (R : relation) : relation :=
  | star_refl : forall t,
      STTerm t ->
      star_ R t t
  | star_trans : forall t2 t1 t3,
      star_ R t1 t2 -> star_ R t2 t3 -> star_ R t1 t3
  | star_step : forall t t',
      R t t' -> star_ R t t'.

Notation "R 'star'" := (star_ R) (at level 69).

(* ********************************************************************** *)
(** Definition of confluence and of the Church-Rosser property
 (Our goal is to prove the Church-Rosser Property for beta relation) *)

(** TODO: prove this following Chargueraud's system **)

Definition confluence (R : relation) :=
  forall M S T, R M S -> R M T ->
  exists P, R S P /\ R T P.

Definition church_rosser (R : relation) :=
  forall t1 t2, (R equiv) t1 t2 ->
  exists t, (R star) t1 t /\ (R star) t2 t.