From Coq Require Import Reals Psatz.
From Coq.ssr Require Import ssreflect ssrfun.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy.
From stdpp Require Export countable.
From self.prelude Require Export base Coquelicot_ext Reals_ext.
From self.prob Require Export countable_sum distribution.

Open Scope R.

Section couplings.
  Context `{Countable A, Countable B, Countable A', Countable B'}.
  Context (μ1 : distr A) (μ2 : distr B) (R : A -> B -> Prop) (S : A' → B' → Prop).

  Definition isCoupl (μ : distr (A * B)) : Prop :=
    lmarg μ = μ1 ∧ rmarg μ = μ2.

  Definition coupl :=
    ∃ (μ : distr (A * B)), isCoupl μ.

  Definition isRcoupl (μ : distr (A * B)) : Prop :=
    isCoupl μ ∧ (∀ (p : A * B), (μ p > 0) -> R (fst p) (snd p)).

  Definition Rcoupl :=
    ∃ (μ : distr (A * B)), isRcoupl μ.

  Lemma isRcoupl_isCoupl μ : isRcoupl μ -> isCoupl μ.
  Proof.
    intro C; destruct C; auto.
  Qed.

  Lemma isCoupl_mass_l μ : isCoupl μ -> SeriesC μ = SeriesC μ1.
  Proof.
    intro Hμ.
    destruct Hμ as (Hμl & Hμr).
    rewrite <- Hμl.
    rewrite /lmarg.
    rewrite <- dmap_mass.
    auto.
  Qed.

  Lemma isCoupl_mass_r μ : isCoupl μ -> SeriesC μ = SeriesC μ2.
  Proof.
    intro Hμ.
    destruct Hμ as (Hμl & Hμr).
    rewrite <- Hμr.
    rewrite /rmarg.
    rewrite <- dmap_mass.
    auto.
  Qed.

  Lemma isCoupl_mass_eq μ : isCoupl μ -> SeriesC μ1 = SeriesC μ2.
  Proof.
    intro Hμ.
    rewrite <- (isCoupl_mass_l μ); auto.
    rewrite <- (isCoupl_mass_r μ); auto.
  Qed.

End couplings.

Section couplings_theory.
  Context `{Countable A, Countable B, Countable A', Countable B'}.

  Lemma isCoupl_dret (a : A) (b : B) :
    isCoupl (dret a) (dret b) (dret (a, b)).
  Proof.
    split; [rewrite /lmarg dmap_dret // |rewrite /rmarg dmap_dret //].
  Qed.

  Lemma coupl_dret (a : A) (b : B) :
    coupl (dret a) (dret b).
  Proof.
    exists (dret (a, b)).
    apply isCoupl_dret.
  Qed.

  Lemma isRcoupl_dret (a : A) (b : B) (R : A → B → Prop) :
    R a b → isRcoupl (dret a) (dret b) R (dret (a, b)).
  Proof.
    split; [apply isCoupl_dret |].
    intro p.
    rewrite /pmf /= /dret_pmf /=.
    case_bool_decide as Hp; [rewrite Hp //| lra].
  Qed.

  Lemma Rcoupl_dret (a : A) (b : B) (R : A → B → Prop) :
    R a b → Rcoupl (dret a) (dret b) R.
  Proof.
    exists (dret (a, b)).
    apply isRcoupl_dret.
    auto.
  Qed.

  Lemma Rcoupl_mass_eq (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) :
    Rcoupl μ1 μ2 R → SeriesC μ1 = SeriesC μ2.
  Proof. intros (?&?&?). by eapply isCoupl_mass_eq. Qed.

  Lemma Rcoupl_eq (μ1 : distr A) :
    Rcoupl μ1 μ1 (=).
  Proof.
    exists (ddiag μ1); split; [split | ].
    + apply distr_ext.
      intro a.
      rewrite lmarg_pmf.
      rewrite {1}/pmf/=/dbind_pmf/=.
      rewrite SeriesC_singleton'; auto.
    + apply distr_ext.
      intro a.
      rewrite rmarg_pmf.
      rewrite {1}/pmf/=/dbind_pmf/=.
      (* TODO: Need lemma to rewrite these singletons *)
      rewrite (SeriesC_ext _ (λ a0 : A, if bool_decide (a0 = a) then μ1 a else 0));
      [rewrite SeriesC_singleton; auto | ].
      intro a'; case_bool_decide; simplify_eq; auto.
    + intros (a1 & a2) Hpos; simpl.
      rewrite /pmf/= in Hpos.
      case_bool_decide; simplify_eq; auto; lra.
  Qed.

  Lemma coupl_sym (μ1 : distr A) (μ2 : distr B) :
    coupl μ1 μ2 -> coupl μ2 μ1.
  Proof.
    intros (μ & HμL & HμR).
    exists (dmap (λ '(a, b), (b, a)) μ); split; apply distr_ext.
    + intro b.
      rewrite <- HμR.
      rewrite lmarg_pmf rmarg_pmf.
      apply SeriesC_ext; intro a.
      simpl.
      rewrite {1}/pmf /= /dbind_pmf /=.
      rewrite {2}/pmf /= /dret_pmf /=.
      assert (∀ a0, μ a0 * (if bool_decide ((b, a) = (let '(a1, b0) := a0 in (b0, a1))) then 1 else 0)
                    = if bool_decide ((a, b) = a0 ) then μ (a, b) else 0) as Heq1.
      { intros (a' & b').
        case_bool_decide; case_bool_decide; simplify_eq; try lra.
      }
      rewrite (SeriesC_ext _ _ Heq1).
      apply SeriesC_singleton'.
    + intro a.
      rewrite <- HμL.
      rewrite lmarg_pmf rmarg_pmf.
      apply SeriesC_ext; intro b.
      simpl.
      rewrite {1}/pmf /= /dbind_pmf /=.
      rewrite {2}/pmf /= /dret_pmf /=.
      assert (∀ a0, μ a0 * (if bool_decide ((b, a) = (let '(a1, b0) := a0 in (b0, a1))) then 1 else 0)
                    = if bool_decide ((a, b) = a0 ) then μ (a, b) else 0) as Heq1.
      { intros (a' & b').
        case_bool_decide; case_bool_decide; simplify_eq; try lra. }
      rewrite (SeriesC_ext _ _ Heq1).
      apply SeriesC_singleton'.
  Qed.

  Lemma coupl_dbind (f : A → distr A') (g : B → distr B') (μ1 : distr A) (μ2 : distr B) :
    (∀ a b, coupl (f a) (g b)) → coupl μ1 μ2 → coupl (dbind f μ1) (dbind g μ2).
  Proof.
    intros Hfg (μ & Hμ).
    rewrite /coupl in Hfg.
    assert (∀ (p : A * B), ∃ μ : distr (A' * B'), isCoupl (f p.1) (g p.2) μ) as Hfg'; auto.
    pose proof (Choice (A * B) (distr (A' * B')) _ Hfg') as Ch.
    rewrite /coupl.
    destruct Ch as (Ch & HCh).
    exists (dbind Ch μ); split.
    + apply distr_ext; intro a'.
      rewrite lmarg_pmf.
      rewrite {1 2}/pmf/=/dbind_pmf.
      rewrite <- distr_double_swap_lmarg.
      setoid_rewrite SeriesC_scal_l.
      assert (∀ p , μ p * SeriesC (λ b' : B', Ch p (a', b')) = μ p * f p.1 a') as Heq2.
      { intros (a & b).
        specialize (HCh (a, b)) as (HChL & HChR).
        rewrite <- HChL.
        rewrite lmarg_pmf.
        auto.
      }
      rewrite (SeriesC_ext _ _ Heq2).
      rewrite fubini_pos_seriesC_prod_lr; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      assert (∀ a : A, SeriesC (λ b : B, μ (a, b) * f (a, b).1 a')
               = SeriesC (λ b : B, μ (a, b) ) * f a a') as Heq3.
      {
        intro a; simpl; apply SeriesC_scal_r.
      }
      rewrite (SeriesC_ext _ _ Heq3).
      assert (∀ a, SeriesC (λ b : B, μ (a, b)) = μ1 a) as Heq4.
      {
        intro a.
        destruct Hμ as (Hμ1 & Hμ2).
        rewrite <- Hμ1;
        rewrite lmarg_pmf; auto.
      }
      apply SeriesC_ext.
      intro a.
      rewrite (Heq4 a); auto.
    (* The second half is esentially the same as the first, can it be proven somehow by symmetry? *)
    + apply distr_ext; intro b'.
      rewrite rmarg_pmf.
      rewrite {1 2}/pmf/=/dbind_pmf.
      rewrite <- distr_double_swap_rmarg.
      setoid_rewrite SeriesC_scal_l.
      assert (∀ p , μ p * SeriesC (λ a' : A', Ch p (a', b')) = μ p * g p.2 b') as Heq2.
      { intros (a & b).
        specialize (HCh (a, b)) as (HChL & HChR).
        rewrite <- HChR.
        rewrite rmarg_pmf.
        auto.
      }
      rewrite (SeriesC_ext _ _ Heq2).
      rewrite fubini_pos_seriesC_prod_rl; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      assert (∀ b : B, SeriesC (λ a : A, μ (a, b) * g (a, b).2 b')
               = SeriesC (λ a : A, μ (a, b) ) * g b b') as Heq3.
      {
        intro b; simpl; apply SeriesC_scal_r.
      }
      rewrite (SeriesC_ext _ _ Heq3).
      assert (∀ b, SeriesC (λ a : A, μ (a, b)) = μ2 b) as Heq4.
      {
        intro b.
        destruct Hμ as (Hμ1 & Hμ2).
        rewrite <- Hμ2;
        rewrite rmarg_pmf; auto.
      }
      apply SeriesC_ext.
      intro b.
      rewrite (Heq4 b); auto.
  Qed.

  Lemma Rcoupl_dbind (f : A → distr A') (g : B → distr B')
    (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (S : A' → B' → Prop) :
      (∀ a b, R a b → Rcoupl (f a) (g b) S) → Rcoupl μ1 μ2 R → Rcoupl (dbind f μ1) (dbind g μ2) S.
  Proof.
    intros Hfg (μ & HμC & HμS).
    rewrite /Rcoupl /isRcoupl in Hfg.
    (* First we rewrite Hfg to be able to use Choice *)
    assert (∀ p, ∃ μ', R p.1 p.2 →
                       (isCoupl (f p.1) (g p.2) μ' ∧ (∀ q : A' * B', μ' q > 0 → S q.1 q.2)))
      as Hfg'; auto.
    {
      intro p.
      specialize (HμS p).
      specialize (Hfg p.1 p.2).
      pose proof (ExcludedMiddle (R p.1 p.2)) as H3; destruct H3 as [HR | HnR].
      + specialize (Hfg HR).
        destruct Hfg as (μ' & Hμ'1 & Hμ'2).
        exists μ'; auto.
      + exists dzero; intro ; done.
    }
    pose proof (Choice (A * B) (distr (A' * B')) _ Hfg') as (Ch & HCh).
    rewrite /Rcoupl /isRcoupl.
    exists (dbind Ch μ); split; try split.
 (* To prove that the first marginal coincides is a matter of rearranging the sums and using the
    fact that μ and (Ch p) are couplings *)
    + apply distr_ext; intro a'.
      rewrite lmarg_pmf.
      rewrite {1 2}/pmf/=/dbind_pmf.
      rewrite <- distr_double_swap_lmarg.
      setoid_rewrite SeriesC_scal_l.
      erewrite (SeriesC_ext _ (λ p, μ p * f p.1 a')); last first.
      { intros (a & b).
        destruct (Rtotal_order (μ (a, b)) 0) as [Hlt | [Heqz | Hgt]].
        - pose proof (pmf_pos μ (a, b)); lra.
        - rewrite Heqz; lra.
        - specialize (HCh (a, b) (HμS (a, b) Hgt )) as ((HChL & HChR) & HChS).
          rewrite -HChL lmarg_pmf //=. }
      rewrite fubini_pos_seriesC_prod_lr; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      erewrite (SeriesC_ext _ (λ a, SeriesC (λ b : B, μ (a, b) ) * f a a'));
      [ | intro a; simpl; apply SeriesC_scal_r ].
      erewrite (SeriesC_ext _ (λ a, (μ1 a) * f a a')); auto.
      intro a.
      destruct HμC as (Hμ1 & Hμ2).
      rewrite <- Hμ1;
      rewrite lmarg_pmf; auto.
    (* The second half is esentially the same as the first, can it be proven somehow by symmetry? *)
    + apply distr_ext; intro b'.
      rewrite rmarg_pmf.
      rewrite {1 2}/pmf/=/dbind_pmf.
      rewrite <- distr_double_swap_rmarg.
      setoid_rewrite SeriesC_scal_l.
      erewrite (SeriesC_ext _ (λ p, μ p * g p.2 b')); last first.
      {intros (a & b);
        destruct (Rtotal_order (μ (a, b)) 0) as [Hlt | [Heqz | Hgt]];
        [ pose proof (pmf_pos μ (a, b)); lra | rewrite Heqz; lra |
        specialize (HCh (a, b) (HμS (a, b) Hgt)) as ((HChL & HChR) & HChS);
        rewrite -HChR rmarg_pmf //=].
       }
      rewrite fubini_pos_seriesC_prod_rl; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      erewrite (SeriesC_ext _ (λ b, SeriesC (λ a : A, μ (a, b) ) * g b b'));
      [ | intro b; simpl; apply SeriesC_scal_r].
      erewrite (SeriesC_ext _ (λ b, (μ2 b) * g b b')); auto.
      intro b.
      destruct HμC as (Hμ1 & Hμ2).
      rewrite <- Hμ2;
      rewrite rmarg_pmf; auto.
    + intros (a' & b') H3; simpl.
      pose proof (dbind_pos_support Ch μ (a', b')) as (H4 & H5).
      specialize (H4 H3) as ((a0, b0) & H7 & H8).
      specialize (HCh (a0, b0) (HμS (a0, b0) H8)) as (HCh1 & HCh2).
      specialize (HCh2 (a', b') H7).
      done.
  Qed.

  Lemma Rcoupl_eq_elim (μ1 μ2 : distr A) :
    Rcoupl μ1 μ2 (=) → μ1 = μ2.
  Proof.
    intros (μ & (HμL & HμR) & HμS).
    rewrite <- HμL, <- HμR.
    apply distr_ext.
    intro a1.
    rewrite lmarg_pmf rmarg_pmf.
    apply SeriesC_ext.
    intro a2.
    specialize (HμS (a1, a2)) as HμS12.
    specialize (HμS (a2, a1)) as HμS21.
    simpl in HμS12.
    simpl in HμS21.
    pose proof (Rtotal_order (μ (a1, a2)) (μ (a2, a1))) as [Hlt | [Heq | Hgt]]; auto.
    + pose proof (pmf_pos μ (a1, a2)).
      assert (μ (a2, a1) > 0) as H'; try lra.
      specialize (HμS21 H'); destruct HμS21; auto.
    + pose proof (pmf_pos μ (a2, a1)).
      assert (μ (a1, a2) > 0) as H'; try lra.
      specialize (HμS12 H'); destruct HμS12; auto.
  Qed.

  Lemma Rcoupl_eq_sym (μ1 μ2: distr A) :
    Rcoupl μ1 μ2 eq → Rcoupl μ2 μ1 eq.
  Proof.
    intros Hc.
    apply Rcoupl_eq_elim in Hc as ->; auto.
    apply Rcoupl_eq.
  Qed.

  Lemma Rcoupl_eq_trans (μ1 μ2 μ3 : distr A) :
    Rcoupl μ1 μ2 eq → Rcoupl μ2 μ3 eq → Rcoupl μ1 μ3 eq.
  Proof. by intros ->%Rcoupl_eq_elim ?. Qed.

  Lemma Rcoupl_weaken (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (S : A → B → Prop):
    Rcoupl μ1 μ2 R → (∀ a b, R a b -> S a b) → Rcoupl μ1 μ2 S.
  Proof.
    intros [μ [[HμL HμR] HμSupp]] Hwk.
    exists μ; split; [split | ]; auto.
  Qed.
  Definition Rcoupl_impl μ1 μ2 R S H RC := Rcoupl_weaken μ1 μ2 R S RC H.

  Lemma Rcoupl_inhabited_l (μ1 : distr A) (μ2 : distr B) R :
    Rcoupl μ1 μ2 R →
    SeriesC μ1 > 0 →
    ∃ a b, R a b.
  Proof.
    intros [μ [Hcpl HR]] Hz.
    assert (SeriesC μ > 0) as Hsup by by erewrite isCoupl_mass_l.
    apply SeriesC_gtz_ex in Hsup as [[a b] Hμ]; [|done].
    eauto.
  Qed.

  Lemma Rcoupl_inhabited_r (μ1 : distr A) (μ2 : distr B) R :
    Rcoupl μ1 μ2 R →
    SeriesC μ2 > 0 →
    ∃ a b, R a b.
  Proof.
    intros [μ [Hcpl HR]] Hz.
    assert (SeriesC μ > 0) as Hsup by by erewrite isCoupl_mass_r.
    apply SeriesC_gtz_ex in Hsup as [[a b] Hμ]; [|done].
    eauto.
  Qed.

End couplings_theory.

(* TODO: cleanup *)
Section Rcoupl.
  Context `{Countable A, Countable B}.
  Variable (μ1 : distr A) (μ2 : distr B).

  Lemma Rcoupl_trivial :
    SeriesC μ1 = 1 ->
    SeriesC μ2 = 1 ->
    Rcoupl μ1 μ2 (λ _ _, True).
  Proof.
    intros Hμ1 Hμ2.
    exists (dprod μ1 μ2). split; [|done].
    split; [apply lmarg_dprod|apply rmarg_dprod]; done.
  Qed.

  Lemma Rcoupl_pos_R R :
    Rcoupl μ1 μ2 R → Rcoupl μ1 μ2 (λ a b, R a b ∧ μ1 a > 0 ∧ μ2 b > 0).
  Proof.
    intros [μ [[Hμ1 Hμ2] HR]].
    exists μ. split; [done|].
    intros [a b] Hρ. split; [auto|].
    rewrite -Hμ1 -Hμ2.
    rewrite 2!dmap_pos.
    split; eauto.
  Qed.

End Rcoupl.

Lemma Rcoupl_dzero_r_inv `{Countable A, Countable B} μ1 (R : A → B → Prop) :
  Rcoupl μ1 dzero R → μ1 = dzero.
Proof.
  intros Hz%Rcoupl_mass_eq.
  apply SeriesC_zero_dzero.
  rewrite Hz SeriesC_0 //.
Qed.

Lemma Rcoupl_dzero_l_inv `{Countable A, Countable B} μ2 (R : A → B → Prop) :
  Rcoupl dzero μ2 R → μ2 = dzero.
Proof.
  intros Hz%Rcoupl_mass_eq.
  apply SeriesC_zero_dzero.
  rewrite -Hz SeriesC_0 //.
Qed.

Lemma Rcoupl_map `{Countable A, Countable B, Countable A', Countable B'}
  (f : A → A') (g : B → B') (μ1 : distr A) (μ2 : distr B) (R : A' → B' → Prop) :
  Rcoupl μ1 μ2 (λ a a', R (f a) (g a')) → Rcoupl (dmap f μ1) (dmap g μ2) R.
Proof.
  intros Hcoupl. rewrite /dmap.
  eapply (Rcoupl_dbind _ _ _ _ (λ (a : A) (a' : B), R (f a) (g a'))); auto.
  intros a b Hab.
  apply (Rcoupl_dret (f a) (g b) R Hab).
Qed.

(* I think this should be true, maybe it can be proven through Strassens theorem, but
  I don't see how to do it directly *)
(*
  Lemma Rcoupl_from_mapL `{Countable A, Countable B, Countable A', Countable B'}:
    forall (f : A → A') (μ1 : distr A) (μ2 : distr B) (R : A' → B → Prop),
      Rcoupl (dmap f μ1) μ2 R -> Rcoupl μ1 μ2 (λ a b, R (f a) b).
  Proof.
    intros f μ1 μ2 R (μ & ((HμL & HμR) & HμSup)).
    eexists (dprod μ1 μ2).
    split; [split | ].

    eexists (MkDistr (λ '(a, b), μ (f a , g b)) _ _ _).

  Qed.
 *)

(* TODO: move somewhere else *)
Definition f_inv {A B} f `{Surj A B (=) f} : B → A := λ b, epsilon (surj f b).

Lemma f_inv_cancel_r {A B} f `{Surj A B (=) f} b :
  f (f_inv f b) = b.
Proof. rewrite /f_inv /= (epsilon_correct _ (surj f b)) //. Qed.

Lemma f_inv_cancel_l {A B} f `{Inj A B (=) (=) f, Surj A B (=) f} b :
  f_inv f (f b) = b.
Proof. apply (inj f), (epsilon_correct _ (surj f (f b))). Qed.

Lemma Rcoupl_fair_coin f `{Inj bool bool (=) (=) f, Surj bool bool (=) f} :
  Rcoupl fair_coin fair_coin (λ b b', b = f b').
Proof.
  exists (fair_coins f). repeat split.
  - eapply distr_ext=> b.
    rewrite lmarg_pmf /pmf /= /fair_coins_pmf /fair_coin_pmf /=.
    rewrite (SeriesC_ext _ (λ b', if bool_decide (b' = f_inv f b) then 0.5 else 0)).
    { rewrite SeriesC_singleton //. }
    intros b'. case_bool_decide as Heq.
    + rewrite bool_decide_eq_true_2 //.
      rewrite Heq f_inv_cancel_l //.
    + rewrite bool_decide_eq_false_2 //.
      intros [= ->]. apply Heq. rewrite f_inv_cancel_r //.
  - eapply distr_ext=> b.
    rewrite rmarg_pmf /pmf /= /fair_coins_pmf /fair_coin_pmf /=.
    rewrite SeriesC_singleton //.
  - intros []. rewrite /pmf /= /fair_coins_pmf /=.
    case_bool_decide; [done|lra].
Qed.

(* NB: Classical proof, but should be possible to make constructive
       TODO: finish
*)

Local Lemma pigeonhole_aux1 n f `{Inj nat nat (=) (=) f, Surj nat nat (=) f} :
  (forall m, (m <= n)%nat -> (f m <= n)%nat) ->
  (forall m, (m <= n)%nat -> exists p, (p <= n)%nat /\ f p = m).
Proof.
  induction n.
  - intros Hdom m Hm.
    inversion Hm; simplify_eq.
    exists 0%nat; split; auto.
    specialize (Hdom 0%nat (le_refl 0%nat)); auto with arith.
  - intros Hdom m Hm.
    pose proof (ExcludedMiddle (∀ m : nat, m ≤ n → f m ≤ n)) as [Hem | Hem].
    + specialize (IHn Hem).
      inversion Hm.
      * admit.
      * destruct (IHn m) as [p [Hp1  Hp2]]; auto.
        exists p; split; auto with arith.
    + apply not_forall_exists_not in Hem as [x Hx].
Admitted.

Local Lemma pigeonhole_aux2 n f `{Inj nat nat (=) (=) f, Surj nat nat (=) f} :
  (forall m, (m <= n)%nat -> (f m <= n)%nat) ->
  (forall m, (f m <= n)%nat -> (m <= n)%nat).
Proof.
  intros Hdom m Hfm.
  pose proof (H0 m) as [x Hx].
  pose proof (pigeonhole_aux1 n f Hdom (f m) Hfm) as [y [Hy1 Hy2]].
  specialize (H y m Hy2); simplify_eq; auto.
Qed.

Lemma Rcoupl_unif_distr n f `{Inj nat nat (=) (=) f, Surj nat nat (=) f} :
  (forall m, (m <= n)%nat -> (f m <= n)%nat) ->
  Rcoupl (unif_distr n) (unif_distr n) (λ m m', m' = f m).
Proof.
  intro Hdom.
  exists (dbind (λ x, dret (x, f x)) (unif_distr n)); repeat split.
  - eapply distr_ext=> y1.
    rewrite lmarg_pmf.
    erewrite (SeriesC_ext _ (λ y2, if bool_decide ( (0 <= y1 <= n)%nat  /\ y2 = f y1) then / (INR n + 1) else 0)); last first.
    { intro. case_bool_decide as H1; destruct_and?; simplify_eq.
      - apply dbind_dret_unif_nonzero.
        + intros ? ? ?; simplify_eq; auto.
        + exists y1; auto.
      - apply dbind_dret_unif_zero.
        intros ? ? ?; simplify_eq; apply H1; auto.
    }
    rewrite /pmf/=.
    case_bool_decide as H1.
    + erewrite (SeriesC_ext); [apply (SeriesC_singleton (f y1)) | ].
      intro; simpl.
      case_bool_decide as H2; case_bool_decide; destruct_and?; simplify_eq; auto.
      destruct H2; auto with arith.
    + erewrite (SeriesC_ext _ (λ x, 0)); [apply (SeriesC_0); auto | ].
      intro.
      case_bool_decide; destruct_and?; simplify_eq; auto.
      destruct H1; auto.
  - eapply distr_ext=> y2.
    rewrite rmarg_pmf.
    erewrite (SeriesC_ext _ (λ y1, if bool_decide ( (0 <= y1 <= n)%nat  /\ y2 = f y1) then / (INR n + 1) else 0)); last first.
    { intro n0. case_bool_decide as H1; destruct_and?; simplify_eq.
      - apply dbind_dret_unif_nonzero.
        + intros ? ? ?; simplify_eq; auto.
        + exists n0; auto.
      - apply dbind_dret_unif_zero.
        intros ? ? ?; simplify_eq; apply H1; auto.
    }
    rewrite /pmf/=.
    case_bool_decide as H1.
    + erewrite (SeriesC_ext).
      * apply (SeriesC_singleton_inj y2 f); auto.
      * intro y1; case_bool_decide as H2; case_bool_decide; destruct_and?; simplify_eq; auto.
        destruct H2; split; auto; split; auto with arith.
        apply (pigeonhole_aux2 n f); auto.
    + erewrite (SeriesC_ext); [apply SeriesC_0; done | ].
      intro m; simpl.
      case_bool_decide; destruct_and?; simplify_eq; auto.
      destruct H1.
      apply Hdom; done.
   - intros (m1 & m2) Haux; simpl.
     rewrite /pmf/=/dbind_pmf in Haux.
     apply SeriesC_gtz_ex in Haux as [l Hl]; auto.
     + rewrite /pmf/=/dret_pmf/= in Hl.
       case_bool_decide; case_bool_decide; destruct_and?; simplify_eq; auto; lra.
     + intro; rewrite /pmf/=/dret_pmf.
       case_bool_decide; case_bool_decide; try lra.
       rewrite Rmult_1_r.
       left; apply RinvN_pos.
Qed.

Lemma Rcoupl_fair_conv_comb `{Countable A, Countable B}
  f `{Inj bool bool (=) (=) f, Surj bool bool (=) f}
  (S : A → B → Prop) (μ1 μ2 : distr A) (μ1' μ2' : distr B) :
  (∀ a, Rcoupl (if f a then μ1 else μ2) (if a then μ1' else μ2') S) →
  Rcoupl (fair_conv_comb μ1 μ2) (fair_conv_comb μ1' μ2') S.
Proof.
  intros HS. rewrite /fair_conv_comb.
  eapply Rcoupl_dbind; [|apply (Rcoupl_fair_coin f)].
  simpl. intros a b ->.
  done.
Qed.

Lemma Rcoupl_fair_conv_comb_id `{Countable A, Countable B} (S : A → B → Prop)
  (μ1 μ2 : distr A) (μ1' μ2' : distr B) :
  Rcoupl μ1 μ1' S →
  Rcoupl μ2 μ2' S →
  Rcoupl (fair_conv_comb μ1 μ2) (fair_conv_comb μ1' μ2') S.
Proof.
  intros HS1 HS2.
  eapply (Rcoupl_fair_conv_comb id).
  intros []; (eapply Rcoupl_impl; [|done]); eauto.
Qed.

Lemma Rcoupl_fair_conv_comb_neg `{Countable A, Countable B} (S : A → B → Prop)
  (μ1 μ2 : distr A) (μ1' μ2' : distr B) :
  Rcoupl μ1 μ2' S →
  Rcoupl μ2 μ1' S →
  Rcoupl (fair_conv_comb μ1 μ2) (fair_conv_comb μ1' μ2') S.
Proof.
  intros HS1 HS2.
  eapply (Rcoupl_fair_conv_comb negb).
  intros []; (eapply Rcoupl_impl; [|done]); eauto.
Qed.

(* This is a lemma about convex combinations, but it is easier to prove with couplings
     TODO: find a better place to put it in *)
Lemma fair_conv_comb_dbind `{Countable A, Countable B} (μ1 μ2 : distr A) (f : A -> distr B) :
  dbind f (fair_conv_comb μ1 μ2) = fair_conv_comb (dbind f μ1) (dbind f μ2).
Proof.
  rewrite /fair_conv_comb -dbind_assoc.
  apply Rcoupl_eq_elim.
  eapply (Rcoupl_dbind _ _ _ _ (=)); [ | apply Rcoupl_eq].
  intros b1 b2 ->.
  destruct b2; apply Rcoupl_eq.
Qed.

Section Rcoupl_strength.
  Context `{Countable A, Countable B, Countable D, Countable E}.

  Variable (μ1 : distr A) (μ2 : distr B).

  Lemma Rcoupl_strength_l (R : A → B → Prop) (d : D)  :
    Rcoupl μ1 μ2 R →
    Rcoupl (strength_l d μ1) μ2 (λ '(d', a) b, d' = d ∧ R a b).
  Proof.
    rewrite /strength_l /dmap.
    intros Hcpl.
    rewrite -(dret_id_right μ2).
    eapply Rcoupl_dbind; [|done].
    intros. by apply Rcoupl_dret.
  Qed.

  Lemma Rcoupl_strength (R : A → B → Prop) (d : D) (e : E) :
    Rcoupl μ1 μ2 R →
    Rcoupl (strength_l d μ1) (strength_l e μ2)
      (λ '(d', a) '(e', b), d' = d ∧ e' = e ∧ R a b).
  Proof.
    rewrite /strength_l /dmap.
    eapply Rcoupl_dbind.
    intros. by apply Rcoupl_dret.
  Qed.

End Rcoupl_strength.

Section refinement_couplings.
  Context `{Countable A, Countable B, Countable A', Countable B'}.
  Context (μ1 : distr A) (μ2 : distr B) (R : A -> B -> Prop) (S : A' → B' → Prop).

  Definition isRefCoupl (μ : distr (A * B)) : Prop :=
    lmarg μ = μ1 /\ (∀ (b : B), rmarg μ b <= μ2 b).

  Definition refCoupl :=
    ∃ (μ : distr (A * B)), isRefCoupl μ.

  Definition isRefRcoupl (μ : distr (A * B)) : Prop :=
    isRefCoupl μ ∧ (forall (p : A * B), (μ p > 0) -> R (fst p) (snd p)).

  Definition refRcoupl :=
    ∃ (μ : distr (A * B)), isRefRcoupl μ.

  Lemma isRefCoupl_mass_l μ : isRefCoupl μ -> SeriesC μ = SeriesC μ1.
  Proof.
    intro Hμ.
    destruct Hμ as (Hμl & Hμr).
    rewrite <- Hμl.
    rewrite /lmarg.
    rewrite <- dmap_mass.
    auto.
  Qed.

  Lemma isRefCoupl_mass_r μ : isRefCoupl μ -> SeriesC μ <= SeriesC μ2.
  Proof.
    intro Hμ.
    destruct Hμ as (Hμl & Hμr).
    rewrite (dmap_mass μ snd).
    apply SeriesC_le; auto.
  Qed.

  Lemma isRefCoupl_mass_eq μ : isRefCoupl μ -> SeriesC μ1 <= SeriesC μ2.
  Proof.
    intro Hμ.
    rewrite <- (isRefCoupl_mass_l μ); auto.
    apply (isRefCoupl_mass_r μ); auto.
  Qed.

End refinement_couplings.

Section ref_couplings_theory.
  Context `{Countable A, Countable B}.

  Lemma refRcoupl_mass_eq (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) :
    refRcoupl μ1 μ2 R → SeriesC μ1 <= SeriesC μ2.
  Proof. intros (?&?&?). by eapply isRefCoupl_mass_eq. Qed.

  Lemma refRcoupl_eq_elim (μ1 μ2 : distr A) :
    refRcoupl μ1 μ2 (=) → (∀ a, μ1 a <= μ2 a).
  Proof.
    intros (μ & (HμL & HμR) & HμS) a.
    eapply (Rle_Transitive _ (rmarg μ a) _); auto.
    rewrite <- HμL.
    rewrite lmarg_pmf rmarg_pmf.
    eapply SeriesC_le.
    { intro .  specialize (HμS (a,n)). simpl in HμS.
      destruct (Rtotal_order (μ (a,n)) 0) as [? | [? | H3]];
      [ pose proof (pmf_pos μ (a, n)); lra |
       pose proof (pmf_pos μ (n, a)); lra |
      pose proof (HμS H3); simplify_eq; lra ].
    }
    apply ex_distr_rmarg.
  Qed.

  Lemma refRcoupl_from_leq (μ1 μ2 : distr A) :
    (∀ a, μ1 a <= μ2 a) -> refRcoupl μ1 μ2 (=).
  Proof.
    intro Hleq.
    exists (ddiag μ1). split;[ split  | ].
    + apply distr_ext; intro a.
      rewrite lmarg_pmf {2}/pmf/=.
      rewrite SeriesC_singleton'; auto.
    + intro a.
      rewrite ddiag_rmarg.
      auto.
    + intros p Hp.
      rewrite ddiag_pmf in Hp.
      case_bool_decide; auto; lra.
  Qed.

  Lemma refRcoupl_eq_refl (μ1 : distr A):
    refRcoupl μ1 μ1 (=).
  Proof.
    apply refRcoupl_from_leq.
    intro a.
    apply Rle_refl.
  Qed.

  Lemma refRcoupl_eq_trans (μ1 μ2 μ3 : distr A):
    refRcoupl μ1 μ2 (=) → refRcoupl μ2 μ3 (=) → refRcoupl μ1 μ3 (=).
  Proof.
    intros H12 H23.
    pose proof (refRcoupl_eq_elim _ _ H12) as H12'.
    pose proof (refRcoupl_eq_elim _ _ H23) as H23'.
    apply refRcoupl_from_leq.
    intros; eapply Rle_trans; eauto.
  Qed.

  Lemma refRcoupl_eq_refRcoupl_unfoldl (μ1 μ2 μ3 : distr A) R :
    Rcoupl μ1 μ2 (=) → refRcoupl μ2 μ3 R → refRcoupl μ1 μ3 R.
  Proof. by intros ->%Rcoupl_eq_elim ?. Qed.

  Lemma refRcoupl_eq_refRcoupl_unfoldr (μ1 μ2 μ3 : distr A) R :
    refRcoupl μ1 μ2 R → Rcoupl μ2 μ3 (=) → refRcoupl μ1 μ3 R.
  Proof. by intros ? <-%Rcoupl_eq_elim. Qed.

  Lemma isRefCoupl_dret (a : A) (b : B) :
    isRefCoupl (dret a) (dret b) (dret (a, b)).
  Proof.
    split; [rewrite /lmarg dmap_dret // | rewrite /rmarg dmap_dret //].
  Qed.

  Lemma refCoupl_dret (a : A) (b : B) :
    refCoupl (dret a) (dret b).
  Proof.
    exists (dret (a, b)).
    apply isRefCoupl_dret.
  Qed.

  Lemma Rcoupl_refRcoupl (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) :
    Rcoupl μ1 μ2 R → refRcoupl μ1 μ2 R.
  Proof.
    rewrite /refRcoupl /Rcoupl.
    intros (μ & ((HμL & HμR) & HμSupp)).
    exists μ.
    split; auto.
    split; auto.
    intro.
    rewrite HμR; lra.
  Qed.

  Lemma refRcoupl_dret a b (R : A → B → Prop) :
    R a b → refRcoupl (dret a) (dret b) R.
  Proof.
    intros HR.
    eexists. split; [eapply isRefCoupl_dret|].
    intros [] [=<- <-]%dret_pos. done.
  Qed.

  Context `{Countable A', Countable B'}.

  Lemma refRcoupl_dbind (f : A → distr A') (g : B → distr B') (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (S : A' → B' → Prop) :
    (∀ a b, R a b → refRcoupl (f a) (g b) S) → refRcoupl μ1 μ2 R → refRcoupl (dbind f μ1) (dbind g μ2) S.
  Proof.
    intros Hfg (μ & HμC & HμS).
    rewrite /Rcoupl /isRcoupl in Hfg.
    (* First we rewrite Hfg to be able to use Choice *)
    assert (∀ p, ∃ μ' , R p.1 p.2 → (isRefCoupl (f p.1) (g p.2) μ' ∧
                (∀ q : A' * B', μ' q > 0 → S q.1 q.2))) as Hfg'.
    {
      intro p.
      specialize (HμS p).
      specialize (Hfg p.1 p.2).
      pose proof (ExcludedMiddle (R p.1 p.2)) as H3; destruct H3 as [HR | HnR].
      + specialize (Hfg HR).
        destruct Hfg as (μ' & Hμ'1 & Hμ'2).
        exists μ'; auto.
      + exists dzero; intro ; done.
    }
    pose proof (Choice (A * B) (distr (A' * B')) _ Hfg') as (Ch & HCh).
    rewrite /Rcoupl /isRcoupl.
    exists (dbind Ch μ); split; try split.
    (* To prove that the first marginal coincides is a matter of rearranging the sums and using the
    fact that μ and (Ch p) are couplings *)
    + apply distr_ext; intro a'.
      rewrite lmarg_pmf.
      rewrite /pmf /= /dbind_pmf.
      rewrite <- distr_double_swap_lmarg.
      setoid_rewrite SeriesC_scal_l.
      erewrite (SeriesC_ext _ (λ p, μ p * f p.1 a')); last first.
      { intros (a & b).
        destruct (Rtotal_order (μ (a, b)) 0) as [Hlt | [Heqz | Hgt]].
        + pose proof (pmf_pos μ (a, b)); lra.
        + rewrite Heqz; lra.
        + specialize (HCh (a, b) (HμS (a, b) Hgt )) as ((HChL & HChR) & HChS).
          rewrite -HChL lmarg_pmf //=. }
      rewrite fubini_pos_seriesC_prod_lr; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      erewrite (SeriesC_ext _ (λ a, SeriesC (λ b : B, μ (a, b) ) * f a a'));
      [ | intro a; simpl; apply SeriesC_scal_r ].
      erewrite (SeriesC_ext _ (λ a, (μ1 a) * f a a')); auto.
      intro a.
      destruct HμC as (Hμ1 & Hμ2).
      rewrite <- Hμ1;
      rewrite lmarg_pmf; auto.
    + intro b'.
      rewrite rmarg_pmf.
      rewrite /pmf/=/dbind_pmf.
      rewrite <- distr_double_swap_rmarg.
      erewrite (SeriesC_ext _ (λ b, μ b * SeriesC (λ a : A', Ch b (a, b'))) );
      [ | intro p; apply SeriesC_scal_l].
      apply (Rle_trans _ (SeriesC (λ p, μ p * g p.2 b')) _).
      {
        apply SeriesC_le; [ | ]; last first.
        + apply (ex_seriesC_le _ μ); auto.
          intros; split.
          ++ apply Rmult_le_pos; auto.
          ++ rewrite <- Rmult_1_r.
             apply Rmult_le_compat_l; auto.
        + intros (a & b); split; [ apply Rmult_le_pos; auto | ].
        {
          assert (SeriesC (λ a0 : A', Ch (a, b) (a0, b')) = rmarg (Ch (a, b)) b') as ->;
          [rewrite rmarg_pmf; auto | apply pmf_pos].
        }
        destruct (Rtotal_order (μ (a, b)) 0) as [Hlt | [Heqz | Hgt]].
        ++ pose proof (pmf_pos μ (a, b)); lra.
        ++ rewrite Heqz; lra.
        ++ specialize (HCh (a, b) (HμS (a, b) Hgt )) as ((HChL & HChR) & HChS).
          specialize (HChR b').
          rewrite (rmarg_pmf (Ch (a, b))) in HChR.
          apply Rmult_le_compat_l; auto.
      }
      rewrite fubini_pos_seriesC_prod_rl; auto.
      2:{simpl; intros; apply Rmult_le_pos; auto. }
      2:{apply (ex_seriesC_le _ μ); auto.
         intros; split; [apply Rmult_le_pos; auto | ].
         rewrite <- Rmult_1_r; apply Rmult_le_compat; auto.
         apply Rle_refl.
      }
      apply SeriesC_le; [ | ]; last first.
      {
        apply (ex_seriesC_le _ μ2); auto.
        intros; split.
        + apply Rmult_le_pos; auto.
        + rewrite <- Rmult_1_r.
          apply Rmult_le_compat_l; auto.
      }
      intro b; split; simpl.
      ++ rewrite SeriesC_scal_r.
         apply Rmult_le_pos ; auto.
         assert (SeriesC (λ x : A, μ (x, b)) = rmarg μ b ) as -> ; [rewrite rmarg_pmf | apply pmf_pos ]; auto.
      ++ destruct HμC as [HμCL HμCR].
         rewrite SeriesC_scal_r.
         apply Rmult_le_compat_r; auto.
         specialize (HμCR b).
         rewrite rmarg_pmf in HμCR; auto.
    + intros (a' & b') H3; simpl.
      pose proof (dbind_pos_support Ch μ (a', b')) as (H4 & H5).
      specialize (H4 H3) as ((a0, b0) & H7 & H8).
      specialize (HCh (a0, b0) (HμS (a0, b0) H8)) as (HCh1 & HCh2).
      specialize (HCh2 (a', b') H7).
      done.
  Qed.

  Lemma refRcoupl_dzero (μ : distr B) (R: A → B → Prop):
    refRcoupl dzero μ R.
  Proof.
    exists dzero; split; try split.
    + rewrite /lmarg dmap_dzero; done.
    + intro a.
      rewrite rmarg_pmf {1}/pmf/=.
      rewrite SeriesC_0; auto.
    + rewrite /pmf/=; intros; lra.
  Qed.

  Lemma refRcoupl_weaken (μ1 : distr A) (μ2 : distr B) (R : A → B → Prop) (S : A → B → Prop):
      (∀ a b, R a b -> S a b) → refRcoupl μ1 μ2 R → refRcoupl μ1 μ2 S.
  Proof.
    intros Hwk [μ [[HμL HμR] HμSupp]].
    exists μ; split; [split | ]; auto.
  Qed.

  Lemma refRcoupl_trivial (μ1 :distr A) (μ2 :distr B):
    SeriesC μ1 <= SeriesC μ2 ->
    refRcoupl μ1 μ2 (λ _ _, True).
  Proof.
    intros Hμ.
    pose proof (pmf_SeriesC_ge_0 μ1) as H3.
    destruct (Rlt_or_le 0 (SeriesC μ1)); last first.
    + destruct H3 ; try lra.
      rewrite (SeriesC_zero_dzero μ1); [ | apply Rle_antisym; auto].
      apply refRcoupl_dzero.
    + assert (0 < SeriesC μ2); [apply (Rlt_le_trans _ (SeriesC μ1)) | ]; auto.
      eexists (distr_scal (/(SeriesC μ2)) (dprod μ1 μ2) _).
    Unshelve.
    2:{
      split; auto.
      - left; apply Rinv_0_lt_compat; auto.
      - rewrite dprod_mass.
        rewrite Rmult_comm Rmult_assoc.
        rewrite Rinv_r; auto; try lra.
        rewrite Rmult_1_r.
        apply pmf_SeriesC.
    }
    split; [|done].
    split.
    ++ apply distr_ext. intro a.
      rewrite lmarg_pmf
       SeriesC_scal_l
       -lmarg_pmf
       lmarg_dprod_pmf
       -Rmult_comm
       Rmult_assoc
       Rinv_r; lra.
    ++ intro b.
      rewrite rmarg_pmf
       SeriesC_scal_l
       -rmarg_pmf
       rmarg_dprod_pmf
       -Rmult_comm
       Rmult_assoc.
      assert (μ2 b = μ2 b * 1) as Hrw; [rewrite Rmult_1_r; auto | ].
      rewrite {2}Hrw.
      apply (Rmult_le_compat_l); auto; try lra.
      apply (Rdiv_le_1 (SeriesC μ1) (SeriesC μ2)) ; try lra.
  Qed.

End ref_couplings_theory.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Inductive t (a:Type) :=
  | A : a -> t a
  | B : t a.
Implicit Arguments A.
Set Contextual Implicit.
Implicit Arguments B.
Unset Contextual Implicit.

Parameter f: unit -> unit.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem x : ~ ((A tt) = (B :(t unit))).
(* YOU MAY EDIT THE PROOF BELOW *)
discriminate.
Qed.
(* DO NOT EDIT BELOW *)


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

Require Import Coq.Init.Nat.
Require Import Coq.micromega.Lia.
Require Import Cava.Cava.
Local Open Scope vector_scope.
Require Import Examples.TwoSorter.

Section WithCava.
  Context {signal} `{Cava signal}.

  (* simpler definition for 2^n to make types easier to work with *)
  Fixpoint two_pow (n : nat) : nat :=
    match n with
    | O => 1
    | S n => let r := two_pow n in r + r
    end.

  Lemma two_pow_pow : forall n : nat, two_pow n = pow 2 n.
  Proof.
    intros.
    induction n.
    - reflexivity.
    - simpl.
      rewrite IHn.
      lia.
  Qed.

  Definition parl {A m n}
    (default : signal A)
    (f : signal (Vec A m) -> cava (signal (Vec A m)))
    (g : signal (Vec A n) -> cava (signal (Vec A n)))
    (input : signal (Vec A (m + n)))
    : cava (signal (Vec A (m + n))) :=
    inputV <- unpackV input ;;
    let (ifst, isnd) := Vector.splitat m inputV in
    ifst' <- (packV >=> f >=> unpackV) ifst ;;
    isnd' <- (packV >=> g >=> unpackV) isnd ;;
    packV (ifst' ++ isnd').

  Fixpoint vec_alternate {A n m}
    (default : A)
    (a : Vector.t A n)
    (b : Vector.t A m)
    : Vector.t A (n + m) :=
    match a, b with
    | ahd :: atl, bhd :: btl =>
        resize_default default (n + m) (ahd :: bhd :: vec_alternate default atl btl)
    | _, _ => a ++ b
    end.

  Definition vec_riffle {A n}
    (default : A)
    (input : Vector.t A (two_pow (S n)))
    : Vector.t A (two_pow (S n)) :=
    let (fst_halve, snd_halve) := Vector.splitat (two_pow n) input in
    vec_alternate default fst_halve snd_halve.

  Fixpoint list_odds {A} (a : list A) :=
    match a with
    | a1 :: a2 :: atl => a1 :: list_odds atl
    | empty_or_single => empty_or_single
    end%list.
  Definition vec_odds {A n} (default : A) (a : Vector.t A (n + n)) : Vector.t A n :=
    resize_default default n (Vector.of_list (list_odds (Vector.to_list a))).

  Fixpoint list_evens {A} (a : list A) :=
    match a with
    | a1 :: a2 :: atl => a2 :: list_evens atl
    | _ => []
    end%list.
  Definition vec_evens {A n} (default : A) (a : Vector.t A (n + n)) : Vector.t A n :=
    resize_default default n (Vector.of_list (list_evens (Vector.to_list a))).

  Definition vec_unriffle {A n}
    (default : A)
    (input : Vector.t A (two_pow (S n)))
    : Vector.t A (two_pow (S n)) :=
    vec_odds default input ++ vec_evens default input.

  Definition riffle {A n}
    (default : signal A)
    : signal (Vec A (two_pow (S n))) -> cava (signal (Vec A (two_pow (S n)))) :=
    unpackV >=> vec_riffle default >=> packV.

  Definition unriffle {A n}
    (default : signal A)
    : signal (Vec A (two_pow (S n))) -> cava (signal (Vec A (two_pow (S n)))) :=
    unpackV >=> vec_unriffle default >=> packV.

  Definition interleave {A n}
    (default : signal A)
    (f : signal (Vec A (two_pow n)) -> cava (signal (Vec A (two_pow n))))
    : signal (Vec A (two_pow (S n))) -> cava (signal (Vec A (two_pow (S n)))) :=
    unriffle default >=> parl default f f >=> riffle default.

  Fixpoint evens {A n}
    (default : signal A)
    (f : signal (Vec A 2) -> cava (signal (Vec A 2)))
    : signal (Vec A n) -> cava (signal (Vec A n)) :=
    match n with
    | O => ret
    | S n' => match n' with
              | O => ret
              | S _ => parl default f (evens default f)
              end
    end.

  Fixpoint butterfly {A n}
    (default : signal A)
    (f : signal (Vec A 2) -> cava (signal (Vec A 2)))
    : signal (Vec A (two_pow (S n))) -> cava (signal (Vec A (two_pow (S n)))) :=
    match n with
    | O => f
    | S n' => interleave default (butterfly default f) >=> evens default f
    end.

  Fixpoint bitonicSorter {bw n}
    (default : signal (Vec Bit bw))
    : signal (Vec (Vec Bit bw) (two_pow n)) -> cava (signal (Vec (Vec Bit bw) (two_pow n))) :=
    match n with
    | O => ret
    | S n' => (parl default (bitonicSorter default) (bitonicSorter default >=> Vec.rev))
              >=> butterfly default twoSorter
    end.

End WithCava.

Section Test.
  Definition bw := 8. (* only test numbers < 2**8 *)

  Definition run_sort (n : nat) (v : Vector.t N (two_pow n)) : Vector.t N (two_pow n) :=
    Vector.map Bv2N (@bitonicSorter combType _ _ n
                       (N2Bv_sized bw 0)
                       (Vector.map (N2Bv_sized bw) v)).

  Open Scope N.
  Lemma testSort0_1 : [1] = run_sort 0 [1]. reflexivity. Qed.
  Lemma testSort1_1 : [1; 2] = run_sort 1 [1; 2]. reflexivity. Qed.
  Lemma testSort1_2 : [1; 2] = run_sort 1 [2; 1]. reflexivity. Qed.
  Lemma testSort2_1 : [1; 2; 3; 4] = run_sort 2 [1; 2; 3; 4]. reflexivity. Qed.
  Lemma testSort2_2 : [1; 2; 3; 4] = run_sort 2 [3; 2; 1; 4]. reflexivity. Qed.
  Lemma testSortBig : [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] =
           run_sort 4 [12; 2; 11; 10; 16; 14; 6; 3; 5; 1; 7; 15; 9; 13; 4; 8].
  Proof. reflexivity. Qed.
  Close Scope N.
End Test.

Definition bsort_Interface name n bw
  := combinationalInterface name
     [mkPort "inputs" (Vec (Vec Bit bw) (two_pow n))]
     [mkPort "sorted" (Vec (Vec Bit bw) (two_pow n))].

Definition bsort4_8_Netlist
  := makeNetlist (bsort_Interface "bsort4_8" 4 8) (bitonicSorter defaultSignal).

Local Open Scope N_scope.

Definition bsort4_8_tb_inputs := map (Vector.map (N2Bv_sized 8))
  [ [12; 2; 11; 10; 16; 14; 6; 3; 5; 1; 7; 15; 9; 13; 4; 8]%vector
  ]%list.

Definition bsort4_8_tb_expectedOutputs := map (Vector.map (N2Bv_sized 8))
  [ [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16]%vector
  ]%list.

Definition bsort4_8_tb :=
  testBench "bsort4_8_tb" (bsort_Interface "bsort4_8" 4 8)
  bsort4_8_tb_inputs bsort4_8_tb_expectedOutputs.


From isla Require Import opsem.

Definition ac : isla_trace :=
  WriteReg "R0" [] (RegVal_Base (Val_Bits (BV 64%N 0x48%Z))) Mk_annot :t:
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 47%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 47%Z)) Mk_annot :t:
  tnil
.


Set Warnings "-notation-overridden,-parsing".
(* Full safety for STLC *)

Require Export SfLib.
Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Omega.
Require Import NPeano.
Require Import Utf8.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint length {X: Type} (l : list X): nat :=
  match l with
    | [] => 0
    | _::l' => 1 + length l'
  end.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_var: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
           has_type (T1::(TFun T1 T2)::env) y T2 ->
           has_type env (tabs y) (TFun T1 T2)
.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)

with val_type : vl -> ty -> Prop :=
| v_bool: forall b,
    val_type (vbool b) TBool
| v_abs: forall venv tenv y T1 T2,
    wf_env venv tenv ->
    has_type (T1::(TFun T1 T2)::tenv) y T2 ->
    val_type (vabs venv y) (TFun T1 T2)
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vbool _)) => Some None
            | Some (Some (vabs env2 ey)) =>
              match teval n env ex with
                | None => None
                | Some None => Some None
                | Some (Some vx) =>
                  teval n (vx::(vabs env2 ey)::env2) ey
              end
          end
      end
  end.

(* Here is a possible way to use DO notion for cleaner syntax: *)

Notation "'RES' x" := (Some x) (right associativity, at level 60).
Notation "'VAL' x" := (Some x) (right associativity, at level 60).

Definition STUCK: option (option vl) := Some (None).
Definition TIMEOUT: option (option vl) := None.

Notation "'DO1' x <== e1 ; e2"
   := (match e1 with
         | Some x => e2
         | _ => None
       end)
   (right associativity, at level 60).

Notation "'DO' x <== e1 ; e2"
   := (match e1 with
         | Some (Some x) => e2
         | Some _ => Some None
         | None => None
       end)
   (right associativity, at level 60).

Notation "'FUEL' n <== e1 ; e2"
   := (match e1 with
         | 0 => TIMEOUT
         | S n => e2
       end)
   (right associativity, at level 60).

Notation "'DO' n <== 'FUEL' e1 ; e2"
   := (match e1 with
         | 0 => TIMEOUT
         | S n => e2
       end)
   (right associativity, at level 60).

Fixpoint eval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  DO n1 <== FUEL n;
  match t with
    | ttrue      => RES VAL (vbool true)
    | tfalse     => RES VAL (vbool false)
    | tvar x     => RES (index x env)
    | tabs y     => RES VAL (vabs env y)
    | tapp ef ex =>
      DO vf <== eval n1 env ef;
        DO vx <==  eval n1 env ex;
        match vf with
          | (vabs env2 ey) =>
            eval n1 (vx::(vabs env2 ey)::env2) ey
          | _ => STUCK
        end
  end.

(* end notation *)

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto.  eauto.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_safety : forall n e tenv venv res T,
  teval n venv e = Some res -> has_type tenv e T -> wf_env venv tenv ->
  exists v, res = Some v /\ val_type v T.

Proof.
  intros n. induction n.
  (* 0   *) intros. inversion H.
  (* S n *) intros. destruct e; inversion H; inversion H0.

  Case "True".  eexists. split. eauto. eapply v_bool.
  Case "False". eexists. split. eauto. eapply v_bool.

  Case "Var".
    destruct (index_safe_ex venv0 tenv0 T i) as [v IV]. eauto. eauto.
    inversion IV as [I V].

    rewrite I. eexists. split. eauto. eapply V.

  Case "App".
    remember (teval n venv0 e1) as tf. (* not stuck *)
    remember (teval n venv0 e2) as tx.
    subst T.

    destruct tf as [rf|]; destruct tx as [rx|]; try solve by inversion.

    assert (exists vf, rf = Some vf /\ val_type vf (TFun T1 T2)) as HRF. subst. eapply IHn; eauto.
    inversion HRF as [vf [EF HVF]].
    inversion HVF. (* now we know it's a closure, and we have has_type evidence *)

    assert (exists vx, rx = Some vx /\ val_type vx T1) as HRX. subst. eapply IHn; eauto.
    inversion HRX as [vx [EX HVX]].

    subst. eapply IHn; eauto. (* body *)

    (* other case: tx = None *)
    assert (exists vf, rf = Some vf /\ val_type vf (TFun T1 T2)) as HRF. subst. eapply IHn; eauto.

    inversion HRF as [vf [EF HVF]]. subst. inversion HVF. subst. inversion H3. (* contradiction *)

  Case "Abs".
    eexists. split. eauto. eapply v_abs; eauto.
Qed.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph.lib Require Import typed_proph.
From iris_examples.proph Require Import clairvoyant_coin_spec.
From iris.prelude Require Import options.

(* Clairvoyant coin with *typed* prophecies. *)

Definition new_coin: val :=
  λ: <>, (ref (nondet_bool #()), NewProph).

Definition read_coin : val := λ: "cp", !(Fst "cp").

Definition toss_coin : val :=
  λ: "cp",
  let: "c" := Fst "cp" in
  let: "p" := Snd "cp" in
  let: "r" := nondet_bool #() in
  "c" <- "r";; resolve_proph: "p" to: "r";; #().

Section proof.
  Context `{!heapGS Σ}.

  Definition coin (cp : val) (bs : list bool) : iProp Σ :=
    (∃ (c : loc) (p : proph_id) (b : bool) (bs' : list bool),
        ⌜cp = (#c, #p)%V⌝ ∗ ⌜bs = b :: bs'⌝ ∗ c ↦ #b ∗
          (typed_proph_prop BoolTypedProph) p bs')%I.

  Lemma coin_exclusive (cp : val) (bs1 bs2 : list bool) :
    coin cp bs1 -∗ coin cp bs2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (c1 p1 b1 bs'1) "(-> & -> & _ & Hp1)".
    iDestruct "H2" as (c2 p2 b2 bs'2) "(% & -> & _ & Hp2)".
    simplify_eq.
    iApply (typed_proph_prop_excl BoolTypedProph). iFrame.
  Qed.

  Lemma new_coin_spec :
    {{{ True }}}
      new_coin #()
    {{{ c bs, RET c; coin c bs }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_lam.
    wp_apply (typed_proph_wp_new_proph BoolTypedProph); first done.
    iIntros (bs p) "Hp".
    wp_apply nondet_bool_spec; first done.
    iIntros (b) "_". wp_alloc c as "Hc". wp_pair.
    iApply ("HΦ" $! _ (b :: bs)).
    iExists c, p, b, bs. by iFrame.
  Qed.

  Lemma read_coin_spec cp bs :
    {{{ coin cp bs }}}
      read_coin cp
    {{{ b bs', RET #b; ⌜bs = b :: bs'⌝ ∗ coin cp bs }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p b bs') "[-> [-> [Hc Hp]]]".
    wp_lam. wp_load. iApply "HΦ". iModIntro. iSplit; first done.
    iExists c, p, b, bs'. by iFrame.
  Qed.

  Lemma toss_coin_spec cp bs :
    {{{ coin cp bs }}}
      toss_coin cp
    {{{ b bs', RET #(); ⌜bs = b :: bs'⌝ ∗ coin cp bs' }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p b bs') "[-> [-> [Hc Hp]]]".
    wp_lam. wp_pures. wp_apply nondet_bool_spec; first done.
    iIntros (r) "_". wp_store.
    wp_apply (typed_proph_wp_resolve BoolTypedProph with "[Hp]"); try done.
    wp_pures. iIntros "!>" (bs) "-> Hp". wp_seq.
    iModIntro. iApply "HΦ"; iSplit; first done.
    iExists c, p, r, bs. by iFrame.
  Qed.

End proof.

Definition clairvoyant_coin_spec_instance `{!heapGS Σ} :
  clairvoyant_coin_spec.clairvoyant_coin_spec Σ :=
  {| clairvoyant_coin_spec.new_coin_spec := new_coin_spec;
     clairvoyant_coin_spec.read_coin_spec := read_coin_spec;
     clairvoyant_coin_spec.toss_coin_spec := toss_coin_spec;
     clairvoyant_coin_spec.coin_exclusive := coin_exclusive |}.

Typeclasses Opaque coin.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.Canonical_Kripke.
Require Import Logic.GeneralLogic.Complete.Complete_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimunLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.
Require Import Logic.SeparationLogic.Complete.Lindenbaum_Flat.
Require Import Logic.SeparationLogic.Complete.Truth_Flat.
Require Import Logic.SeparationLogic.Complete.Canonical_Flat.
Require Import Logic.SeparationLogic.DeepEmbedded.Parameter.
Require Logic.SeparationLogic.DeepEmbedded.SeparationEmpLanguage.
Require Logic.SeparationLogic.DeepEmbedded.FlatSemantics.
Require Logic.SeparationLogic.DeepEmbedded.ParametricSeparationLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.

Section Complete.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}
        {CV: Countable SeparationEmpLanguage.Var}
        (SLP: SL_Parameter).

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sL SeparationEmpLanguage.s'L.

Existing Instances ParametricSeparationLogic.G ParametricSeparationLogic.AX ParametricSeparationLogic.minAX  ParametricSeparationLogic.ipG ParametricSeparationLogic.sG ParametricSeparationLogic.eG ParametricSeparationLogic.ParG.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC Axiomatization2SequentCalculus_cpSC.

Existing Instances FlatSemantics.MD FlatSemantics.kMD FlatSemantics.R FlatSemantics.J FlatSemantics.SM FlatSemantics.kminSM FlatSemantics.kpSM FlatSemantics.fsSM FlatSemantics.feSM.

Definition cP : context -> Prop := Intersection _ (Intersection _ derivable_closed orp_witnessed) consistent.

Lemma AL_DC: at_least derivable_closed cP.
Proof. solve_at_least. Qed.

Lemma AL_OW: at_least orp_witnessed cP.
Proof. solve_at_least. Qed.

Lemma AL_CONSI: at_least consistent cP.
Proof. solve_at_least. Qed.

Lemma LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply SeparationEmpLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_cannot_derive.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
    - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
    - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

Lemma LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply SeparationEmpLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_context_sepcon_included_l_ensures_derivable_closed.
    - apply Lindenbaum_context_sepcon_included_l_ensures_orp_witnessed.
      * apply AL_DC, (proj2_sig Psi).
      * apply AL_OW, (proj2_sig Psi).
    - apply Lindenbaum_context_sepcon_included_l_ensures_consistent.
      apply AL_CONSI, (proj2_sig Psi).
Qed.

Lemma LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  eapply Lindenbaum_constructable_Same_set.
  + symmetry.
    apply context_sepcon_included_equiv.
    apply AL_DC, (proj2_sig Psi).
  + apply LIN_SL.
Qed.

Definition canonical_frame: FlatSemantics.frame :=
  FlatSemantics.Build_frame (sig cP)
    (fun a b => Included _ (proj1_sig a) (proj1_sig b))
    (fun a b c => Included _ (context_sepcon (proj1_sig a) (proj1_sig b)) (proj1_sig c)).

Definition canonical_eval: SeparationEmpLanguage.Var -> FlatSemantics.sem canonical_frame :=
  fun p a => proj1_sig a (SeparationEmpLanguage.varp p).

Definition canonical_Kmodel: @Kmodel FlatSemantics.MD FlatSemantics.kMD :=
  FlatSemantics.Build_Kmodel canonical_frame canonical_eval.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Definition H_R:
  forall m n Phi Psi, rel m Phi -> rel n Psi ->
    (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).
Proof.
  intros.
  change (m = Phi) in H.
  change (n = Psi) in H0.
  subst; reflexivity.
Qed.

Definition H_J:
  forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi ->
    (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).
Proof.
  intros.
  change (m = Phi) in H1.
  change (m1 = Phi1) in H.
  change (m2 = Phi2) in H0.
  subst; reflexivity.
Qed.

Lemma TRUTH:
  forall x: expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_DC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_DC AL_OW x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel H_R AL_DC LIN_CD x1 x2 IHx1 IHx2).
  + exact (truth_lemma_sepcon cP rel H_J AL_DC LIN_SL LIN_SR x1 x2 IHx1 IHx2).
  + exact (truth_lemma_wand cP rel H_J AL_DC LIN_CD LIN_SR x1 x2 IHx1 IHx2).
  + exact (truth_lemma_emp cP rel H_R H_J AL_DC LIN_CD LIN_SR).
  + exact (truth_lemma_falsep cP rel AL_CONSI).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

Context (SAP: SA_Parameter).

Hypothesis PC: Parameter_coincide SLP SAP.

Theorem ParametricCompleteness:
  strongly_complete (ParametricSeparationLogic.G SLP) FlatSemantics.SM
    (KripkeModelClass _
      (FlatSemantics.Kmodel_Monotonic +
       FlatSemantics.Kmodel_PreOrder +
       FlatSemantics.Kmodel_SeparationAlgebra +
       FlatSemantics.Kmodel_UpwardsClosed +
       FlatSemantics.Kmodel_DownwardsClosed +
       FlatSemantics.Kmodel_Unital +
       FlatSemantics.Parametric_Kmodel_Class SAP)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  split; [split; [split; [split; [split; [split |] |] |] |] |].
  + hnf; intros.
    exact (denote_monotonic cP rel H_R
             (SeparationEmpLanguage.varp v)
             (TRUTH (SeparationEmpLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (SA cP rel H_J AL_DC LIN_SR).
  + exact (uSA cP rel H_R H_J AL_DC).
  + exact (dSA cP rel H_R H_J AL_DC).
  + exact (unitSA cP rel H_R H_J AL_DC LIN_SR TRUTH).
  + inversion PC.
    constructor; intros HH; rewrite HH in *.
    - pose proof ParametricSeparationLogic.Parametric_C H.
      exact (classical_canonical_ident cP rel H_R AL_DC AL_OW AL_CONSI).
    - pose proof ParametricSeparationLogic.Parametric_GD H0.
      exact (GodelDummett_canonical_no_branch cP rel H_R AL_DC AL_OW).
    - pose proof ParametricSeparationLogic.Parametric_DM H1.
      exact (DeMorgan_canonical_branch_join cP rel H_R AL_DC AL_OW AL_CONSI LIN_CD).
    - pose proof ParametricSeparationLogic.Parametric_GC H2.
      exact (garbage_collected_canonical_increaing cP rel H_R H_J AL_DC).
    - pose proof ParametricSeparationLogic.Parametric_NE H3.
      exact (nonsplit_canonical_split_smaller cP rel H_R H_J AL_DC TRUTH).
    - pose proof ParametricSeparationLogic.Parametric_ED H4.
      exact (dup_canonical_incr_join cP rel H_J AL_DC TRUTH).
Qed.

End Complete.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Prop.
Variable l_ : Universe -> Prop.
Variable i_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable e_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable c_ : Universe.
Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ (dom_ b_ /\ (dom_ c_ /\ (p_ a_ /\ (p_ b_ /\ p_ c_))))).
Variable goal_proved_2 : (forall L : Universe, ((i_ a_ L /\ (i_ b_ L /\ i_ c_ L)) -> goal_)).
Variable sortp_3 : (forall P L : Universe, (i_ P L -> p_ P)).
Variable sortl_4 : (forall P L : Universe, (i_ P L -> l_ L)).
Variable p_ref_5 : (forall X : Universe, (p_ X -> e_ X X)).
Variable l_ref_6 : (forall X : Universe, (l_ X -> e_ X X)).
Variable sym_7 : (forall X Y : Universe, (e_ X Y -> e_ Y X)).
Variable tra_8 : (forall X Y Z : Universe, ((e_ X Y /\ e_ Y Z) -> e_ X Z)).
Variable conp_9 : (forall P Q L : Universe, ((e_ P Q /\ i_ Q L) -> i_ P L)).
Variable conl_10 : (forall P L M : Universe, ((i_ P L /\ e_ L M) -> i_ P M)).
Variable line_11 : (forall P Q : Universe, ((p_ P /\ p_ Q) -> (exists L : Universe, (dom_ L /\ (i_ P L /\ i_ Q L))))).
Variable point_12 : (forall L M : Universe, ((l_ L /\ l_ M) -> (exists P : Universe, (dom_ P /\ (i_ P L /\ i_ P M))))).
Variable unique_13 : (forall P L M Q : Universe, ((i_ P L /\ (i_ P M /\ (i_ Q L /\ i_ Q M))) -> (e_ P Q \/ e_ L M))).
Variable wrong_14 : (forall A1 Lb1 Lc1 B1 La1 C1 A2 Lb2 Lc2 B2 La2 C2 Ld P Le Lf D Lp E F : Universe, ((i_ A1 Lb1 /\ (i_ A1 Lc1 /\ (i_ B1 La1 /\ (i_ B1 Lc1 /\ (i_ C1 La1 /\ (i_ C1 Lb1 /\ (i_ A2 Lb2 /\ (i_ A2 Lc2 /\ (i_ B2 La2 /\ (i_ B2 Lc2 /\ (i_ C2 La2 /\ (i_ C2 Lb2 /\ (i_ A1 Ld /\ (i_ A2 Ld /\ (i_ P Ld /\ (i_ B1 Le /\ (i_ B2 Le /\ (i_ P Le /\ (i_ C1 Lf /\ (i_ C2 Lf /\ (i_ P Lf /\ (i_ D La1 /\ (i_ D La2 /\ (i_ D Lp /\ (i_ E Lb1 /\ (i_ E Lb2 /\ (i_ E Lp /\ (i_ F Lc1 /\ i_ F Lc2)))))))))))))))))))))))))))) -> (i_ F Lp \/ (e_ La1 La2 \/ (e_ Lb1 Lb2 \/ e_ Lc1 Lc2))))).

Theorem sd_15 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ A C /\ (wd_ B D /\ (wd_ M B /\ (wd_ M A /\ (wd_ M D /\ (wd_ M C /\ (col_ A B C /\ (col_ A M C /\ (col_ B M D /\ (col_ B M A /\ (col_ M C B /\ col_ M A D))))))))))) -> col_ A B D)).
Proof.
  time tac.
Qed.

End FOFProblem.