From discprob.basic Require Import base order nify sval.
From discprob.prob Require Import prob countable finite stochastic_order uniform.
From discprob.monad Require Import monad monad_hoare.
From discprob.monad Require quicksort quicksort_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coq Require Import Omega Psatz Program.Wf MSets.MSetInterface MSets.MSetGenTree Structures.OrdersEx.
Local Open Scope nat_scope.

(* TODO: should make unif generic over ``cost'' or not, so don't have to repeat this
   across other examples *)
Require Import Reals Fourier FunctionalExtensionality.
Program Definition unif n : ldist { x : nat | (leq x n) } :=
  mklDist [ seq (1/(INR (n.+1)), (exist _ (nat_of_ord i) _)) | i <- enum 'I_(n.+1) ] _ _.
Next Obligation. intros n (?&?); rewrite -ltnS. done. Qed.
Next Obligation.
  intros ?.
  apply /allP => r.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  rewrite //=. induction (iota 1 n) => //=.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR. omega.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec 0 (1 / _)) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first by fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR; omega.
Qed.
Next Obligation.
  intros ?.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  cut (∀ o k, \big[Rplus/0]_(a<-[seq (1 / INR n.+1) | i <- iota k o]) a
            = INR (o) / INR (n.+1)).
  {
    intros Hcut. specialize (Hcut (n.+1) O). rewrite //= in Hcut.
    rewrite Hcut. apply /eqP => //=. field.
    apply Rgt_not_eq.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); first by intros; fourier.
    apply lt_INR; omega.
  }
  induction o => k.
  - rewrite big_nil. replace (INR 0) with 0 by auto. rewrite /Rdiv Rmult_0_l //.
  - rewrite big_cons. rewrite (S_INR o).
    rewrite Rdiv_plus_distr IHo. ring.
Qed.

Lemma unif_all n x (Hle: (x <= n)%nat):
  exist _ x Hle \in [seq i.2 | i <- outcomes (unif n)].
Proof.
  apply /mapP.
  set (a := exist _ x Hle).
  replace (a) with (1/INR (S n), a).2; last done.
  do 2 apply /mapP; eexists; eauto.
  rewrite /unif => //=.
  apply /mapP => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  exists (Ordinal Hlt).
  - apply mem_enum.
  - rewrite /a; repeat f_equal. apply bool_irrelevance.
Qed.

Lemma unif_pr n a :
  a \in [seq i.2 | i <- outcomes (unif n)] →
  pr_eq (rvar_of_ldist (unif n)) a = 1 / INR (S n).
Proof.
  intros Hin. rewrite pr_rvar_ldist /unif//=.
  rewrite big_map -big_filter //=.
  destruct a as (x&Hle) => //=.
  assert (Hlt: (x < S n)%nat) by auto.
  rewrite (bigD1_seq (Ordinal Hlt)) => //=.
  - rewrite -[a in _ = a]Rplus_0_r; f_equal.
    rewrite -big_filter -filter_predI big_filter. apply big_pred0.
    intros i => //=. apply negbTE. apply /andP => [] []. move /eqP => Heq.
    move /eqP => []. intros. subst. apply Heq.
    destruct i. f_equal. apply bool_irrelevance.
  - rewrite mem_filter. apply /andP; split; auto.
    * apply /eqP; f_equal; auto. f_equal. apply bool_irrelevance.
    * apply mem_enum.
  - apply /filter_uniq/enum_uniq.
Qed.

Lemma unif_sval n n':
  n = n' →
  map sval (undup (map snd (unif n))) = map sval (undup (map snd (unif n'))).
Proof.
  intros Heq. rewrite /unif. subst. auto.
Qed.

Section perm.
Variable (A: eqType).
Program Definition draw_next (a : A) (l: list A) : ldist { x : A | x \in (a :: l) } :=
  idx ← unif (size l);
  mret (exist _ (nth a (a :: l) (sval idx)) _).
Next Obligation. intros a l (?&?); rewrite mem_nth //. Qed.

Definition rand_perm_list : list A → ldist (list A).
  refine(Fix (measure_wf lt_wf size) (fun _ => ldist (list A))
  (fun l rand_perm_list =>
     match l as l' return (l = l' → ldist (list A)) with
     | [::] => λ eq, mret [::]
     | [::a] => λ eq, mret [::a]
     | (a :: b :: l') => λ eq,
                         p ← draw_next a (b :: l');
                         rest ← rand_perm_list (rem (sval p) (a :: b :: l')) _;
                         mret (sval p :: rest)
     end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (destruct p as (x&Hin); rewrite size_rem //; subst; rewrite //=).
Defined.

Lemma rand_perm_list_unfold_aux l:
  rand_perm_list l =
  match l as l' return (l = l' → ldist (list A)) with
     | [::] => λ eq, mret [::]
     | [::a] => λ eq, mret [::a]
     | (a :: b :: l') => λ eq,
                         p ← draw_next a (b :: l');
                         rest ← rand_perm_list (rem (sval p) (a :: b :: l'));
                         mret (sval p :: rest)
  end (Init.Logic.eq_refl).
Proof. rewrite /rand_perm_list quicksort.easy_fix_eq; done. Qed.

Lemma rand_perm_list_unfold l:
  rand_perm_list l =
  (match l with
    | [::] => mret [::]
    | [::a] => mret [::a]
    | (a :: l) => p ← draw_next a l;
                         rest ← rand_perm_list (rem (sval p) (a :: l));
                         mret (sval p :: rest)
  end).
Proof. rewrite rand_perm_list_unfold_aux. destruct l => //. destruct l => //. Qed.
End perm.

Arguments rand_perm_list {_}.
Arguments draw_next {_}.

Lemma draw_next_pr {A: eqType} (a': A) l a:
  uniq (a' :: l) →
  sval a \in (a' :: l) →
  pr_eq (rvar_of_ldist (draw_next a' l)) a = 1 / INR (size (a' :: l)).
Proof.
  intros Huniq Hin. rewrite /draw_next.
  rewrite pr_mbind_ldist2.
  assert (Hpf: (index (sval a) (a' :: l) <= size l)%nat).
  { rewrite -index_mem in Hin. rewrite //= in Hin. }
  rewrite (@big_rem _ _ _ _ (undup (map snd (unif (size l))))
                    (exist _ (index (sval a) (a' :: l)) Hpf)); last first.
  { rewrite mem_undup. apply unif_all. }
    rewrite -[a in _ = a]Rplus_0_r.
    rewrite rem_filter; last apply undup_uniq.
    rewrite big_filter.
    rewrite big1; last first.
    { intros (n&Hle) Hn0. apply Rmult_eq_0_compat_l.
      rewrite pr_mret_simpl //. destruct a. case: ifP; auto.
      intros Heq. move /eqP in Heq. inversion Heq as [[Heqx]].
      rewrite /sval in Hn0. cut (n = index x (a' :: l)).
      { intros Hidx. exfalso. move /negP in Hn0. apply Hn0.
        apply /eqP. clear -Hidx. subst. f_equal. apply bool_irrelevance. }
      symmetry. rewrite -Heqx. apply index_uniq; auto. }
    apply Rplus_eq_compat_r.
    rewrite pr_mret_simpl. case: ifP; last first.
    { move /negP => Hfalse. exfalso; apply Hfalse. apply /eqP.
      destruct a as (a&Hin').
      apply sval_inj_pred. rewrite /sval.
      apply nth_index. auto.
    }
    intros. rewrite Rmult_1_r unif_pr; first done.
    apply unif_all.
Qed.

Lemma draw_next_all {A: eqType} (a: A) l x Hin:
  uniq (a :: l) →
  exist _ x Hin \in [seq i.2 | i <- outcomes (draw_next a l)].
Proof.
  intros Huniq.
  rewrite -mem_undup.
  rewrite -img_rvar_of_ldist'.
  apply pr_img. rewrite draw_next_pr //.
  apply Rlt_gt, Rdiv_lt_0_compat; first nra.
  specialize (pos_INR (size l)).
  rewrite S_INR. rewrite //=. rewrite -/size. nra.
Qed.

Definition gen_perm (n: nat) := rand_perm_list (Finite.enum [finType of 'I_n]).

Lemma perm_eq_nil (A: eqType) (l: list A): perm_eq l [::] → l = [::].
Proof.
  move /perm_eq_size. destruct l => //=.
Qed.

Lemma perm_eq_singleton (A: eqType) (l: list A) (a: A): perm_eq l [::a] → l = [::a].
Proof.
  destruct l => //=.
  - rewrite perm_eq_sym. move /perm_eq_nil => //.
  - destruct l as [| b l] => //=.
    * move /perm_eqP. intros Heq. specialize (Heq (pred1 a)).
      rewrite //= in Heq. f_equal.
      move: Heq. case: eqP; auto. rewrite eq_refl //=.
    * move /perm_eq_size => //=.
Qed.

Lemma perm_eq_rem {A: eqType} (l1 l2: list A) x:
  perm_eq l1 l2 → perm_eq (rem x l1) (rem x l2).
Proof.
  intros Heq.
  case_eq (x \in l1).
  - rewrite -(perm_cons x).
    intros Hin. eapply perm_eq_trans.
    * rewrite perm_eq_sym. apply perm_to_rem. done.
    * eapply perm_eq_trans; first apply Heq. apply perm_to_rem.
      rewrite -(perm_eq_mem Heq) //.
  - intros Hnin. rewrite ?rem_id //.
    * rewrite -(perm_eq_mem Heq). apply /negP. rewrite Hnin. done.
    * apply /negP. rewrite Hnin. done.
Qed.

Lemma rand_perm_list_initial {A: eqType} (l1 l2 lt: seq A):
  perm_eq l1 l2 →
  pr_eq (rvar_of_ldist (rand_perm_list l1)) lt =
  pr_eq (rvar_of_ldist (rand_perm_list l2)) lt.
Proof.
  remember (size l1) as k eqn:Heq.
  revert l1 l2 lt Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l1 l2 lt Heq Hperm.
  destruct l1 as [| a1 l1]; last destruct l1 as [| b1 l1].
  - rewrite perm_eq_sym in Hperm; apply perm_eq_nil in Hperm; subst.
    done.
  - rewrite perm_eq_sym in Hperm; apply perm_eq_singleton in Hperm; subst.
    done.
  - destruct l2 as [| a2 l2]; last destruct l2 as [| b2 l2].
    { apply perm_eq_nil in Hperm; subst. congruence. }
    { apply perm_eq_singleton in Hperm; subst. congruence. }
    rewrite ?rand_perm_list_unfold.
    rewrite /draw_next. rewrite ?ldist_assoc.
    rewrite ?pr_mbind_ldist2.
    destruct (quicksort_cost.perm_eq_bij a1 _ _ Hperm) as (h&Hhspec&Hhsize&Hinv&Hinj).
    assert (Hbound: ∀ x, (x <= size (b1 :: l1))%nat → (h x <= size (b2 :: l2))%nat).
    { rewrite //= => x Hle.
      apply (perm_eq_size) in Hperm.
      rewrite //= in Hperm.
      assert (h x < S (S (size l1)))%nat as Hsize'.
      { apply Hhsize. rewrite //=. }
      nify. omega.
    }
    set (h' := λ x : {y : nat | (y <= (size (b1 :: l1)))%nat} ,
                     match x with
                      | exist n Hpf => (exist _ (h n) (Hbound n Hpf) :
                                          {x : nat | (x <= size (b2 :: l2))%nat})
                    end).
    eapply (sum_reidx_map _ _ _ _ h').
    * intros (n&Hle) Hin. f_equal.
      { rewrite ?unif_pr //; rewrite /h'; try apply unif_all.
        apply perm_eq_size in Hperm.  rewrite //= in Hperm. inversion Hperm as [Hsize].
        rewrite /size -/size Hsize. done. }
      rewrite 2!ldist_left_id /h'/sval.
      symmetry.
      rewrite (set_nth_default a1); last first.
      { rewrite //=. by apply Hbound. }
      symmetry.
      eapply eq_dist_ldist_bind_congr.
      ** intros lt'. eapply IH; eauto.
         rewrite size_rem; subst => //=; nify; try omega.
         { apply /mem_nth => //=. }
         rewrite Hhspec; last by rewrite //=.
         apply perm_eq_rem; auto.
      ** intros a x. rewrite ?pr_mret_simpl Hhspec. eauto.
         rewrite //=.
    * intros a Hin _; split; auto. rewrite mem_undup.
      destruct (h' a); apply unif_all.
    * intros (x&Hx) Hin _ Hfalse. exfalso. apply Hfalse.
      edestruct (Hinv x) as (x'&Hlt&?); eauto.
      { apply perm_eq_size in Hperm. clear -Hx Hperm.
        rewrite //= in Hx, Hperm. nify. rewrite //=. omega. }
      exists (exist _ x' Hlt); repeat split.
      ** rewrite mem_undup. apply unif_all.
      ** rewrite /h'//=; subst.
         f_equal => //=. apply bool_irrelevance.
    * apply undup_uniq.
    * apply undup_uniq.
    * intros (x&?) (x'&?) _ Heqh'.
      rewrite /h' in Heqh'. inversion Heqh' as [Heqh]. eapply Hinj in Heqh; eauto.
      subst. f_equal. apply bool_irrelevance.
Qed.

(*
Lemma rand_perm_gen_then_draw {A: eqType} (a: A) (l: seq A):
  eq_dist (rvar_of_ldist (rand_perm_list l))
          (rvar_of_ldist (sigma ← gen_perm (size l);
                          mret ([seq (nth a l (nat_of_ord i)) | i <- sigma]))).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq => lt.
  destruct l as [| b1 l]; last destruct l as [| b2 l].
  - subst. rewrite /size/gen_perm.
    assert (Finite.enum [finType of 'I_0] = [::]) as ->.
    { destruct (Finite.enum _) as [| o l] => //=. inversion o. nify. omega. }
    rewrite ?rand_perm_list_unfold.
    rewrite ldist_left_id. rewrite pr_mret_simpl; done.
  - rewrite rand_perm_list_unfold.
    rewrite /gen_perm. rewrite ?rand_perm_list_unfold.
    subst. specialize (size_enum_ord 1).
    rewrite enumT.
    destruct (Finite.enum) as [| o le]; first by done.
    destruct le; last by done.
    intros ?. rewrite ldist_left_id. rewrite ?pr_mret_simpl //=.
    assert (nat_of_ord o = O) as Hnat.
    { destruct o as (x&Hlt) => //=. clear -Hlt. rewrite //= in Hlt.  nify. omega. }
    rewrite Hnat //=.
  - rewrite /gen_perm.
Abort.
*)

Lemma rand_perm_list_id {A: eqType} (l1: seq A):
  uniq l1 →
  pr_eq (rvar_of_ldist (rand_perm_list l1)) l1 = 1 / INR ((size l1)`!).
Proof.
  remember (size l1) as k eqn:Heq.
  revert l1 Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l1 Heq Huniq1.
  destruct l1 as [| a1 l1]; last destruct l1 as [| b1 l1].
  - rewrite rand_perm_list_unfold. subst. rewrite //=. rewrite pr_mret_simpl eq_refl.
    field.
  - rewrite rand_perm_list_unfold. subst. rewrite //=. rewrite pr_mret_simpl eq_refl.
    field.
  - rewrite ?rand_perm_list_unfold ?ldist_assoc ?pr_mbind_ldist2.
    assert (Hpf: (O <= size (b1 :: l1))%nat).
    { rewrite //=. }
    rewrite (@big_rem _ _ _ _ (undup (map snd (unif (size (b1 :: l1))))) (exist _ O Hpf)); last first.
    { rewrite mem_undup.  apply unif_all. }
    rewrite -[a in _ = a]Rplus_0_r.
    rewrite rem_filter; last apply undup_uniq.
    rewrite big_filter.
    rewrite big1; last first.
    { intros (n&Hle) Hn0. apply Rmult_eq_0_compat_l.
      rewrite ldist_left_id /sval. rewrite ?pr_mbind_mret_inj0 //. intros rest.
      destruct n; rewrite //= in Hn0.
      intros Heq'.
      assert (nth a1 [:: a1, b1 & l1] (S n) == nth a1 [:: a1, b1 & l1] O) as Hidx.
      { rewrite //=. apply /eqP. inversion Heq' as [[Hhd Htl]]. rewrite Hhd. done.  }
      rewrite nth_uniq in Hidx; auto.
    }
    apply Rplus_eq_compat_r.
    subst. rewrite {1}factS. rewrite -/size.
    transitivity ((1/ INR (S (S (size l1)))) * (1 / INR ((S (size l1))`!))); last first.
    { symmetry. rewrite mult_INR ?S_INR. field. split.
      * rewrite factS mult_INR ?S_INR. specialize (pos_INR (size l1)).
        intros. apply Rgt_not_eq. specialize (fact_gt0 (size l1)). intros Hgt0. nify.
        apply lt_INR in Hgt0. replace (INR 0) with 0 in Hgt0; auto; nra.
      * specialize (pos_INR (size l1)). nra.
    }
    f_equal.
    * rewrite unif_pr; first by auto. apply unif_all.
    * rewrite ldist_left_id /sval. rewrite pr_mbind_mret_inj; last first.
      { intros a b; congruence. }
      rewrite /nth. rewrite {1}/rem //= eq_refl. apply IH; auto.
      rewrite cons_uniq in Huniq1. move /andP in Huniq1. intuition.
Qed.

Lemma pr_rand_perm_list {A: eqType} (l1 l2: seq A):
  uniq l1 →
  perm_eq l1 l2 →
  pr_eq (rvar_of_ldist (rand_perm_list l1)) l2 = 1 / INR ((size l1)`!).
Proof.
  intros Huniq Hperm.
  rewrite (rand_perm_list_initial l1 l2) //.
  rewrite rand_perm_list_id; last first.
  { rewrite -(perm_eq_uniq Hperm). done. }
  apply perm_eq_size in Hperm. rewrite Hperm. done.
Qed.

Lemma rand_perm_list_id' {A: eqType} (l1 l2: seq A):
  uniq l1 →
  uniq l2 →
  size l1 = size l2 →
  pr_eq (rvar_of_ldist (rand_perm_list l1)) l1 =
  pr_eq (rvar_of_ldist (rand_perm_list l2)) l2.
Proof.
  intros Hu1 Hu2 Hsize. rewrite ?rand_perm_list_id // Hsize. done.
Qed.

Lemma rand_perm_list_correct {A: eqType} (l: list A):
  mspec (rand_perm_list l) (λ l': list A, perm_eq l l').
Proof.
 remember (size l) as k eqn: Heq.
 revert l Heq.
 induction k as [k IH] using (well_founded_induction lt_wf) => l Heq.
 destruct l as [| a l]; last destruct l as [| b l].
 - rewrite rand_perm_list_unfold. apply mspec_mret => //=.
 - rewrite rand_perm_list_unfold. apply mspec_mret => //=.
 - rewrite rand_perm_list_unfold.
   tbind (λ x, sval x \in a :: b :: l).
   { intros (?&?) => //. }
   intros (x&Hin) _.
   rewrite /sval. tbind (λ l', perm_eq (rem x [:: a, b & l]) l').
   {
     eapply IH; eauto. subst. rewrite size_rem //=.
   }
   intros l' Hperm.
   apply mspec_mret.
   eapply perm_eq_trans; first apply (perm_to_rem Hin); eauto.
   rewrite perm_cons. done.
Qed.

Lemma img_rand_perm_list {A: eqType} (l: list A):
  uniq l →
  img (rvar_of_ldist (rand_perm_list l)) =i perm_eq l.
Proof.
  intros Huniq l'. rewrite img_rvar_of_ldist' mem_undup.
  case_eq (l' \in (map snd (rand_perm_list l))).
  * intros Htrue. rewrite Htrue.
    symmetry. apply rand_perm_list_correct. rewrite /output. auto.
  * intros Hnotin.
    case_eq (l' \in perm_eq l); rewrite //=.
    intros Hl'. exfalso.
    move /negP in Hnotin. apply Hnotin.
    rewrite -mem_undup.
    rewrite -img_rvar_of_ldist'.
    apply pr_img. rewrite pr_rand_perm_list //.
    specialize (fact_gt0 (size l)). intros Hgt. nify.
    apply lt_INR in Hgt. replace (INR 0) with 0 in Hgt by auto.
    apply Rlt_gt, Rdiv_lt_0_compat; nra.
Qed.

Lemma permutation_uniform {A: eqType} (l: list A):
  uniq l →
  uniform_on (rvar_of_ldist (rand_perm_list l)) (img (rvar_of_ldist (rand_perm_list l))).
Proof.
  intros Huniq l1 l2 Hin1 Hin2.
  rewrite ?pr_rand_perm_list //.
  - specialize (img_rand_perm_list l Huniq l2). rewrite /in_mem/mem//=. intros <-. auto.
  - specialize (img_rand_perm_list l Huniq l1). rewrite /in_mem/mem//=. intros <-. auto.
Qed.

Lemma INR_fact_gt0 n:
  0 < INR (n`!).
Proof.
  replace 0 with (INR 0) by auto. apply lt_INR. specialize (fact_gt0 n). intros. nify. done.
Qed.

Lemma filter_rem {A: eqType} (x: A) (s: seq A) (P: pred A):
  filter P (rem x s) = rem x (filter P s).
Proof.
  induction s => //=.
  case: ifP => //=.
  - case: ifP.
    * rewrite //=. intros ? ->. done.
    * rewrite //=; intros HP Heq. rewrite rem_id //.
      apply /negP. rewrite mem_filter. move /andP. intros (HP'&?).
      move /eqP in Heq. subst. move /negP in HP. apply HP. auto.
  - intros Hneq. case: ifP => //= HP. rewrite Hneq. f_equal.
    auto.
Qed.

(* TODO: there's a tremendous amount of redundancy and symmetry in the case work *)
Lemma pr_shuffle_then_split {A: eqType} (l: list A) (P Q: pred A) l1 l2 a0
  (Ha0: ∀ a, ((~~ P a) ∧ (~~ Q a)) ↔ a = a0)
  (HPQ: ∀ a, ~~ (P a && Q a)):
  uniq l →
  perm_eq (filter P l) l1 →
  perm_eq (filter Q l) l2 →
  pr_eq (rvar_of_ldist (lrand ← rand_perm_list l; mret (filter P lrand, filter Q lrand)))
        (l1, l2) = (1 / INR (size l1)`!) * (1 / INR (size l2)`!).
Proof.
  remember (size l) as k eqn:Heq.
  revert l l1 l2 Heq.
  induction k as [k IH] using (well_founded_induction lt_wf)
    => l l1 l2 Heq Huniq Hperm1 Hperm2.
  assert (Ha0Q: ~ Q a0).
  {
    intros HQ.
    specialize (proj2 (Ha0 a0) Init.Logic.eq_refl); auto.
    intros (?&?). subst. apply /negP; eauto.
  }
  assert (Ha0P: ~ P a0).
  {
    intros HP.
    specialize (proj2 (Ha0 a0) Init.Logic.eq_refl); auto.
    intros (?&_). subst. apply /negP; eauto.
  }
  assert (size l = size l1 + size l2 + (a0 \in l))%nat as Hsize_combine.
  {
    apply perm_eq_size in Hperm1.
    apply perm_eq_size in Hperm2.
    rewrite -Hperm1.
    rewrite -Hperm2.
    rewrite ?size_filter.
    rewrite -count_predT -count_predUI.
    rewrite (@eq_in_count _ (predI P Q) pred0); last first.
    { intros a Hin => //=. apply /negP. specialize (HPQ a). move /negP in HPQ. auto. }
    rewrite count_pred0 addn0.
    rewrite -count_uniq_mem //.
    rewrite -count_predUI //=.
    rewrite (@eq_in_count _ (predI (predU P Q) (pred1 a0)) pred0); last first.
    { intros a Hin => //=. apply /andP.  intros (Hor&Heq').
      move /eqP in Heq'. move /orP in Hor. destruct Hor; subst; auto. }
    rewrite count_pred0 addn0. apply eq_in_count.
    intros a Hin. rewrite //=. symmetry. apply /orP.
    specialize (Ha0 a).
    destruct (P a) => //=; auto; [].
    destruct (Q a) => //=; auto; [].
    right. apply /eqP. apply Ha0; auto.
  }
  destruct l as [| a1 l]; last destruct l as [| a2 l].
  - subst.
    rewrite ?rand_perm_list_unfold ?ldist_left_id ?pr_mret_simpl //=.
    rewrite //= in Hperm1 Hperm2.
    rewrite perm_eq_sym in Hperm1. apply perm_eq_nil in Hperm1.
    rewrite perm_eq_sym in Hperm2. apply perm_eq_nil in Hperm2.
    subst. rewrite eq_refl //=. field.
  - rewrite ?rand_perm_list_unfold ?ldist_left_id ?pr_mret_simpl //=.
    rewrite //= in Hperm1 Hperm2.
    move: Hperm1 Hperm2.
    case: (P a1);
    case: (Q a1);
    intros Hperm1; rewrite perm_eq_sym in Hperm1;
    intros Hperm2; rewrite perm_eq_sym in Hperm2;
    try (apply perm_eq_nil in Hperm1);
    try (apply perm_eq_singleton in Hperm1);
    try (apply perm_eq_nil in Hperm2);
    try (apply perm_eq_singleton in Hperm2);
    subst; rewrite ?eq_refl //=; field.
  - rewrite ?rand_perm_list_unfold ldist_assoc.
    destruct l1 as [| a1_ l1]; destruct l2 as [| a2_ l2].
    * exfalso.  apply perm_eq_nil in Hperm1. apply perm_eq_nil in Hperm2.
      { assert (a1 = a2).
        { transitivity a0.
          ** apply Ha0; split.
             *** move: Hperm1. rewrite //=. case: ifP; auto; try congruence.
             *** move: Hperm2. rewrite //=. case: ifP; auto; try congruence.
          ** symmetry; apply Ha0; split.
             *** move: Hperm1. rewrite //=. repeat case: ifP; auto; try congruence.
             *** move: Hperm2. rewrite //=. repeat case: ifP; auto; try congruence.
        }
        subst. rewrite //= in Huniq. move /andP in Huniq. rewrite in_cons eq_refl //= in Huniq.
        intuition.
      }
    * rewrite pr_mbind_ldist2.
      assert (Q a2_) as HQa2.
      {
        cut (is_true (a2_ \in (filter Q [:: a1, a2 & l]))).
        { rewrite mem_filter. move /andP. intuition. }
        rewrite (perm_eq_mem Hperm2) in_cons eq_refl //.
      }
      assert (Hpf: a2_ \in (a1 :: a2 :: l)).
      { apply perm_eq_mem in Hperm2.
        specialize (Hperm2 a2_). rewrite mem_filter in Hperm2.
        symmetry in Hperm2. rewrite in_cons eq_refl //= in Hperm2.
        symmetry in Hperm2. move /andP in Hperm2. destruct Hperm2; auto.
      }
      rewrite (@big_rem _ _ _ _ (undup _) (exist _ (a2_) Hpf)); last first.
      { rewrite mem_undup. apply draw_next_all. auto. }
      case_eq (a0 \in (a1 :: a2 :: l)).
      ** intros Hpf'.
      rewrite (@big_rem _ _ _ _ (rem _ (undup _)) (exist _ (a0) Hpf')); last first.
      {
        rewrite rem_filter; last apply undup_uniq.
        rewrite mem_filter. apply /andP; split.
        - rewrite //=. apply /eqP => Heq'. inversion Heq' as [[Heq'']].
            subst. auto.
        - rewrite mem_undup. by apply draw_next_all.
      }
      rewrite (rem_filter (exist _ _ Hpf')); last first.
      { apply rem_uniq, undup_uniq. }
      rewrite (rem_filter (exist _ a2_ Hpf)); last first.
      { apply undup_uniq. }
      rewrite -filter_predI.
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HQa2.
        assert ( P a2_ = false) as ->.
        { apply /negP. intros HP. specialize (HPQ a2_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        assert ( P a0 = false) as -> by (apply /negP; auto).
        assert ( Q a0 = false) as -> by (apply /negP; auto).
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls, a2_ :: snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls, a2_ :: snd ls)) ([::], l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls, snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls, snd ls)) ([::], l2)); last first.
        { intros (?&?) (?&?). rewrite //=. }
        rewrite (IH (size (rem a2_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq);
        first (rewrite (IH (size (rem a0 [:: a1, a2 & l]))));
        try (rewrite size_rem //=); try by apply rem_uniq.
        **** simpl size. rewrite fact0. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (size l = size l2) as ->.
             { nify. omega. }
             field => //=.
             specialize (INR_fact_gt0 (size l2)); intros.
             specialize (pos_INR (size l2)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace [::] with (rem a0 [::]) by auto.
             apply perm_eq_rem. done.
        **** rewrite filter_rem. replace (a2_ :: l2) with (rem a0 (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm2) mem_filter. move /andP. intros (?&?); auto.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace [::] with (rem a2_ [::]) by auto.
             apply perm_eq_rem. done.
        **** rewrite filter_rem. replace (l2) with (rem a2_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
      }
      intros (i&?) Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (P i); first (intros HP; rewrite HP in Heq1; inversion Heq1).
      intros HnP.
      case_eq (Q i).
      { intros HQ. rewrite HQ in Heq2. inversion Heq2. move /andP in Hin.
        destruct Hin as (_&Hin). move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnQ.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst.
      move /andP in Hin. destruct Hin as (Hin&?). move /negP in Hin. apply Hin. subst.
      apply /eqP; f_equal. apply bool_irrelevance.
      ** intros Hpf'.
      rewrite (rem_filter (exist _ a2_ Hpf)); last first.
      { apply undup_uniq. }
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HQa2.
        assert ( P a2_ = false) as ->.
        { apply /negP. intros HP. specialize (HPQ a2_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls, a2_ :: snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls, a2_ :: snd ls)) ([::], l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite (IH (size (rem a2_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq).
        **** simpl size. rewrite fact0. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (S (size l) = size l2) as <-.
             { nify. omega. }
             rewrite factS mult_INR ?S_INR.
             field => //=.
             specialize (INR_fact_gt0 (size l)); intros.
             specialize (pos_INR (size l)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace [::] with (rem a2_ [::]) by auto.
             apply perm_eq_rem. done.
        **** rewrite filter_rem. replace (l2) with (rem a2_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
      }
      intros (i&Hin') Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (P i); first (intros HP; rewrite HP in Heq1; inversion Heq1).
      intros HnP.
      case_eq (Q i).
      { intros HQ. rewrite HQ in Heq2. inversion Heq2.
        move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnQ.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst. clear -Hin' Hpf'. move /negP in Hpf'. apply Hpf'.
      rewrite /in_mem. done.
    * rewrite pr_mbind_ldist2.
      assert (P a1_) as HPa2.
      {
        cut (is_true (a1_ \in (filter P [:: a1, a2 & l]))).
        { rewrite mem_filter. move /andP. intuition. }
        rewrite (perm_eq_mem Hperm1) in_cons eq_refl //.
      }
      assert (Hpf: a1_ \in (a1 :: a2 :: l)).
      { apply perm_eq_mem in Hperm1.
        specialize (Hperm1 a1_). rewrite mem_filter in Hperm1.
        symmetry in Hperm1. rewrite in_cons eq_refl //= in Hperm1.
        symmetry in Hperm1. move /andP in Hperm1. destruct Hperm1; auto.
      }
      rewrite (@big_rem _ _ _ _ (undup _) (exist _ (a1_) Hpf)); last first.
      { rewrite mem_undup. apply draw_next_all. auto. }
      case_eq (a0 \in (a1 :: a2 :: l)).
      ** intros Hpf'.
      rewrite (@big_rem _ _ _ _ (rem _ (undup _)) (exist _ (a0) Hpf')); last first.
      {
        rewrite rem_filter; last apply undup_uniq.
        rewrite mem_filter. apply /andP; split.
        - rewrite //=. apply /eqP => Heq'. inversion Heq' as [[Heq'']].
            subst. auto.
        - rewrite mem_undup. by apply draw_next_all.
      }
      rewrite (rem_filter (exist _ _ Hpf')); last first.
      { apply rem_uniq, undup_uniq. }
      rewrite (rem_filter (exist _ a1_ Hpf)); last first.
      { apply undup_uniq. }
      rewrite -filter_predI.
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HPa2.
        assert ( Q a1_ = false) as ->.
        { apply /negP. intros HP. specialize (HPQ a1_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        assert ( P a0 = false) as -> by (apply /negP; auto).
        assert ( Q a0 = false) as -> by (apply /negP; auto).
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (a1_ :: fst ls,  snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (a1_ :: fst ls,  snd ls)) (l1, [::])); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls, snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls, snd ls)) (l1, [::])); last first.
        { intros (?&?) (?&?). rewrite //=. }
        rewrite (IH (size (rem a1_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq);
        first (rewrite (IH (size (rem a0 [:: a1, a2 & l]))));
        try (rewrite size_rem //=); try by apply rem_uniq.
        **** simpl size. rewrite fact0. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (size l = size l1) as ->.
             { nify. omega. }
             field => //=.
             specialize (INR_fact_gt0 (size l1)); intros.
             specialize (pos_INR (size l1)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (a1_ :: l1) with (rem a0 (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm1) mem_filter. move /andP. intros (?&?); auto.
        **** rewrite filter_rem. replace [::] with (rem a0 [::]) by auto.
             apply perm_eq_rem. done.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (l1) with (rem a1_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** rewrite filter_rem. replace [::] with (rem a1_ [::]) by auto.
             apply perm_eq_rem. done.
      }
      intros (i&?) Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (Q i); first (intros HQ; rewrite HQ in Heq2; inversion Heq2).
      intros HnQ.
      case_eq (P i).
      { intros HP. rewrite HP in Heq1. inversion Heq1. move /andP in Hin.
        destruct Hin as (_&Hin). move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnP.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst.
      move /andP in Hin. destruct Hin as (Hin&?). move /negP in Hin. apply Hin. subst.
      apply /eqP; f_equal. apply bool_irrelevance.
      ** intros Hpf'.
      rewrite (rem_filter (exist _ a1_ Hpf)); last first.
      { apply undup_uniq. }
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HPa2.
        assert ( Q a1_ = false) as ->.
        { apply /negP. intros HP. specialize (HPQ a1_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (a1_ :: fst ls,  snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (a1_ :: fst ls, snd ls)) (l1, [::])); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite (IH (size (rem a1_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq).
        **** simpl size. rewrite fact0. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (S (size l) = size l1) as <-.
             { nify. omega. }
             rewrite factS mult_INR ?S_INR.
             field => //=.
             specialize (INR_fact_gt0 (size l)); intros.
             specialize (pos_INR (size l)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (l1) with (rem a1_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** rewrite filter_rem. replace [::] with (rem a1_ [::]) by auto.
             apply perm_eq_rem. done.
      }
      intros (i&Hin') Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (Q i); first (intros HQ; rewrite HQ in Heq2; inversion Heq2).
      intros HnQ.
      case_eq (P i).
      { intros HP. rewrite HP in Heq1. inversion Heq1.
        move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnP.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst. clear -Hin' Hpf'. move /negP in Hpf'. apply Hpf'.
      rewrite /in_mem. done.
    * rewrite pr_mbind_ldist2.
      assert (P a1_) as HPa1.
      {
        cut (is_true (a1_ \in (filter P [:: a1, a2 & l]))).
        { rewrite mem_filter. move /andP. intuition. }
        rewrite (perm_eq_mem Hperm1) in_cons eq_refl //.
      }
      assert (Q a2_) as HQa2.
      {
        cut (is_true (a2_ \in (filter Q [:: a1, a2 & l]))).
        { rewrite mem_filter. move /andP. intuition. }
        rewrite (perm_eq_mem Hperm2) in_cons eq_refl //.
      }
      assert (Hpf1: a1_ \in (a1 :: a2 :: l)).
      { apply perm_eq_mem in Hperm1.
        specialize (Hperm1 a1_). rewrite mem_filter in Hperm1.
        symmetry in Hperm1. rewrite in_cons eq_refl //= in Hperm1.
        symmetry in Hperm1. move /andP in Hperm1. destruct Hperm1; auto.
      }
      rewrite (@big_rem _ _ _ _ (undup _) (exist _ (a1_) Hpf1)); last first.
      { rewrite mem_undup. apply draw_next_all. auto. }
      assert (Hpf2: a2_ \in ((a1 :: a2 :: l))).
      { apply perm_eq_mem in Hperm2.
        specialize (Hperm2 a2_). rewrite mem_filter in Hperm2.
        symmetry in Hperm2. rewrite in_cons eq_refl //= in Hperm2.
        symmetry in Hperm2. move /andP in Hperm2. destruct Hperm2; auto.
      }
      rewrite (@big_rem _ _ _ _ (rem _ (undup _)) (exist _ (a2_) Hpf2)); last first.
      { rewrite rem_filter; last by apply undup_uniq. rewrite mem_filter mem_undup.
        apply /andP; split.
        * rewrite //=. apply /eqP. intros Heq'. inversion Heq'. subst.
          specialize (HPQ a1_). move /negP in HPQ. apply HPQ. apply /andP; split; auto.
        * apply draw_next_all; auto.
      }
      case_eq (a0 \in (a1 :: a2 :: l)).
      ** intros Hpf'.
      rewrite (@big_rem _ _ _ _ (rem _ (rem _ (undup _))) (exist _ (a0) Hpf')); last first.
      {
        rewrite ?rem_filter //; [| apply undup_uniq | apply filter_uniq, undup_uniq
                                 | apply undup_uniq ].
        rewrite ?mem_filter. repeat (apply /andP; split).
        - rewrite //=. apply /eqP => Heq'. inversion Heq' as [[Heq'']].
            subst. auto.
        - rewrite //=. apply /eqP => Heq'. inversion Heq' as [[Heq'']].
            subst. auto.
        - rewrite mem_undup. by apply draw_next_all.
      }
      rewrite (rem_filter (exist _ _ Hpf')); last first.
      { apply rem_uniq, rem_uniq, undup_uniq. }
      rewrite (rem_filter (exist _ a1_ Hpf1)); last first.
      { apply undup_uniq. }
      rewrite (rem_filter (exist _ a2_ Hpf2)); last first.
      { apply filter_uniq, undup_uniq. }
      rewrite -?filter_predI.
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HPa1 HQa2.
        assert ( Q a1_ = false) as HnQ1.
        { apply /negP. intros HP. specialize (HPQ a1_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite HnQ1.
        assert ( P a2_ = false) as HnP2.
        { apply /negP. intros HP. specialize (HPQ a2_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite HnP2.
        assert ( P a0 = false) as -> by (apply /negP; auto).
        assert ( Q a0 = false) as -> by (apply /negP; auto).
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls, snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls, snd ls)) (a1_ :: l1, a2_ ::l2)); last first.
        { intros (?&?) (?&?). rewrite //=. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (a1_ :: fst ls,  snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (a1_ :: fst ls,  snd ls)) (l1, a2_ :: l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls,  a2_ :: snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls,  a2_ :: snd ls)) (a1_ :: l1, l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite (IH (size (rem a1_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq);
        first rewrite (IH (size (rem a2_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq);
        first (rewrite (IH (size (rem a0 [:: a1, a2 & l]))));
        try (rewrite size_rem //=); try by apply rem_uniq.
        **** simpl size. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (size l = size l1 + size l2 + 1)%nat as ->.
             { nify. omega. }
             rewrite ?S_INR ?factS ?plus_INR ?mult_INR ?S_INR //=.
             field => //=.
             specialize (INR_fact_gt0 (size l1)); intros.
             specialize (INR_fact_gt0 (size l2)); intros.
             specialize (pos_INR (size l1)); intros.
             specialize (pos_INR (size l2)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (a1_ :: l1) with (rem a0 (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm1) mem_filter. move /andP. intros (?&?); auto.
        **** rewrite filter_rem. replace (a2_ :: l2) with (rem a0 (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm2) mem_filter. move /andP. intros (?&?); auto.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (a1_ :: l1) with (rem a2_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm1) mem_filter. move /andP. intros (?&?); auto.
             move /negP in HnP2. auto.
        **** rewrite filter_rem. replace (l2) with (rem a2_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (l1) with (rem a1_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** rewrite filter_rem. replace (a2_ :: l2) with (rem a1_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm2) mem_filter. move /andP. intros (?&?); auto.
             move /negP in HnQ1. auto.
      }
      intros (i&?) Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (Q i).
      { intros HQ. rewrite HQ in Heq2. inversion Heq2. move /andP in Hin.
        destruct Hin as (Hin&_). move /andP in Hin. destruct Hin as (_&Hin).
        move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnQ.
      case_eq (P i).
      { intros HP. rewrite HP in Heq1. inversion Heq1. move /andP in Hin.
        destruct Hin as (_&Hin). move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnP.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst.
      move /andP in Hin. destruct Hin as (Hin&?). move /andP in Hin.
      destruct Hin as (Hin&_). move /negP in Hin. apply Hin.
      apply /eqP; f_equal. apply bool_irrelevance.
      ** intros Hpf'.
      rewrite (rem_filter (exist _ a1_ Hpf1)); last first.
      { apply undup_uniq. }
      rewrite (rem_filter (exist _ a2_ Hpf2)); last first.
      { apply filter_uniq, undup_uniq. }
      rewrite -?filter_predI.
      rewrite big_filter.
      rewrite big1.
      { rewrite ?draw_next_pr //.
        rewrite /sval. rewrite ?ldist_fmap_bind. simpl filter.
        rewrite HPa1.
        rewrite HQa2.
        assert ( Q a1_ = false) as HnQ1.
        { apply /negP. intros HP. specialize (HPQ a1_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite HnQ1.
        assert ( P a2_ = false) as HnP2.
        { apply /negP. intros HP. specialize (HPQ a2_). move /negP in (HPQ).
          apply HPQ. apply /andP. intuition. }
        rewrite HnP2.
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (a1_ :: fst ls,  snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (a1_ :: fst ls,  snd ls)) (l1, a2_ :: l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite -(ldist_fmap_bind _ (λ l, ([seq x <- l | P x],
                                           [seq x <- l | Q x]))
                                  (λ ls, mret (fst ls,  a2_ :: snd ls))).
        rewrite (pr_mbind_mret_inj _ (λ ls, (fst ls,  a2_ :: snd ls)) (a1_ :: l1, l2)); last first.
        { intros (?&?) (?&?). rewrite //=. inversion 1. congruence. }
        rewrite (IH (size (rem a1_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try (by apply rem_uniq);
        first rewrite (IH (size (rem a2_ [:: a1, a2 & l]))); eauto;
        try (rewrite size_rem //=); try by apply rem_uniq.
        **** simpl size. replace (INR 1) with 1 by auto.
             rewrite ?S_INR ?factS mult_INR ?S_INR //=.
             rewrite Hpf' //= in Hsize_combine.
             assert (size l = size l1 + size l2)%nat as ->.
             { nify. omega. }
             rewrite ?S_INR ?factS ?plus_INR ?mult_INR ?S_INR //=.
             field => //=.
             specialize (INR_fact_gt0 (size l1)); intros.
             specialize (INR_fact_gt0 (size l2)); intros.
             specialize (pos_INR (size l1)); intros.
             specialize (pos_INR (size l2)); intros.
             repeat split; nra.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (a1_ :: l1) with (rem a2_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm1) mem_filter. move /andP. intros (?&?); auto.
             move /negP in HnP2. auto.
        **** rewrite filter_rem. replace (l2) with (rem a2_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** subst. rewrite //=.
        **** rewrite filter_rem. replace (l1) with (rem a1_ (a1_ :: l1)); first
             by apply perm_eq_rem.
             rewrite //= eq_refl. done.
        **** rewrite filter_rem. replace (a2_ :: l2) with (rem a1_ (a2_ :: l2)); first
             by apply perm_eq_rem.
             rewrite rem_id //. apply /negP.
             rewrite -(perm_eq_mem Hperm2) mem_filter. move /andP. intros (?&?); auto.
             move /negP in HnQ1. auto.
      }
      intros (i&Hin') Hin. apply Rmult_eq_0_compat_l.
      rewrite //= in Hin.
      rewrite ldist_fmap_bind.
      apply pr_mbind_mret_inj0. intros lrest.
      intros Heq'. inversion Heq' as [[Heq1 Heq2]].
      case_eq (Q i).
      { intros HQ. rewrite HQ in Heq2. inversion Heq2. move /andP in Hin.
        destruct Hin as (Hin&_). move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnQ.
      case_eq (P i).
      { intros HP. rewrite HP in Heq1. inversion Heq1. move /andP in Hin.
        destruct Hin as (_&Hin). move /negP in Hin. apply Hin. subst.
        apply /eqP; f_equal. apply bool_irrelevance. }
      intros HnP.
      assert (i = a0).
      { apply Ha0. rewrite HnP HnQ //. }
      subst. clear -Hin' Hpf'. move /negP in Hpf'. apply Hpf'.
      rewrite /in_mem. done.
Qed.

Local Open Scope nat_scope.
Lemma rand_perm_list_split l (x: nat):
  uniq l →
      eq_dist (rvar_of_ldist (l' ← rand_perm_list l;
                                mret ([seq i <- l' | i < x], [seq i <- l' | x < i])))
              (rvar_of_ldist
                 (l1 ← rand_perm_list [seq i <- l | i < x];
                  l2 ← rand_perm_list [seq i <- l | x < i];
                  mret (l1, l2))).
Proof.
  intros Huniq.
  apply (mspec_range_eq_dist _ _ (λ ls, (perm_eq [seq i <- l | i < x]) (fst ls) &&
                                        (perm_eq [seq i <- l | x < i]) (snd ls))).
  {
    eapply mspec_mbind; first apply rand_perm_list_correct. intros l' Hperm.
    apply mspec_mret => //=. apply /andP; split; apply quicksort_cost.perm_filter, Hperm.
  }
  {
    eapply mspec_mbind; first apply rand_perm_list_correct. intros l1 Hperm1.
    eapply mspec_mbind; first apply rand_perm_list_correct. intros l2 Hperm2.
    apply mspec_mret => //=. apply /andP; split;  try apply Hperm1; try apply Hperm2.
  }
  intros (l1&l2). move /andP. intros (Hperm1&Hperm2).
  rewrite (pr_shuffle_then_split _ _ _ _ _ x) //=.
  * intros. rewrite pr_eq_bind_pair.
    rewrite ?pr_rand_perm_list //.
    ** apply perm_eq_size in Hperm1. rewrite Hperm1 //.
       apply perm_eq_size in Hperm2. rewrite Hperm2 //.
    ** by apply filter_uniq.
    ** by apply filter_uniq.
  * intros a; split.
    ** intros (Hnlt&Hngt).
       move /ltP in Hnlt.
       move /ltP in Hngt.
       omega.
    ** intros ->. split; apply /ltP; omega.
  * intros a. apply /andP. intros (Hlt1&Hlt2).
    move /ltP in Hlt1.
    move /ltP in Hlt2.
    omega.
Qed.


From Undecidability.L Require Import L Tactics.LTactics AbstractMachines.LargestVar Util.Subterm.

From Complexity.L Require Import AbstractHeapMachineDef UnfoldTailRec AbstractHeapMachine.
From Complexity.L.AbstractMachines.Computable Require Import Unfolding HeapMachine Shared EvalForTime EvalForTimeBool.

From Complexity.HierarchyTheorem Require Import AbstractTimeHierarchyTheorem.
From Complexity.Complexity Require Import Definitions.
From Undecidability.L.Datatypes Require Import Lists.
From Complexity.L.Datatypes Require Import LBinNums.
From Complexity.L.Functions Require Import BinNums BinNumsCompare.
From Undecidability.L.Functions Require Import UnboundIteration.

Section TimeHierarchy.

  Variable f : nat -> nat.
  Hypothesis TC__f : timeConstructible f.
  Hypothesis f_geq_n : forall n, n <= f n.

  Let fT := projT1 TC__f.

  Definition comp_t__E: computableTime' (fun n => N.of_nat (f n)) (fun n _ => (fT n,tt)) := timeConstructible_computableTime' TC__f.
  Definition inO_time_t__E: fT ∈O f := timeConstructible_inO TC__f.

  Definition L__f : term * nat -> Prop :=
    Eval unfold L__f in
      @L__f f.

  Definition E (fuel:N) (s:term) := negb (evalForTimeBool false fuel s).

#[export]
Instance term_t__E : computableTime' E (fun fuel _ => (1, fun s _ => (t__evalForTimeBool (largestVar s) (size s) (N.to_nat fuel) + 7, tt))).
  Proof.
    extract. solverec.
  Qed.

  Definition t__E (largestVar size:nat) fuel := t__evalForTimeBool largestVar size fuel + 8.

  Import L_Notations.

  Lemma E__spec (s:term) (fuel : N):
      closed s ->
      exists res : bool,
        (extT E) (enc fuel) (enc s) ⇓(<=t__E (largestVar s) (size s) (N.to_nat fuel)) (enc res) /\
        if res
        then ~ (s ⇓(<= N.to_nat fuel ) (enc false))
        else s ⇓(<= N.to_nat fuel) (enc false).
  Proof.
    intros. eexists. split.
    {
      eapply le_evalLe_proper, evalle_trans. 2,3:reflexivity.
      2:now Lsimpl.
      2:Lreflexivity.
      solverec. reflexivity.
    }
    unfold E. destruct (evalForTimeBool_spec false s fuel).
    -cbn. easy.
    -cbn. easy.
  Qed.

  Lemma mono_t__E maxVar maxVar' x x' size size' :
    maxVar <= maxVar' -> x <= x' -> size <= size' -> t__E maxVar size x <= t__E maxVar' size' x'.
  Proof.
    intros H1 H2 H3.
    unfold t__E,t__evalForTimeBool.
    rewrite mono_t__evalForTime. 2-4:eassumption.
    repeat (lazymatch goal with
              |- _ + _ <= _ + _ => eapply Nat.add_le_mono
            | |- _ * _ <= _ * _ => eapply Nat.mul_le_mono
            | |- _ => first [eassumption | reflexivity | eapply N_size_nat_monotone | eapply unfoldBool_time_mono | Lia.nia |eapply heapStep_timeBound_mono']
            end).
  Qed.

  Lemma suplin_t__E maxVar size x : x <= t__E maxVar size x.
  Proof.
    unfold t__E,t__evalForTimeBool . intros. rewrite <- suplin_t__evalForTime. Lia.nia.
  Qed.

  Lemma inO_size_nat f' g:
    f' ∈O g ->
    (fun n => N.size_nat (N.of_nat (f' n))) ∈O g.
  Proof using fT f TC__f.
    intros (c0&n0&H).
    eexists c0,n0.
    intros. rewrite N_size_nat_leq. easy.
  Qed.

  Ltac inO_leq n := simple eapply inO_leq with (n0:=n);intros ;try rewrite <- !f_geq_n;nia.

  Lemma in_O_t__E :
    (fun n : nat => t__E n (2 * n) (f n)) ∈O (fun n => n * f n * f n).
  Proof using f_geq_n fT TC__f.
    unfold t__E,t__evalForTimeBool,t__evalForTime.

    all:unfold unfoldBool_time.
    all:unfold heapStep_timeBound,Lookup.lookupTime.
    smpl_inO.
    1,4,6-11:inO_leq 1.
    2:unfold unfoldBool_time.
    2-3:unfold heapStep_timeBound,Lookup.lookupTime.
    -eapply inO_size_nat. inO_leq 1.
    -transitivity (fun n => f n * ( n * f n)). 2:inO_leq 1.
     simple eapply inO_mul_l.
     all:smpl_inO.
     1-2,5-8:solve [inO_leq 1].
     +eapply inO_size_nat. smpl_inO. all:inO_leq 1.
     +simple eapply inO_mul_l. all:smpl_inO. all:inO_leq 1.
    -setoid_rewrite Nat.mul_comm at 1. eapply inO_mul_l.
     all:smpl_inO. all:try inO_leq 1.
  Qed.

  Lemma LA_In_f_times_step':
    L__f ∈TimeO (fun n : nat => t__E n (2 * n) (f n)).
  Proof using f_geq_n fT TC__f.
    eapply LA_In_f_times_step.
    all:eauto using comp_t__E,E__spec,proc_extT,inO_time_t__E,mono_t__E,suplin_t__E.
  Qed.

  Lemma L_A_notIn_f : ~ L__f ∈Timeo f.
  Proof.
    apply L_A_notIn_f.
  Qed.

  Lemma LA_In_f_times_step:
    L__f ∈TimeO (fun n => n * f n * f n).
  Proof using f_geq_n fT TC__f.
    eapply inTime_mono.
    apply in_O_t__E.
    apply LA_In_f_times_step'.
  Qed.

  Lemma TimeHierarchyTheorem :
    exists (P : term * nat -> Prop), ~P ∈Timeo f /\ P ∈TimeO (fun n => n * f n * f n).
  Proof using f_geq_n fT TC__f.
    exists L__f;split. all:eauto using L_A_notIn_f, LA_In_f_times_step.
  Qed.
End TimeHierarchy.

(**Check TimeHierarchyTheorem.
Axiom free:
Print Assumptions TimeHierarchyTheorem.
*)


Require Import Coq.Lists.List.
Require Import Logic.LogicGenerator.Utils.
Require Import Logic.LogicGenerator.ConfigLang.

Import ListNotations.

Definition how_connectives :=
  [primitive_connective impp
  ;primitive_connective andp
  ;primitive_connective orp
  ;primitive_connective falsep
  ;primitive_connective coq_prop
  ;primitive_connective sepcon
  ;primitive_connective emp
  ;FROM_andp_impp_TO_iffp
  ;FROM_falsep_impp_TO_negp
  ;FROM_falsep_impp_TO_truep
  ;FROM_impp_TO_multi_imp
  ;FROM_empty_set_TO_empty_context
  ;FROM_andp_TO_iter_andp
  ;FROM_sepcon_TO_iter_sepcon
  ].

Definition how_judgements :=
  [primitive_judgement provable
  ;primitive_judgement corable
  ;FROM_provable_TO_derivable
  ;FROM_provable_TO_derivable1
  ;FROM_provable_TO_logic_equiv
  ].

Definition transparent_names :=
  [expr:parameter].

Definition primitive_rule_classes :=
  [ provability_OF_impp
  ; provability_OF_andp
  ; provability_OF_orp
  ; provability_OF_falsep
  ; provability_OF_classical_logic
  ; provability_OF_sepcon_rule_AS_weak_iffp
  ; provability_OF_sepcon_rule_AS_mono
  ; provability_OF_sepcon_orp_rule
  ; provability_OF_sepcon_falsep_rule
  ; provability_OF_emp_rule_AS_iffp
  ; corability_OF_basic_setting
  ; corability_OF_coq_prop
  ].


(* -*- coq-prog-name: "coqtop"; -*- *)

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

Require Import ssreflect ssrfun ssrbool .
From Modules Require Import lib HomotopicalEquality PreSyntaxOnlyContr Syntax.

Set Bullet Behavior "Strict Subproofs".

(* La version inductive *)
Inductive WVar : Con -> Ty -> Var -> Type :=
  w_vstar : WVar x:⋆ ⋆ vstar
| w_vwk Γ A u B x : WVar Γ B x ->
                 (* Je dois aussi mettre les hypothèses suivantes *)
                    Wtm Γ A u ->
                    WVar (Γ ,C A , #0 → u) (wkT B) (vwk x)
| w_v1 Γ A u : Wtm Γ A u -> WVar (Γ ,C A , #0 → u) (wkT A) v1
| w_v0 Γ A u : Wtm Γ A u -> WVar (Γ ,C A , #0 → u)
                                ((va v1) →⟨ wkT A ⟩ (wkt u)) v0

with WC : Con -> Type :=
  w_astar : WC x:⋆
| w_ext Γ A u : WC Γ -> WTy Γ A ->  Wtm Γ A u -> WC (Γ ,C A , #0 → u)
with WTy : Con -> Ty -> Type :=
       | w_star Γ : WC Γ -> WTy Γ ⋆
       | w_ar Γ A t u : WTy Γ A -> Wtm Γ A t -> Wtm Γ A u -> WTy Γ (t →⟨A⟩ u)
with Wtm : Con -> Ty -> Tm -> Type :=
       | w_va Γ A x : WVar Γ A x -> Wtm Γ A (va x)
       | w_coh Γ Δ A σ : WC Δ -> WTy Δ A -> WS Γ Δ σ ->
                         (* en principe inutile, mais je le rajoute pour avoir la bonne hypothèse
                           de récurrence *)
                         (* WTy Γ A.[σ]T  -> *)
                         Wtm Γ A.[σ]T (coh Δ A σ)
with WS : Con -> Con -> sub -> Type :=
     | w_to_star Γ t : Wtm Γ ⋆ t -> WS Γ x:⋆ ❪ t ❫
     | w_to_ext Γ A u Δ σ t f : WS Γ Δ σ ->
                                WTy Δ A ->
                                Wtm Δ A u ->
                                Wtm Γ A.[σ]T t ->
                                Wtm Γ (t →⟨ A.[ σ ]T ⟩  u.[σ]t) f ->
                                WS Γ (Δ ,C A , #0 → u) (σ ,S t , f).

Instance syntax : Syntax preSyntax := Build_Syntax WC WTy Wtm WS.

Notation "Gamma ⊢_v s : A" := (WVar Gamma A s) : wf_scope.

Fixpoint wkTm_inj (a b: Tm) (e : wkt a = wkt b) {struct a}: a = b
with wkS_inj (x y : sub)(e : wkS x = wkS y) {struct x} : x = y.
  - destruct a,b => //=.
    +  by case:e => ->.
    + case:e .
      move => ?? /wkS_inj .
      intros; subst.
      f_equal.
  - destruct x,y => //=.
    + case:e.
      by move/wkTm_inj => ->.
    + case:e.
      by move => /wkS_inj -> /wkTm_inj -> /wkTm_inj -> .
Qed.

Fixpoint wkTy_inj  (a b: Ty) (e : wkT a = wkT b) {struct a}: a = b.
  destruct a,b => //=.
  - case:e .
    move =>/wkTy_inj ->.
    move/wkTm_inj => ->.
    move/ wkTm_inj ->.
    reflexivity.
Qed.

(* Ici j'utilise JMeq_eq général mais j'aurai pu le montrer en particulier en
montrant UIP spécifiquement sur la syntaxe *)
Fixpoint WC_hp Γ (wΓ : WC Γ) : is_center wΓ
with WTy_hp Γ A (wA : Γ ⊢ A) : is_center wA
with WTm_hp Γ A t (wt : Γ ⊢ t : A) : is_center wt
with WVar_hp Γ A x (wx : WVar Γ A x) : is_center wx
with WS_hp Γ Δ σ (wσ : (Γ ⊢ σ ⇒  Δ)) : is_center wσ.
-  destruct wΓ.
   + move => w.
     apply:JMeq_eq.
     set (C := astar) in w.
     (* need to do that otherwise it odes not genralize proper;ly
before :
  @JMeq (WC astar) w (WC astar) w_astar
after :
@JMeq (WC C) w (WC astar) w_astar
*)
     change (w ≅ w_astar).
     have  : C = astar by reflexivity.
     case:w => //=.
   + move => wΓe.
     set (C := ext _ _ _) in wΓe.
     apply:JMeq_eq.
     change (  wΓe ≅ w_ext wΓ w w0).
     have  : C = ext Γ A u by reflexivity.
     case : wΓe => //=.
     move => ?????? [? ? ?].
     subst.
     apply:JMeq_from_eq.
     f_equal.
     * apply:WC_hp.
     * apply:WTy_hp.
     * apply:WTm_hp.
- destruct wA.
  + move => wst.
    set (Ct := Γ) in wst.
    set (C := star) in wst.
    apply:JMeq_eq.
    change (  wst ≅ w_star w).
    have  : C = star  by reflexivity.
    have  : Ct = Γ  by reflexivity.
    case : wst => //=.
    intros; subst.
    apply:JMeq_from_eq.
    f_equal.
    apply:WC_hp.
  +  move => wAr.
     set (Ct := Γ) in wAr.
     set (C := ar A t u) in wAr.
    apply:JMeq_eq.
    change (  wAr ≅ w_ar wA w w0).
    have  : C = ar A t u  by reflexivity.
    have  : Ct = Γ  by reflexivity.
    case : wAr => //=.
    intros; subst.
    case:x0; intros; subst.
    apply:JMeq_from_eq.
    f_equal.
    * apply:WTy_hp.
    * apply:WTm_hp.
    * apply:WTm_hp.
- destruct wt.
  + move => wt'.
     set (CC := Γ) in wt'.
     set (CT := A) in wt'.
     set (Ct := va x) in wt'.
     apply:JMeq_eq.
     change   (wt' ≅ w_va w).
     move:(erefl CC) (erefl CT) (erefl Ct).
     rewrite {2}/CC {2}/CT {2}/Ct.
     case:wt' => //=.
     intros ; subst.
     case:H1; intros; subst.
     apply:JMeq_from_eq.
     f_equal.
     by apply:WVar_hp.
  + move => wt'.
     set (CC := Γ) in wt'.
     set (CT := A.[σ]T) in wt'.
     set (Ct := coh Δ A σ) in wt'.
     apply:JMeq_eq.
     change   (wt' ≅ w_coh w w0 w1).
     move:(erefl CC) (erefl CT) (erefl Ct).
     rewrite {2}/CC {2}/CT {2}/Ct.
     case:wt' => //=.
     intros ; subst.
     case:H1 => ???; subst.
     apply:JMeq_from_eq.
     f_equal.
     * apply:WC_hp.
     * apply:WTy_hp.
     * apply:WS_hp.
- destruct wx.
  + move => wx'.
    (* cette technique marche super bien !! *)
    refine (match wx' with w_vstar => _ | _ => _ end).
    all:easy.
  + move => wx'.
    apply:JMeq_eq.
    match goal with [ H : WVar ?C ?B ?X |- ?a ≅ ?b] =>
                      set (CC := C) in H;
                      set (CT := B) in H;
                      set (Ct := X) in H;
                      change (a ≅ b)
    end.
    move:(erefl CC) (erefl CT) (erefl Ct).
    rewrite {2}/CC {2}/CT {2}/Ct.
    case:wx' => //=.
    intros; subst.
    case:H ; intros ;subst.
    case:H1 ; intros ;subst.
    apply wkTy_inj in H0.
    subst.
    apply:JMeq_from_eq.
    f_equal.
    * apply:WVar_hp.
    * apply:WTm_hp.
  + move => wx'.
    apply:JMeq_eq.
    match goal with [ H : WVar ?C ?B ?X |- ?a ≅ ?b] =>
                      set (CC := C) in H;
                      set (CT := B) in H;
                      set (Ct := X) in H;
                      change (a ≅ b)
    end.
    move:(erefl CC) (erefl CT) (erefl Ct).
    rewrite {2}/CC {2}/CT {2}/Ct.
    case:wx' => //=.
    intros; subst.
    case:H ; intros ;subst.
    apply:JMeq_from_eq.
    f_equal.
    * apply:WTm_hp.
  + move => wx'.
    apply:JMeq_eq.
    match goal with [ H : WVar ?C ?B ?X |- ?a ≅ ?b] =>
                      set (CC := C) in H;
                      set (CT := B) in H;
                      set (Ct := X) in H;
                      change (a ≅ b)
    end.
    move:(erefl CC) (erefl CT) (erefl Ct).
    rewrite {2}/CC {2}/CT {2}/Ct.
    case:wx' => //=.
    intros; subst.
    case:H ; intros ;subst.
    apply:JMeq_from_eq.
    f_equal.
    * apply:WTm_hp.
- destruct wσ.
  + move => wσ'.
    apply:JMeq_eq.
    match goal with [ H : ?C ⊢ ?B ⇒ ?C2 |- ?a ≅ ?b] =>
                      set (CC := C) in H;
                      set (CS := B) in H;
                      set (CC2 := C2) in H;
                      change (a ≅ b)
    end.
    move:(erefl CC) (erefl CS) (erefl CC2).
    rewrite {2}/CC {2}/CS {2}/CC2.
    case:wσ' => //=.
    intros; subst.
    case:H0 ; intros ;subst.
    apply:JMeq_from_eq.
    f_equal.
    * apply:WTm_hp.
  + move => wσ'.
    apply:JMeq_eq.
    match goal with [ H : ?C ⊢ ?B ⇒ ?C2 |- ?a ≅ ?b] =>
                      set (CC := C) in H;
                      set (CS := B) in H;
                      set (CC2 := C2) in H;
                      change (a ≅ b)
    end.
    move:(erefl CC) (erefl CS) (erefl CC2).
    rewrite {2}/CC {2}/CS {2}/CC2.
    case:wσ' => //=.
    intros; subst.
    case:H0 ; intros ;subst.
    case:H1 ; intros ;subst.
    apply:JMeq_from_eq.
    f_equal; (apply WTm_hp || apply:WTy_hp || apply:WS_hp).
Qed.
(* TODO définir sbVcomp avant et sbTcomp après *)
Fixpoint sbTcomp  (σ δ : sub) C C' Γ
         (wδ : C ⊢ δ ⇒ C')
               (wσ : C' ⊢ σ ⇒ Γ)
               (A :Ty)
         (wA : Γ ⊢ A)
  :
  A.[σ]T.[δ]T = A.[σ ∘ δ]T
with sbTmcomp  (σ δ : sub) C C' Γ
               (wδ : C ⊢ δ ⇒ C')
               (wσ : C' ⊢ σ ⇒ Γ)
               A (t :Tm)
               (wt : Γ ⊢ t : A)
     :
       t.[σ]t.[δ]t = t.[σ ∘ δ]t
with sbVcomp  (σ δ : sub) C C' Γ
               (wδ : C ⊢ δ ⇒ C')
               (wσ : C' ⊢ σ ⇒ Γ)
               A (x :Var)
              (wx : WVar Γ A x)
     : x.[σ]V.[δ]t = x.[σ ∘ δ]V
with sbScomp  (σ δ : sub) C C' Γ
               (wδ : C ⊢ δ ⇒ C')
               (wσ : C' ⊢ σ ⇒ Γ)
              Δ (s :sub)
               (ws : Γ ⊢ s ⇒ Δ )
     : (s ∘ σ) ∘ δ = s ∘ (σ ∘ δ).
- destruct wA.
  + reflexivity.
  + cbn.
    move/sbTcomp:wA => /(_ _ _ _ _ wδ wσ) ->.
    move/sbTmcomp:w => /(_ _ _ _ _ wδ wσ ) ->.
    move/sbTmcomp:w0 => /(_ _ _ _ _ wδ wσ ) ->.
    reflexivity.
- destruct wt.
  + apply:sbVcomp; last by apply:w.
    eassumption.
    eassumption.
  + simpl.
    erewrite sbScomp => //; eassumption.
- destruct wx.
  + inversion wσ.
    reflexivity.
  + inversion wσ; subst.
    move/sbVcomp:wx => /(_ _ _ _ _ wδ).
    now apply.
  + inversion wσ.
    reflexivity.
  + inversion wσ.
    reflexivity.
- destruct ws.
  + simpl.
    move/sbTmcomp:w => /(_ _ _ _ _ wδ wσ ) ->.
    reflexivity.
  + simpl.
    f_equal.
    * apply:sbScomp; eassumption.
    * apply:sbTmcomp; eassumption.
    * apply:sbTmcomp; eassumption.
Qed.

Lemma wkt_ext  σ t f u : (wkt u).[to_ext σ t f]t = u.[σ]t
with wkS_ext  σ t f δ : (wkS δ) ∘ (to_ext σ t f) = δ∘σ.
  - destruct u.
    + reflexivity.
    + simpl.
      rewrite wkS_ext.
      reflexivity.
  - destruct δ.
    + simpl.
      rewrite wkt_ext.
      reflexivity.
    + simpl.
      f_equal.
      * apply: wkS_ext.
      * apply: wkt_ext.
      * apply: wkt_ext.
Qed.

Lemma wkT_ext σ t f B : (wkT B).[to_ext σ t f]T = B.[σ]T.
  induction B => //=.
  now rewrite IHB !wkt_ext .
Qed.

  Fixpoint wkV_wkS Γ Δ σ  B (x : Var)
        (wσ : Γ ⊢ σ ⇒ Δ)
        (wx : WVar Δ B x)  : wkt (x .[σ]V) = x.[wkS σ]V.
  destruct wx.
  + inversion wσ; subst.
    reflexivity.
  + inversion wσ; subst.
    simpl.
    apply:wkV_wkS; eassumption.
  + by inversion wσ; subst.
  + by inversion wσ; subst.
  Qed.

  Fixpoint wkt_wkS Γ Δ σ  B (t : Tm)
        (wσ : Γ ⊢ σ ⇒ Δ)
        (wt : Δ ⊢ t : B)  : wkt (t .[σ]t) = t.[wkS σ]t
    with wkS_wkS Γ Δ σ E δ
        (wσ : Γ ⊢ σ ⇒ Δ)
        (wδ : Δ ⊢ δ ⇒ E)
        : (wkS (δ ∘ σ)) = δ ∘ (wkS σ).
  - destruct wt.
    + apply:wkV_wkS; eassumption.
    + simpl.
      erewrite wkS_wkS ; reflexivity ||  eassumption.
  - destruct wδ.
    + simpl.
      erewrite wkt_wkS ; reflexivity ||  eassumption.
    + simpl.
      erewrite wkS_wkS.
      erewrite wkt_wkS.
      erewrite wkt_wkS.
      reflexivity.
      all:eassumption.
  Qed.
  Fixpoint wkT_wkS Γ Δ σ  B
        (wσ : Γ ⊢ σ ⇒ Δ)
        (wB : Δ ⊢ B)  : wkT (B .[σ]T) = B.[wkS σ]T.
    destruct wB.
    - reflexivity.
    - simpl.
      erewrite wkT_wkS.
      erewrite wkt_wkS.
      erewrite wkt_wkS.
      reflexivity.
      all:eassumption.
  Qed.

Lemma WVar_wk
      (Γ  : Con)(A: Ty) (u : Tm)
      (wu : Γ ⊢ u : A)
      (B : Ty)(x : Var) (wx : WVar Γ B x) :
  WVar (ext Γ A u) (wkT B) (vwk x).

  move:A u wu.
  induction wx.
  + move => A u wu.
    apply:w_vwk.
    repeat constructor.
    assumption.
  + move => A' u' wu'.
    apply:w_vwk => //.
    by apply:IHwx.
  + move => A' u' wu'.
    apply:w_vwk => //.
    by constructor.
  + move => A' u' wu'.
    apply:w_vwk => //.
    by constructor.
Qed.
Lemma WTm_wk
      (Γ  : Con)(A: Ty) (u : Tm)
      (wu : Γ ⊢ u : A)
      (B : Ty)(t : Tm) (wt : Γ ⊢ t : B) :
   (ext Γ A u) ⊢ wkt t : (wkT B)
  with WS_wk
         (Γ  : Con)(A: Ty) (u : Tm)
         (wu : Γ ⊢ u : A)
         Δ σ (wσ : Γ ⊢ σ ⇒ Δ) : ext Γ A u ⊢ wkS σ ⇒ Δ.

  - move:A u wu.
  induction wt.
  + move => A' u' wu'.
    constructor.
    now apply:WVar_wk.
  + move => A' u' wu'.
    simpl.
    erewrite wkT_wkS; try eassumption.
    constructor => //=.
    by apply:WS_wk.
  - destruct wσ.
    + simpl.
      constructor.
      change star with (wkT star).
      by apply:WTm_wk.
    + simpl.
      constructor; try assumption.
      * by apply:WS_wk.
      * erewrite <- wkT_wkS; try eassumption.
          by apply:WTm_wk.
      * erewrite <- wkT_wkS; try eassumption.
        erewrite <- wkt_wkS; try eassumption.
        move/WTm_wk:(wu) => I.
        by move/I:w2.
Qed.

Fixpoint WTy_wk
      (Γ  : Con)(A: Ty) (u : Tm)
      (wu : Γ ⊢ u : A)
      (wA : Γ ⊢ A)
      (B : Ty) (wB : Γ ⊢ B) :
   (ext Γ A u) ⊢  (wkT B).
  destruct wB.
  - constructor.
    constructor => //.
  - simpl.
    constructor.
    + apply:WTy_wk => //.
    + apply:WTm_wk => //.
    + apply:WTm_wk => //.
Qed.

(* with WS_wk *)
Lemma WVar_sb
         (Γ Δ : Con)(σ : sub)(A : Ty)(x : Var)
         (wΓ : WC Γ) (wΔ : WC Δ)
         (wσ : Γ ⊢ σ ⇒ Δ) (wx : WVar Δ A x) :  Γ ⊢ (x.[σ]V) : (A.[σ]T)   .
  move : wx σ    wσ  wΓ wΔ.
  induction 1.
  + now inversion 1.
  + inversion 1.
    subst.
    rewrite wkT_ext.
    simpl.
    intros.
    apply:IHwx => //.
    now inversion wΔ.
  + inversion 1; subst=> //.
    now rewrite wkT_ext.
  + inversion 1; subst=> //.
    simpl.
    now rewrite wkT_ext wkt_ext.
Defined.
Lemma
  Wtm_sb
         (Γ Δ : Con)(σ : sub)(A : Ty)(t : Tm)
         (wΓ : WC Γ) (wΔ : WC Δ)
         (wσ : Γ ⊢ σ ⇒ Δ) (wt : Δ ⊢ t : A) : Γ ⊢ t.[σ]t : A.[σ]T
with WS_sb
         (Γ Δ : Con)(σ : sub)(E : Con)(δ : sub)
         (wΓ : WC Γ) (wΔ : WC Δ)
         (wσ : Γ ⊢ σ ⇒ Δ) (wδ : Δ ⊢ δ ⇒ E) : Γ ⊢ δ ∘ σ ⇒ E.
- destruct wt.
  + move/WVar_sb:w.
    apply => //.
  + simpl.
    erewrite sbTcomp; try eassumption.
    {
    constructor ; try eassumption.
    apply:WS_sb; last first; eassumption.
    }
- destruct wδ.
  + simpl.
    constructor.
    apply:(Wtm_sb _ _ σ star); last first; eassumption.
  + simpl.
    constructor.
    * apply:WS_sb; last first; eassumption.
    * assumption.
    * assumption.
    * erewrite <- sbTcomp; try eassumption.
      {
         apply:Wtm_sb; last first; eassumption.
      }
    * erewrite <- sbTcomp; try eassumption.
      erewrite <- sbTmcomp; try eassumption.
      move/Wtm_sb:w2.
      apply ; assumption.
Defined.

Lemma WTy_sb
         (Γ Δ : Con)(σ : sub)(A : Ty)
         (wΓ : WC Γ) (wΔ : WC Δ)
         (wσ : Γ ⊢ σ ⇒ Δ) (wA : Δ ⊢ A): Γ ⊢ A.[σ]T.
 induction wA.
  + constructor => //.
  + cbn.
    constructor.
    * apply:IHwA => //.
    * apply:Wtm_sb => //;[| eassumption |] => // .
    * apply:Wtm_sb => //;[| eassumption |] => // .
Defined.

(* Notation "Gamma ⊢ A" := (WTy Gamma A)  . *)
(* Notation "Gamma ⊢ s : A" := (Wtm Gamma A s). *)
(* Notation "Gamma ⊢  s  ⇒ Delta" := (WS Gamma Delta s). *)

Fixpoint WVar_Ty Γ A x (wΓ : WC Γ) (wx : WVar Γ A x):  Γ ⊢ A
with WTm_Ty Γ A t (wΓ:WC Γ)  (wt : Γ ⊢ t : A) : Γ ⊢ A.
-  destruct wx.
  + repeat constructor.
  + apply:WTy_wk => //.
    * apply:WTm_Ty.
      -- now inversion wΓ.
      -- eassumption.
    * apply:WVar_Ty.
      -- now inversion wΓ.
      -- eassumption.
  + assert ( wA : (Γ ⊢ A)).
    {
     apply:WTm_Ty.
      -- now inversion wΓ.
      -- eassumption.
    }

    apply:WTy_wk => //.
  + assert ( wA : Γ ⊢ A).
    {
     apply:WTm_Ty.
      -- now inversion wΓ.
      -- eassumption.
    }

    constructor.
    * apply:WTy_wk => //.
    * repeat constructor => //.
    * apply:WTm_wk => //.
- destruct wt.
  + apply:WVar_Ty; eassumption.
  + apply:WTy_sb; last first; eassumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleMul.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w -> zn2z w.
 Variable w_0W : w -> zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable w_succ : w -> w.
 Variable w_add_c : w -> w -> carry w.
 Variable w_add : w -> w -> w.
 Variable w_sub: w -> w -> w.
 Variable w_mul_c : w -> w -> zn2z w.
 Variable w_mul : w -> w -> w.
 Variable w_square_c : w -> zn2z w.
 Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w).
 Variable ww_add   : zn2z w -> zn2z w -> zn2z w.
 Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w.
 Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w).
 Variable ww_sub   : zn2z w -> zn2z w -> zn2z w.

 (* ** Multiplication ** *)

 (*   (xh*B+xl) (yh*B + yl)
   xh*yh         = hh  = |hhh|hhl|B2
   xh*yl +xl*yh  = cc  =     |cch|ccl|B
   xl*yl         = ll  =         |llh|lll
  *)

 Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y :=
  match x, y with
  | W0, _ => W0
  | _, W0 => W0
  | WW xh xl, WW yh yl =>
    let hh := w_mul_c xh yh in
    let ll := w_mul_c xl yl in
    let (wc,cc) := cross xh xl yh yl hh ll in
    match cc with
    | W0 => WW (ww_add hh (w_W0 wc)) ll
    | WW cch ccl =>
      match ww_add_c (w_W0 ccl) ll with
      | C0 l => WW (ww_add hh (w_WW wc cch)) l
      | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
      end
    end
  end.

 Definition ww_mul_c :=
  double_mul_c
    (fun xh xl yh yl hh ll=>
      match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with
      | C0 cc => (w_0, cc)
      | C1 cc => (w_1, cc)
      end).

 Definition w_2 := w_add w_1 w_1.

 Definition kara_prod xh xl yh yl hh ll :=
    match ww_add_c hh ll with
      C0 m =>
         match w_compare xl xh with
           Eq => (w_0, m)
         | Lt =>
           match w_compare yl yh with
             Eq => (w_0, m)
           | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl)))
           | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with
                      C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1)
                   end
           end
         | Gt =>
           match w_compare yl yh with
             Eq => (w_0, m)
           | Lt => match ww_add_c m (w_mul_c (w_sub xl xh)  (w_sub yh yl)) with
                      C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1)
                   end
           | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh)  (w_sub yl yh)))
           end
         end
    | C1 m =>
         match w_compare xl xh with
           Eq => (w_1, m)
         | Lt =>
           match w_compare yl yh with
             Eq => (w_1, m)
           | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with
                    C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1)
                   end
           | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with
                      C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1)
                   end
           end
         | Gt =>
           match w_compare yl yh with
             Eq => (w_1, m)
           | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with
                      C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1)
                   end
           | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with
                     C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1)
                   end
           end
         end
    end.

 Definition ww_karatsuba_c :=  double_mul_c kara_prod.

 Definition ww_mul x y :=
  match x, y with
  | W0, _ => W0
  | _, W0 => W0
  | WW xh xl, WW yh yl =>
    let ccl := w_add (w_mul xh yl) (w_mul xl yh) in
    ww_add (w_W0 ccl) (w_mul_c xl yl)
  end.

 Definition ww_square_c x  :=
  match x with
  | W0 => W0
  | WW xh xl =>
    let hh := w_square_c xh in
    let ll := w_square_c xl in
    let xhxl := w_mul_c xh xl in
    let (wc,cc) :=
      match ww_add_c xhxl xhxl with
      | C0 cc => (w_0, cc)
      | C1 cc => (w_1, cc)
      end in
    match cc with
    | W0 => WW (ww_add hh (w_W0 wc)) ll
    | WW cch ccl =>
      match ww_add_c (w_W0 ccl) ll with
      | C0 l => WW (ww_add hh (w_WW wc cch)) l
      | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
      end
    end
  end.

 Section DoubleMulAddn1.
  Variable w_mul_add : w -> w -> w -> w * w.

  Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n :=
   match n return word w n -> w -> w -> w * word w n with
   | O => w_mul_add
   | S n1 =>
     let mul_add := double_mul_add_n1 n1 in
     fun x y r =>
     match x with
     | W0 => (w_0,extend w_0W n1 r)
     | WW xh xl =>
       let (rl,l) := mul_add xl y r in
       let (rh,h) := mul_add xh y rl in
       (rh, double_WW w_WW n1 h l)
     end
   end.

 End DoubleMulAddn1.

 Section DoubleMulAddmn1.
  Variable wn: Type.
  Variable extend_n : w -> wn.
  Variable wn_0W : wn -> zn2z wn.
  Variable wn_WW : wn -> wn -> zn2z wn.
  Variable w_mul_add_n1 : wn -> w -> w -> w*wn.
  Fixpoint double_mul_add_mn1 (m:nat) :
	word wn m -> w -> w -> w*word wn m :=
   match m return word wn m -> w -> w -> w*word wn m with
   | O => w_mul_add_n1
   | S m1 =>
     let mul_add := double_mul_add_mn1 m1 in
     fun x y r =>
     match x with
     | W0 => (w_0,extend wn_0W m1 (extend_n r))
     | WW xh xl =>
       let (rl,l) := mul_add xl y r in
       let (rh,h) := mul_add xh y rl in
       (rh, double_WW wn_WW m1 h l)
     end
   end.

 End DoubleMulAddmn1.

 Definition w_mul_add x y r :=
  match w_mul_c x y with
  | W0 => (w_0, r)
  | WW h l =>
    match w_add_c l r with
    | C0 lr => (h,lr)
    | C1 lr => (w_succ h, lr)
    end
  end.

 (*Section DoubleProof. *)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, x at level 99).

  Notation "[|| x ||]" :=
    (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x)  (at level 0, x at level 99).

  Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x)
    (at level 0, x at level 99).

  Variable spec_more_than_1_digit: 1 < Zpos w_digits.
  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_1   : [|w_1|] = 1.

  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.

  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_w_compare :
     forall x y, w_compare x y = Zcompare [|x|] [|y|].
  Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB.
  Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
  Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
  Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB.

  Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|].
  Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB.
  Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|].

  Variable spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
  Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB.
  Variable spec_ww_add_carry :
	 forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB.
  Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
  Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]].

  Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB.
  Proof. intros x;apply spec_ww_to_Z;auto. Qed.

  Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2.
  Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed.

  Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult.
  Ltac zarith := auto with zarith mult.

  Lemma wBwB_lex: forall a b c d,
      a * wB^2 + [[b]] <= c * wB^2 + [[d]] ->
      a <= c.
  Proof.
   intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith.
  Qed.

  Lemma wBwB_lex_inv: forall a b c d,
      a < c ->
      a * wB^2 + [[b]] < c * wB^2 + [[d]].
  Proof.
   intros a b c d H; apply beta_lex_inv; zarith.
  Qed.

  Lemma sum_mul_carry : forall xh xl yh yl wc cc,
   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] ->
   0 <= [|wc|] <= 1.
  Proof.
   intros.
   apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith.
   apply wB_pos.
  Qed.

  Theorem mult_add_ineq: forall xH yH crossH,
               0 <= [|xH|] * [|yH|] + [|crossH|] < wwB.
  Proof.
   intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith.
  Qed.

  Hint Resolve mult_add_ineq : mult.

  Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll,
   [[hh]] = [|xh|] * [|yh|] ->
   [[ll]] = [|xl|] * [|yl|] ->
   [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] ->
    [||match cc with
      | W0 => WW (ww_add hh (w_W0 wc)) ll
      | WW cch ccl =>
          match ww_add_c (w_W0 ccl) ll with
          | C0 l => WW (ww_add hh (w_WW wc cch)) l
          | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l
          end
      end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]).
  Proof.
   intros;assert (U1 := wB_pos w_digits).
   replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with
   ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]).
   2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0.
   assert (H2 := sum_mul_carry _ _ _ _ _ _ H1).
   destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z.
   rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small;
    rewrite wwB_wBwB. ring.
   rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith.
   simpl ww_to_Z in H1. assert (U:=spec_to_Z cch).
   assert ([|wc|]*wB + [|cch|] <= 2*wB - 3).
    destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial.
    assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2).
     ring_simplify ((2*wB - 4)*wB + 2).
     assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)).
     assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
     omega.
   generalize H3;clear H3;rewrite <- H1.
   rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc;
     rewrite <- Zmult_plus_distr_l.
    assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB).
     apply Zmult_le_compat;zarith.
    rewrite Zmult_plus_distr_l in H3.
    intros. assert (U2 := spec_to_Z ccl);omega.
   generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll)
   as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l;
   simpl zn2z_to_Z;
   try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW;
   rewrite Zmod_small;rewrite wwB_wBwB;intros.
   rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith.
   rewrite Zplus_assoc;rewrite Zmult_plus_distr_l.
   rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring.
   repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith.
  Qed.

  Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w,
     (forall xh xl yh yl hh ll,
        [[hh]] = [|xh|]*[|yh|] ->
        [[ll]] = [|xl|]*[|yl|] ->
        let (wc,cc) :=  cross xh xl yh yl hh ll in
        [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) ->
     forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]].
  Proof.
   intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial.
   destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial.
   assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl).
   generalize (Hcross _ _ _ _ _ _ H1 H2).
   destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc).
   intros;apply spec_mul_aux;trivial.
   rewrite <- wwB_wBwB;trivial.
  Qed.

  Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]].
  Proof.
   intros x y;unfold ww_mul_c;apply spec_double_mul_c.
   intros xh xl yh yl hh ll H1 H2.
   generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh));
   destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c];
   unfold interp_carry;repeat rewrite spec_w_mul_c;intros H;
   (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring.
  Qed.

  Lemma spec_w_2: [|w_2|] = 2.
  unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl.
  apply Zmod_small; split; auto with zarith.
  rewrite <- (Zpower_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith.
  Qed.

  Lemma kara_prod_aux : forall xh xl yh yl,
   xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh.
  Proof. intros;ring. Qed.

  Lemma spec_kara_prod : forall xh xl yh yl hh ll,
   [[hh]] = [|xh|]*[|yh|] ->
   [[ll]] = [|xl|]*[|yl|] ->
   let (wc,cc) := kara_prod xh xl yh yl hh ll in
   [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|].
  Proof.
   intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux;
     rewrite <- H; rewrite <- H0; unfold kara_prod.
   assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl));
     assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)).
   generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll);
     intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)).
   rewrite spec_w_compare; case Zcompare_spec; intros Hxlh;
    try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail).
   rewrite spec_w_compare; case Zcompare_spec; intros Hylh.
   rewrite Hylh; rewrite spec_w_0; try (ring; fail).
   rewrite spec_w_0; try (ring; fail).
   repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   split; auto with zarith.
   simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
   apply Zmult_le_0_compat; auto with zarith.
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2;
     repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_compare; case Zcompare_spec; intros Hylh.
   rewrite Hylh; rewrite spec_w_0; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2;
     repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; try (ring; fail).
   repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   split.
   match goal with |- context[(?x - ?y) * (?z - ?t)] =>
     replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
   end.
   simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
   apply Zmult_le_0_compat; auto with zarith.
   (** there is a carry in hh + ll **)
   rewrite Zmult_1_l.
   rewrite spec_w_compare; case Zcompare_spec; intros Hxlh;
    try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail).
   rewrite spec_w_compare; case Zcompare_spec; intros Hylh;
     try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
   match goal with |- context[ww_sub_c ?x ?y] =>
     generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
   generalize Hz2; clear Hz2; unfold interp_carry.
   repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_2; unfold interp_carry in Hz2.
   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
   ring.
   rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_compare; case Zcompare_spec; intros Hylh;
     try rewrite Hylh; try rewrite spec_w_1; try (ring; fail).
   match goal with |- context[ww_add_c ?x ?y] =>
     generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_2; unfold interp_carry in Hz2.
   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
   ring.
   rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   match goal with |- context[ww_sub_c ?x ?y] =>
     generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1;
     intros z1 Hz2
   end.
   simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
   match goal with |- context[(?x - ?y) * (?z - ?t)] =>
     replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
   end.
   generalize Hz2; clear Hz2; unfold interp_carry.
   repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
   repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
  Qed.

  Lemma sub_carry : forall xh xl yh yl z,
    0 <= z ->
    [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z ->
    z < wwB.
  Proof.
   intros xh xl yh yl z Hle Heq.
   destruct (Z_le_gt_dec wwB z);auto with zarith.
   generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)).
   generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
   rewrite <- wwB_wBwB;intros H1 H2.
   assert (H3 := wB_pos w_digits).
   assert (2*wB <= wwB).
    rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith.
   omega.
  Qed.

  Ltac Spec_ww_to_Z x :=
   let H:= fresh "H" in
   assert (H:= spec_ww_to_Z x).

  Ltac Zmult_lt_b x y :=
   let H := fresh "H" in
   assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).

  Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]].
  Proof.
   intros x y; unfold ww_karatsuba_c;apply spec_double_mul_c.
   intros; apply spec_kara_prod; auto.
  Qed.

  Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB.
  Proof.
   assert (U:= lt_0_wB w_digits).
   assert (U1:= lt_0_wwB w_digits).
   intros x y; case x; auto; intros xh xl.
   case y; auto.
   simpl; rewrite Zmult_0_r; rewrite Zmod_small; auto with zarith.
   intros yh yl;simpl.
   repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c
    || rewrite spec_w_add || rewrite spec_w_mul).
   rewrite <- Zplus_mod; auto with zarith.
   repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r).
   rewrite <- Zmult_mod_distr_r; auto with zarith.
   rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith.
   rewrite Zplus_mod; auto with zarith.
   rewrite Zmod_mod; auto with zarith.
   rewrite <- Zplus_mod; auto with zarith.
   match goal with |- ?X mod _ = _ =>
     rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|])
   end; auto with zarith.
   f_equal; auto; rewrite wwB_wBwB; ring.
  Qed.

  Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]].
  Proof.
   destruct x as [ |xh xl];simpl;trivial.
   case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with
          | C0 cc => (w_0, cc)
          | C1 cc => (w_1, cc)
          end;intros wc cc Heq.
   apply (spec_mul_aux xh xl xh xl wc cc);trivial.
   generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq.
   rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));
   unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq;
   rewrite (Zmult_comm [|xl|]);subst.
   rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial.
   rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial.
  Qed.

  Section DoubleMulAddn1Proof.

   Variable w_mul_add : w -> w -> w -> w * w.
   Variable spec_w_mul_add : forall x y r,
    let (h,l):= w_mul_add x y r in
    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].

   Lemma spec_double_mul_add_n1 : forall n x y r,
     let (h,l) := double_mul_add_n1 w_mul_add n x y r in
     [|h|]*double_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|].
   Proof.
    induction n;intros x y r;trivial.
    exact (spec_w_mul_add x y r).
    unfold double_mul_add_n1;destruct x as[ |xh xl];
     fold(double_mul_add_n1 w_mul_add).
    rewrite spec_w_0;rewrite spec_extend;simpl;trivial.
    assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l).
   assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h).
    rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial.
    rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H.
    rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
    rewrite U;ring.
   Qed.

  End DoubleMulAddn1Proof.

  Lemma spec_w_mul_add : forall x y r,
    let (h,l):= w_mul_add x y r in
    [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|].
  Proof.
   intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y);
   destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H.
   rewrite spec_w_0;trivial.
   assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold
   interp_carry in U;try rewrite Zmult_1_l in H;simpl.
   rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small.
   rewrite <- Zplus_assoc;rewrite <- U;ring.
   simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).
   rewrite <- H in H1.
   assert (H2:=spec_to_Z h);split;zarith.
   case H1;clear H1;intro H1;clear H1.
   replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring.
   intros H0;assert (U1:= wB_pos w_digits).
   assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith.
  Qed.

(* End DoubleProof. *)

End DoubleMul.