Require Import Reals Psatz Omega.
From iris.program_logic Require Export weakestpre prob_adequacy.
From iris.base_logic.lib Require Export invariants.
From iris.heap_lang Require Export lang adequacy.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac_auth auth.
From iris.heap_lang Require Import proofmode notation par.
From mathcomp Require Import seq fintype.

Section COUNTER.
Variable MAX : nat.

Definition newcounter : val := λ: <>, ref #0.
Definition min : val :=
  λ: "x" "y", if: "x" < "y" then "x" else "y".
Definition incr : val := λ: "l",
    let: "n" := min !"l" #MAX in
    let: "b" := flip #1 ("n" + #1)  in
    if: "b" then
      FAA "l" ("n" + #1);; #()
    else
      #().

Definition read : val := λ: "l", !"l".

From discprob.idxval Require Import pival
     pival_dist ival_dist irrel_equiv idist_pidist_pair extrema pidist_post_cond.

Local Open Scope R_scope.

Lemma INRp1_prob n:
  0 <= 1 / (INR n + 1) <= 1.
Proof.
  split.
  - specialize (RinvN_pos n). intros; nra.
  - replace 1 with (1 / 1) at 3; auto; last nra.
    apply Reals_ext.Rdiv_le_compat_contra; try nra.
    specialize (pos_INR n). nra.
Qed.

From discprob.basic Require Import monad.
Opaque mret.
Opaque mbind.

(* On paper we just write this as (mret 0) U ... U (mret n). *)
Definition select_upto (n: nat) : pidist nat :=
  fold_left pidist_union (map mret (iota 1 n)) (mret O).

Definition flip_incr (n: nat) : pidist nat :=
  pidist_plus (1/(INR n + 1)) (INRp1_prob n) (mret (S n)) (mret O).

Definition approx_incr : pidist nat :=
  k ← select_upto MAX;
  flip_incr k.

Fixpoint approx_n (n: nat) (l: nat) : pidist nat :=
  match n with
  | O => mret l
  | S n' =>
    x ← approx_incr;
    approx_n n' (l + x)
  end.

Lemma select_upto_spec1 curr:
  pspec (select_upto curr) (λ x, x  <= curr)%nat.
Proof.
  rewrite /approx_incr/select_upto.
  eapply (pspec_conseq _ (λ x, x <= curr + 0)%nat); last by (intros; omega).
  generalize O.
  induction curr => //= n.
  * apply pspec_mret. omega.
  * rewrite -pidist_union_foldleft_hd.
    apply pspec_union.
    ** apply pspec_mret; auto. omega.
    ** eapply pspec_conseq; first eapply IHcurr.
       rewrite //=. intros a Hle. omega.
Qed.

Lemma approx_incr_bounded:
  pspec (approx_incr) (λ x : nat, Rabs (INR x) <= INR (S MAX)).
Proof.
  eapply (pspec_mbind _ _ (λ x, x <= MAX)%nat); first eapply select_upto_spec1.
  intros a Hle. rewrite /flip_incr.
  apply pspec_pidist_plus.
  * apply pspec_mret. rewrite Rabs_right.
    ** apply le_INR. omega.
    ** apply Rle_ge, pos_INR.
  * apply pspec_mret. rewrite S_INR //= Rabs_R0.
    specialize (pos_INR MAX); nra.
Qed.

Fixpoint approx_n_bound n curr :=
  match n with
  | O => curr
  | S n' =>
    approx_n_bound n' (curr + S MAX)%nat
  end.

Lemma approx_n_bounded_mono n curr curr':
  (curr <= curr')%nat →
  (approx_n_bound n curr <= approx_n_bound n curr')%nat.
Proof.
  revert curr curr'.
  induction n => //=.
  intros curr curr' Hle.
  eapply IHn. omega.
Qed.

Lemma approx_n_bounded n curr:
  pspec (approx_n n curr) (λ x : nat, Rabs (INR x) <= INR (approx_n_bound n curr)).
Proof.
  revert curr.
  induction n => curr.
  - apply pspec_mret => //=. rewrite Rabs_right; last apply Rle_ge, pos_INR.
    reflexivity.
  - rewrite /=.
    eapply pspec_mbind; first eapply approx_incr_bounded.
    intros a. rewrite S_INR => Hle.
    eapply pspec_conseq; first eapply IHn => //=.
    intros k => //=.
    intros. etransitivity; first eassumption. apply le_INR.
    apply approx_n_bounded_mono.
    rewrite Rabs_right in Hle; last apply Rle_ge, pos_INR.
    rewrite -S_INR in Hle. apply INR_le in Hle. omega.
Qed.

Import Rbar.

Lemma Ex_min_approx_incr:
  Ex_min INR (approx_incr) = Finite 1.
Proof.
  rewrite /approx_incr.
  apply Ex_min_bind_const.
  { apply ex_Ex_extrema_bounded_supp_fun.
    eapply pspec_bounded. exists (INR (S MAX)).
    apply approx_incr_bounded.
  }
  intros k. rewrite /flip_incr.
  rewrite ?Ex_min_pidist_plus ?Ex_min_mret // ?(S_INR) //=.
  * rewrite //= Rmult_0_r Rplus_0_r.
    specialize (INRp1_prob k); intros (?&?).
    specialize (Rcomplements.INRp1_pos k). intros.
    f_equal. field. nra.
  * apply ex_Ex_extrema_pidist_plus; apply ex_Ex_extrema_mret.
Qed.

Lemma Ex_min_approx_n (n: nat) l:
  Ex_min INR (approx_n n l) =
  Finite (INR (n + l)).
Proof.
  revert l.
  induction n => l.
  - rewrite //=. rewrite Ex_min_mret. done.
  - transitivity (Ex_min (λ x : nat, INR (n + l) + INR x) (approx_incr)).
    { rewrite Ex_min_bind_post -/approx_n.
      * apply Ex_min_eq_ext.
        intros n'. rewrite IHn.
        rewrite ?plus_INR //=.
        nra.
      * apply Ex_min_bounded_supp_fun_finite.
        apply pspec_bounded.
        eexists (INR (n + l + MAX + 1)). eapply pspec_conseq; first eapply approx_incr_bounded.
        intros a Hle.
        rewrite IHn. rewrite ?Rabs_right in Hle *; try apply Rle_ge, pos_INR.
        apply le_INR. apply INR_le in Hle. omega.
      * intros. rewrite IHn => //=.
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (approx_n_bound (S n) l)).
        eapply (approx_n_bounded (S n) l).
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (n + l + (MAX  + 1))).
        eapply pspec_conseq; first eapply approx_incr_bounded.
        intros k Hb. rewrite IHn.
        rewrite Rabs_right; last by apply Rle_ge, pos_INR.
        apply le_INR.
        rewrite Rabs_right in Hb; last by apply Rle_ge, pos_INR.
        apply INR_le in Hb. omega.
    }
    rewrite Ex_min_plus_const_l.
    rewrite ?plus_INR. rewrite S_INR.
    rewrite Ex_min_approx_incr.
    rewrite //=. f_equal.
    nra.
Qed.

Lemma Ex_max_approx_incr :
  Ex_max INR (approx_incr) = Finite 1.
Proof.
  rewrite /approx_incr.
  apply Ex_max_bind_const.
  { apply ex_Ex_extrema_bounded_supp_fun.
    eapply pspec_bounded. exists (INR (S MAX)).
    apply approx_incr_bounded.
  }
  intros k. rewrite /flip_incr.
  rewrite ?Ex_max_pidist_plus ?Ex_max_mret // ?(S_INR) //=.
  * rewrite //= Rmult_0_r Rplus_0_r.
    specialize (INRp1_prob k); intros (?&?).
    specialize (Rcomplements.INRp1_pos k). intros.
    f_equal. field. nra.
  * apply ex_Ex_extrema_pidist_plus; apply ex_Ex_extrema_mret.
Qed.

Lemma Ex_max_approx_n (n: nat) l:
  Ex_max INR (approx_n n l) =
  Finite (INR (n + l)).
Proof.
  revert l.
  induction n => l.
  - rewrite //=. rewrite Ex_max_mret. done.
  - transitivity (Ex_max (λ x : nat, INR (n + l) + INR x) (approx_incr)).
    { rewrite Ex_max_bind_post -/approx_n.
      * apply Ex_max_eq_ext.
        intros n'. rewrite IHn.
        rewrite ?plus_INR //=.
        nra.
      * apply Ex_max_bounded_supp_fun_finite.
        apply pspec_bounded.
        eexists (INR (n + l + MAX + 1)). eapply pspec_conseq; first eapply approx_incr_bounded.
        intros a Hle.
        rewrite IHn. rewrite ?Rabs_right in Hle *; try apply Rle_ge, pos_INR.
        apply le_INR. apply INR_le in Hle. omega.
      * intros. rewrite IHn => //=.
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (approx_n_bound (S n) l)).
        eapply (approx_n_bounded (S n) l).
      * apply ex_Ex_extrema_bounded_supp_fun.
        eapply pspec_bounded. exists (INR (n + l + (MAX  + 1))).
        eapply pspec_conseq; first eapply approx_incr_bounded.
        intros k Hb. rewrite IHn.
        rewrite Rabs_right; last by apply Rle_ge, pos_INR.
        apply le_INR.
        rewrite Rabs_right in Hb; last by apply Rle_ge, pos_INR.
        apply INR_le in Hb. omega.
    }
    rewrite Ex_max_plus_const_l.
    rewrite ?plus_INR. rewrite S_INR.
    rewrite Ex_max_approx_incr.
    rewrite //=. f_equal.
    nra.
Qed.

Class acounterG Σ :=
  ACounterG { acounter_inG :> inG Σ (frac_authR natR) }.
Definition acounterΣ : gFunctors := #[GFunctor (frac_authR natR)].
Instance subG_acounterΣ {Σ} : subG acounterΣ Σ → acounterG Σ.
Proof. solve_inG. Qed.

Section proof.
Context `{!heapG Σ, !probG Σ, !acounterG Σ, !spawnG Σ}.

Lemma min_spec E (z1 z2: Z):
  {{{ True }}}
    min #z1 #z2 @ E
  {{{ RET LitV (LitInt (Zmin z1 z2)) ; True }}}.
Proof.
  iIntros (Φ) "_ HΦ".
  iIntros. wp_let. wp_let.
  wp_op; case_bool_decide.
  * wp_if.
    rewrite Z.min_l; last by omega.
    by iApply "HΦ".
  * wp_if.
    rewrite Z.min_r; last by omega.
    by iApply "HΦ".
Qed.

(* See the "counter with contribution" example in the "counter.v" file of the heap_lang lib *)

(* We first prove an "unbundled" form of the spec, where the invariants are
     separated from the acounter permission. Then, we use these triples to prove
     a bundled spec matching the one given in the paper *)

Definition acounter_loc_inv (γl : gname) (l : loc) : iProp Σ :=
    (∃ n, own γl (●! n) ∗ l ↦ #n)%I.

Definition acounter_prob_inv (γp γv : gname): iProp Σ :=
    (∃ n1 n2, own γp (●! n1) ∗ own γv (●! n2) ∗ (own γp (◯! n1) ∨ ownProb (approx_n n1 n2)))%I.

Definition acounter (γl γp γv : gname) (q : frac) (nperm : nat) (ncontrib : nat) : iProp Σ :=
    (own γp (◯!{q} nperm) ∗ own γl (◯!{q} ncontrib) ∗ own γv (◯!{q} ncontrib))%I.

Lemma acounter_sep γl γp γv q1 q2 np1 np2 nc1 nc2 :
  acounter γl γp γv (q1 + q2) (np1 + np2) (nc1 + nc2) ⊢
           acounter γl γp γv q1 np1 nc1 ∗ acounter γl γp γv q2 np2 nc2.
Proof.
  rewrite /acounter.
  iStartProof.
  * iIntros "(Hown1&Hown2&Hown3)".
    rewrite ?frag_auth_op -?own_op.
    iDestruct "Hown1" as "(?&?)".
    iDestruct "Hown2" as "(?&?)".
    iDestruct "Hown3" as "(?&?)".
    iFrame.
Qed.

Lemma acounter_join γl γp γv q1 q2 np1 np2 nc1 nc2 :
  acounter γl γp γv q1 np1 nc1 ∗ acounter γl γp γv q2 np2 nc2 ⊢
           acounter γl γp γv (q1 + q2) (np1 + np2) (nc1 + nc2).
Proof.
  rewrite /acounter.
  iStartProof.
  * iIntros "((Hown1a&Hown2a&Hown3a)&(Hown1b&Hown2b&Hown3b))".
    iCombine "Hown1a" "Hown1b" as "Hown1".
    iCombine "Hown2a" "Hown2b" as "Hown2".
    iCombine "Hown3a" "Hown3b" as "Hown3".
    iFrame.
Qed.

Lemma incr_spec N1 N2 γl γp γv l q np nc:
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv q (S np) nc }}}
    incr (Lit $ LitLoc l)
  {{{ RET LitV LitUnit; ∃ nc' : nat, acounter γl γp γv q np nc' }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iDestruct "Hpre" as "(#Hinv1&#Hinv2&(Hγp&Hγl&Hγv))".
  rewrite /incr.
  wp_let. wp_bind (! _)%E.
  iInv N1 as (c) ">[Hγl' Hl]" "Hclose".
  wp_load.
  iMod ("Hclose" with "[Hγl' Hl]") as "_".
  { iNext; iExists c; by iFrame. }

  iModIntro.
  wp_apply min_spec; first done; iIntros "_".
  wp_let.

  wp_op.
  wp_bind (flip _ _).
  iInv N2 as (np_global nv_global) ">(Hγp'&Hγv'&Hprob)" "Hclose".
  iDestruct "Hprob" as "[Hbad|Hprob]".
  { iDestruct (own_valid_2 with "Hbad Hγp") as %?%frac_auth_frag_valid_op_1_l; done. }

  iDestruct (own_valid_2 with "Hγp' Hγp") as % ?%frac_auth_included_total%nat_included.
  destruct np_global as [|np_global]; first by omega.
  rewrite //=.

  assert (0 <= IZR 1 / IZR (Z.min c MAX + 1) ∧ IZR 1 / IZR (Z.min c MAX + 1) <= 1).
  {
    rewrite //=.
    assert (IZR (Z.min c MAX + 1) = INR (Z.to_nat (Z.min c MAX) + 1)).
    rewrite INR_IZR_INZ; f_equal.
    assert (0 ≤ Z.min c MAX).
    { apply Z.min_glb; omega. }
    replace 1%nat with (Z.to_nat 1); try auto.
    rewrite -Z2Nat.inj_add; try omega.
    { rewrite Z2Nat.id => //=. etransitivity; first eauto.
      rewrite //=.  omega.
    }
    rewrite H. destruct (INRp1_prob (Z.to_nat (Z.min c MAX))).
    split; auto; etransitivity; eauto; rewrite plus_INR //=.
  }

  unshelve (wp_flip (approx_incr)
                    (λ x y, if (x : bool) then (Z.of_nat y) = (Z.min c MAX + 1)%Z
                            else Z.of_nat y = O) b z' HR); auto.
    { rewrite /approx_incr/select_upto. eapply irrel_coupling_proper.
      { reflexivity.  }
      { setoid_rewrite pidist_union_foldleft_bind. reflexivity. }
      apply ip_irrel_coupling.
      eapply (ip_coupling_union_list _ (flip_incr (Z.to_nat (Z.min c MAX)))).
      - rewrite /flip_incr.
        apply ip_coupling_plus.
        { rewrite //=.  f_equal. rewrite plus_IZR. f_equal.
          rewrite INR_IZR_INZ. f_equal.
          rewrite Z2Nat.id; auto.
          apply Z.min_glb; omega.
        }
        * apply ip_coupling_mret.
          rewrite -Z2Nat.inj_succ;
          last (apply Z.min_glb; omega).
          rewrite Z2Nat.id; auto.
          cut (0 ≤ Z.min c MAX); intros; try (apply Z.min_glb); omega.
        * apply ip_coupling_mret.
          split; auto => //=.
      - eexists. split; last first.
        { rewrite -List.map_cons.
          eapply in_map_iff.
          exists (mret (Z.to_nat (Z.min c MAX))); split.
          * reflexivity.
          * rewrite -map_cons. eapply in_map_iff.
            exists (Z.to_nat (Z.min c MAX)); split; auto.
            replace (O :: iota 1 MAX) with (iota O (S MAX - 0)); last first.
            { rewrite //=.  }
            apply Iter.In_iota; split.
            **  omega.
            ** rewrite Z2Nat.inj_min.
               etransitivity; first apply Min.le_min_r.
               rewrite //=.
               rewrite Nat2Z.id.
               reflexivity.
        }
        setoid_rewrite pidist_left_id. reflexivity.
    }
    rewrite //= in HR. (* destruct HR as (Heqz&?); subst. *)
    destruct b.
    * iMod (own_update_2 with "Hγp' Hγp") as "[Hγp' Hγp]".
      { apply frac_auth_update, (nat_local_update _ _ (np_global) (np)); omega. }
      iMod (own_update_2 with "Hγv' Hγv") as "[Hγv' Hγv]".
      { apply frac_auth_update, (nat_local_update _ _ (nv_global + z') (nc + z')); omega. }
      iMod ("Hclose" with "[Hγp' Hγv' Hprob]").
      { iNext. iExists np_global, (nv_global + z')%nat. iFrame.
        iRight. iFrame. }

      iModIntro.
      wp_let.
      wp_if.
      wp_op.
      wp_bind (FAA _ _).
      iInv N1 as (c') ">[Hγl' Hl]" "Hclose".
      wp_faa.
      iMod (own_update_2 with "Hγl' Hγl") as "[Hγl' Hγl]".
      { apply frac_auth_update, (nat_local_update _ _ (c' + z') (nc + z')); omega. }

      iMod ("Hclose" with "[Hγl' Hl]").
      { iNext. iExists (c' + z')%nat. iFrame.
        rewrite ?Nat2Z.inj_add => //=.
        rewrite HR. rewrite Zplus_comm. done.
      }

      iModIntro. wp_let.
      iApply "HΦ".
      iExists (nc + z')%nat.
      iFrame.
    * replace (nv_global + z')%nat with (nv_global); last first.
      { apply Z_of_nat_inj. rewrite Nat2Z.inj_add HR. omega. }
      iMod (own_update_2 with "Hγp' Hγp") as "[Hγp' Hγp]".
      { apply frac_auth_update, (nat_local_update _ _ (np_global) (np)); omega. }
      iMod ("Hclose" with "[Hγp' Hγv' Hprob]").
      { iNext. iExists np_global, nv_global. iFrame. iRight. iFrame. }

      iModIntro.
      wp_let.
      wp_if.

      iApply "HΦ".
      iExists nc. iFrame.
Qed.

Lemma read_spec N1 N2 γl γp γv l nc:
  N1 ## N2 →
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv 1 0 nc }}}
    read (Lit $ LitLoc l)
  {{{ (v : nat), RET LitV $ LitInt v; ownProb (mret v) }}}.
Proof.
  iIntros (Hdisjoint Φ) "Hpre HΦ".
  iDestruct "Hpre" as "(#Hinv1&#Hinv2&(Hγp&Hγl&Hγv))".
  wp_let.
  iInv N1 as (c) ">[Hγl' Hl]" "Hclose1".
  iInv N2 as (np_global nv_global) ">(Hγp'&Hγv'&Hprob)" "Hclose2".
  iDestruct "Hprob" as "[Hbad|Hprob]".
  { iDestruct (own_valid_2 with "Hbad Hγp") as %?%frac_auth_frag_valid_op_1_l; done. }
  wp_load.
  iDestruct (own_valid_2 with "Hγp' Hγp") as % ->%frac_auth_agreeL.
  iDestruct (own_valid_2 with "Hγl' Hγl") as % ->%frac_auth_agreeL.
  iDestruct (own_valid_2 with "Hγv' Hγv") as % ->%frac_auth_agreeL.
  iMod ("Hclose2" with "[Hγp' Hγv' Hγp]").
  { iNext. iExists O, nc. iFrame. iLeft. iFrame. }

  iModIntro.
  iMod ("Hclose1" with "[Hγl' Hl]").
  { iNext. iExists nc. iFrame. }

  iModIntro. iApply "HΦ". rewrite //=.
Qed.

Lemma newcounter_spec N1 N2 n :
  {{{ ownProb (approx_n n O)}}}
    newcounter #()
  {{{ γl γp γv l, RET #l;
      inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
     acounter γl γp γv 1 n O }}}.
Proof.
  iIntros (Φ) "Hprob HΦ".
  iMod (own_alloc (●! O%nat ⋅ ◯! O%nat)) as (γl) "[Hγl' Hγl]"; first done.
  iMod (own_alloc (●! n%nat ⋅ ◯! n%nat)) as (γp) "[Hγp' Hγp]"; first done.
  iMod (own_alloc (●! O%nat ⋅ ◯! O%nat)) as (γv) "[Hγv' Hγv]"; first done.

  rewrite -wp_fupd /newcounter /=.
  wp_let. wp_alloc l as "Hl".
  iMod (inv_alloc N1 _ (acounter_loc_inv γl l) with "[Hl Hγl']").
  { iNext. iExists O. iFrame. }
  iMod (inv_alloc N2 _ (acounter_prob_inv γp γv) with "[Hγp' Hγv' Hprob]").
  { iNext. iExists n, O. iFrame. iRight. done. }

  iApply "HΦ".
  iModIntro. iFrame.
Qed.

(* Bundled versions to match cleaner formulation for paper *)
Definition Acounter γl γp γc l (q : frac) (nperm : nat) : iProp Σ :=
  (∃ N1 N2 ncontrib,
  ⌜ N1 ## N2 ⌝ ∗ inv N1 (acounter_loc_inv γl l) ∗ inv N2 (acounter_prob_inv γp γc) ∗
    own γp (◯!{q} nperm) ∗ own γl (◯!{q} ncontrib) ∗ own γc (◯!{q} ncontrib))%I.

Lemma Acounter_sep γl γp γv l q1 q2 np1 np2:
  Acounter γl γp γv l (q1 + q2) (np1 + np2) ⊢
           Acounter γl γp γv l q1 np1 ∗ Acounter γl γp γv l q2 np2.
Proof.
  iStartProof.
  * iIntros "HA".
    iDestruct "HA" as (N1 N2 nc) "(%&#Hi1&#Hi2&HA)".
    replace nc with (O + nc)%nat by auto.
    iPoseProof (acounter_sep γl γp γv q1 q2 np1 np2 O nc with "[HA]") as "(HA1&HA2)"; auto.
    iSplitL "HA1".
    ** iExists N1, N2, O. auto.
    ** iExists N1, N2, nc. auto.
Qed.

Lemma Acounter_join γl γp γv l q1 q2 np1 np2:
  Acounter γl γp γv l q1 np1 ∗ Acounter γl γp γv l q2 np2 ⊢
           Acounter γl γp γv l (q1 + q2) (np1 + np2).
Proof.
  iStartProof.
  iIntros "(HA1&HA2)".
  iDestruct "HA1" as (N1 N2 nc1) "(%&#Hi1&#Hi2&HA1)".
  iDestruct "HA2" as (N1' N2' nc2) "(%&#Hi1'&#Hi2'&HA2)".
  iCombine "HA1" "HA2" as "HA".
  rewrite acounter_join.
  iExists N1, N2, (nc1 + nc2)%nat; auto.
Qed.

Lemma newcounter_spec' n :
  {{{ ownProb (approx_n n O)}}}
    newcounter #()
  {{{ γl γp γc l, RET #l;
     Acounter γl γp γc l 1 n}}}.
Proof.
  iIntros (Φ) "Hprob HΦ".
  set (N1 := nroot .@ "N1").
  set (N2 := nroot .@ "N2").
  iApply (newcounter_spec N1 N2 n with "Hprob").
  iNext. iIntros (γl γp γv l) "(Hinv1&Hinv2&Hacounter)". iApply "HΦ".
  iExists N1, N2, O.
  iFrame. rewrite /N1/N2; eauto with *.
Qed.

Lemma incr_spec' γl γp γc l q np :
  {{{ Acounter γl γp γc l q (S np)}}}
    incr (Lit $ LitLoc l)
  {{{ RET LitV LitUnit; Acounter γl γp γc l q np }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 ncontrib) "(%&#Hinv1&#Hinv2&H)".
  iApply (incr_spec with "[H]").
  { iFrame "Hinv1 Hinv2 H". }
  iNext. iIntros "HA". iDestruct "HA" as (nc') "HA".
  iApply "HΦ".
  iExists N1, N2, nc'; iFrame; eauto.
Qed.

Lemma read_spec' γl γp γc l:
  {{{ Acounter γl γp γc l 1 0}}}
    read (Lit $ LitLoc l)
  {{{ (v : nat), RET LitV $ LitInt v; ownProb (mret v) }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 ncontrib) "(%&#Hinv1&#Hinv2&H)".
  iApply (read_spec with "[H]"); first by eauto.
  { iFrame "Hinv1 Hinv2 H". }
  done.
Qed.

Section simple_client.

Definition incr_n : val :=
  rec: "incr_n" "l" "n" :=
    if: "n" = #0 then
      #()
    else
      incr "l";;
      let: "n'" := "n" - #1 in
      "incr_n" "l" "n'".

Definition simple_client n1 n2 : expr :=
  let: "l" := newcounter #() in
  (incr_n "l" #n1  ||| incr_n "l" #n2) ;;
  read "l".

Lemma incr_n_spec N1 N2 γl γp γv q n1 n2 l:
  {{{ inv N1 (acounter_loc_inv γl l) ∗
      inv N2 (acounter_prob_inv γp γv) ∗
      acounter γl γp γv q n1 n2 }}}
    (incr_n #l) #n1
  {{{ v, RET v; ∃ nc : nat, acounter γl γp γv q 0 nc }}}.
Proof.
  iIntros (Φ) "(#Hinv1&#Hinv2&Hcounter) Hwand".
  iRevert (n1 n2) "Hcounter".
  iLöb as "IH". iIntros (n1 n2) "Hcounter".
  wp_rec.
  wp_let.
  wp_op; case_bool_decide.
  * wp_if.
    assert (n1 = 0)%nat by (inversion H; auto; omega).
    subst. iApply "Hwand". iExists n2. done.
  * wp_if.
    assert (n1 ≠ 0)%nat.
    { intros Heq.  subst. rewrite //= in H. }
    destruct n1 as [| n1]; first by auto.
    wp_apply (incr_spec with "[Hcounter]"); [ iFrame "Hinv1 Hinv2"; done |].
    iIntros "Hcounter".
    iDestruct "Hcounter" as (nc) "Hcounter".
    wp_let. rewrite Zpos_P_of_succ_nat. wp_op.
    replace (Z.succ n1 - 1)%Z with (n1 : Z) by omega.
    wp_let. wp_apply ("IH" with "Hwand Hcounter").
Qed.

Lemma incr_n_spec' γl γp γc l q n1:
  {{{ Acounter γl γp γc l q n1}}}
    (incr_n #l) #n1
  {{{ v, RET v; Acounter γl γp γc l q 0 }}}.
Proof.
  iIntros (Φ) "Hacounter HΦ".
  iDestruct "Hacounter" as (N1 N2 nc) "(%&#Hinv1&#Hinv2&H)".
  iApply (incr_n_spec with "[H]").
  { iFrame "Hinv1 Hinv2 H". }
  iNext. iIntros (v) "HA". iDestruct "HA" as (nc') "HA".
  iApply "HΦ".
  iExists N1, N2, nc'; iFrame; eauto.
Qed.

Lemma simple_client_spec n1 n2:
  ownProb (approx_n (n1 + n2) O) ⊢
          WP (simple_client n1 n2) {{ v, ∃ (v' : nat), ownProb (mret v') ∗
                                                 ⌜ v = LitV $ LitInt v' ⌝ }}%I.
Proof.
  iIntros "Hprob". rewrite /simple_client.
  wp_bind (newcounter _).
  wp_apply (newcounter_spec' with "Hprob").
  iIntros (γl γp γv l) "Hcounter".
  rewrite -(Qp_div_2 1).
  replace 0%nat with (0 + 0)%nat by auto.
  rewrite Acounter_sep.
  iDestruct "Hcounter" as "(Hcounter1&Hcounter2)".
  wp_let. wp_apply (wp_par (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                           (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                      with "[Hcounter1] [Hcounter2]").
  - wp_apply (incr_n_spec' with "Hcounter1").
    iIntros (_); auto.
  - wp_apply (incr_n_spec' with "Hcounter2").
    iIntros (_); auto.
  - iIntros (v1 v2) "(Hpost1&Hpost2)".
    iCombine "Hpost1" "Hpost2" as "Hpost".
    rewrite Acounter_join Qp_div_2 //=.
    iNext. wp_let. wp_apply (read_spec' with "Hpost"); eauto.
Qed.
End simple_client.

Section list_client.

  (* Convert a list of Coq bools into a heap_lang tuple *)
Fixpoint l2tuple (l: list bool) : val :=
  match l with
  | [] => NONEV
  | b :: l =>
    SOMEV (#b, l2tuple l)
  end.

Definition foldLeft : val :=
  rec: "foldLeft" "f" "l" "a" :=
    match: "l" with
      NONE => "a"
    | SOME "cell" =>
      "foldLeft" "f" (Snd "cell") ("f" "a" (Fst "cell"))
    end.

(* Uses the approx counter to count the number of trues occurring in a list *)
Definition countTrue : val :=
  λ: "c" "lb",
  foldLeft (λ: <> "b", if: "b" then incr "c" else #()) "lb" #().

Definition list_client l1 l2 : expr :=
  let: "c" := newcounter #() in
  (countTrue "c" (l2tuple l1)  ||| countTrue "c" (l2tuple l2)) ;;
  read "c".

Definition lenTrue l := (List.length (List.filter (λ x, x) l)).

Lemma countTrue_spec γl γp γc l q lb:
  {{{ Acounter γl γp γc l q (lenTrue lb) }}}
    (countTrue #l) (l2tuple lb)
  {{{ v, RET v; Acounter γl γp γc l q 0 }}}.
Proof.
  iIntros (Φ) "HA Hwand".
  wp_let. wp_let. wp_let. wp_let. wp_let.
  iRevert (lb) "HA".
  iLöb as "IH". iIntros (lb) "Hcounter".
  destruct lb.
  * wp_match. iApply "Hwand"; done.
  * rewrite /l2tuple -/l2tuple.
    wp_match. wp_let. wp_proj.
    wp_let. wp_let. wp_proj. wp_let.
    destruct b.
    ** wp_if. wp_apply (incr_spec' with "Hcounter").
       iIntros "Hcounter".
       wp_let.  iApply ("IH" with "Hwand Hcounter").
    ** wp_if.
       wp_let.  iApply ("IH" with "Hwand [Hcounter]").
       rewrite //=.
Qed.

Lemma list_client_spec l1 l2:
  ownProb (approx_n (lenTrue l1 + lenTrue l2) O) ⊢
          WP (list_client l1 l2) {{ v, ∃ (v' : nat), ownProb (mret v') ∗
                                                 ⌜ v = LitV $ LitInt v' ⌝ }}%I.
Proof.
  iIntros "Hprob". rewrite /list_client.
  wp_bind (newcounter _).
  wp_apply (newcounter_spec' with "Hprob").
  iIntros (γl γp γv l) "Hcounter".
  rewrite -(Qp_div_2 1).
  replace 0%nat with (0 + 0)%nat by auto.
  rewrite Acounter_sep.
  iDestruct "Hcounter" as "(Hcounter1&Hcounter2)".
  wp_let. wp_apply (wp_par (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                           (λ v, Acounter γl γp γv l (1 / 2)%Qp 0)%I
                      with "[Hcounter1] [Hcounter2]").
  - wp_apply (countTrue_spec with "Hcounter1").
    iIntros (_); auto.
  - wp_apply (countTrue_spec with "Hcounter2").
    iIntros (_); auto.
  - iIntros (v1 v2) "(Hpost1&Hpost2)".
    iCombine "Hpost1" "Hpost2" as "Hpost".
    rewrite Acounter_join Qp_div_2 //=.
    iNext. wp_let. wp_apply (read_spec' with "Hpost"); eauto.
Qed.
End list_client.

End proof.

Section adequate.
Let Σ : gFunctors := #[ heapΣ ; spawnΣ; acounterΣ].

Definition client_ival sch e σ k := @ivdist_tpool_stepN heap_ectxi_lang sch [e] σ k.

Lemma generic_client_adequate n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  irrel_couplingP (client_ival sch e σ k)
                  (approx_n n O)
                  (prob_adequacy.coupling_post (λ x y, x = LitV $ LitInt y)).
Proof.
  intros Hspec ?.
  eapply (heap_prob_adequacy Σ (approx_n n 0)
                             e σ (λ x y, x = LitV $ LitInt y) sch k); eauto.
  intros. iIntros "Hprob".
  iApply Hspec; done.
Qed.

Lemma generic_client_ex_Ex_ival n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  ex_Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch e σ k).
Proof.
  intros.
  intros. eapply irrel_coupling_eq_ex_Ex_supp; last first.
  { eapply pspec_bounded.  eexists. apply approx_n_bounded. }
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
Qed.

Lemma generic_client_Ex_ival n sch e σ k:
  (∀ `{heapG Σ} `{H: probG Σ},
    ownProb (approx_n n 0) -∗
   WP e {{ v, ∃ v' : nat, ownProb (mret v') ∗ ⌜v = #v'⌝ }})%I →
  terminates sch [([e], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch e σ k)
  = INR n%nat.
Proof.
  intros. replace (INR n) with (INR (n + 0)%nat) by (f_equal; omega).
  apply stochastic_order.Finite_inj.
  apply Rbar_le_antisym.
  - rewrite -Ex_max_approx_n.
    intros. apply irrel_coupling_eq_Ex_max_supp.
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
    * apply pspec_bounded. eexists. apply approx_n_bounded.
  - rewrite -Ex_min_approx_n.
    intros. apply irrel_coupling_eq_Ex_min_supp.
    eapply irrel_coupling_conseq; last first.
    * eapply irrel_coupling_proper; last eapply generic_client_adequate.
      ** reflexivity.
      ** reflexivity.
      ** eauto.
      ** eauto.
    * intros x y.
      destruct x as ([| v ?]&?) => //=.
      destruct (to_val v) => //=.
      destruct v0 => //=. destruct l0 => //=.
      inversion 1. subst.
      rewrite INR_IZR_INZ. done.
    * apply pspec_bounded. eexists. apply approx_n_bounded.
Qed.

Lemma simple_client_ex_Ex_ival (n1 n2: nat) sch σ k:
  terminates sch [([simple_client n1 n2], σ)] k →
  ex_Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (simple_client n1 n2) σ k).
Proof.
  eapply generic_client_ex_Ex_ival.
  iIntros; iApply simple_client_spec; done.
Qed.

Lemma simple_client_Ex_ival (n1 n2: nat) sch σ k:
  terminates sch [([simple_client n1 n2], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (simple_client n1 n2) σ k)
  = INR (n1 + n2)%nat.
Proof.
  apply generic_client_Ex_ival.
  iIntros; iApply simple_client_spec; done.
Qed.

Lemma list_client_Ex_ival lb1 lb2 sch σ k:
  terminates sch [([list_client lb1 lb2], σ)] k →
  Ex_ival (λ x, match fst x with
                | [] => 0
                | e :: _ => match prob_language.to_val e with
                            | Some (LitV (LitInt y)) => IZR y
                            | _ => 0
                            end
                end) (client_ival sch (list_client lb1 lb2) σ k)
  = INR (lenTrue lb1 + lenTrue lb2)%nat.
Proof.
  apply generic_client_Ex_ival.
  iIntros; iApply list_client_spec; done.
Qed.

End adequate.
End COUNTER.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2014: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_Terms Derived_Pairs
        Derived_Products Derived_Rules.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.

Module Make(Import M: Memory.T).
  Module Export ProofsExp := Derived_Rules.Make(M).

(* --- Main Proofs --- *)

 Theorem annihilation_update_lookup: forall i: Loc,
         update i o lookup i == id.
         (* Prop: 2.1: All Cases *)
 Proof.
     intro. remember observation. apply observation. intro k.
     destruct (Loc_dec i k). rewrite <- e.
     (*Case k = i*)
     rewrite assoc. setoid_rewrite -> id_src. setoid_rewrite <- id_tgt at 6.
     apply wsc. apply axiom_1. apply strong_refl.
     (*Case k <> i*)
     rewrite assoc. remember wsc. rewrite axiom_2; try decorate.
     apply strong_to_weak. rewrite <- assoc. apply sc. apply strong_refl.
     apply E_1_4; decorate.
 Qed.

 Theorem interaction_lookup_lookup: forall i,
         lookup i o forget o lookup i == lookup i.
         (* Prop: 2.2: All Cases: Simplified Version *)
 Proof.
     intros. setoid_rewrite <- id_src at 6. rewrite <- assoc. apply sc.
     apply strong_refl. apply E_1_4; decorate.
 Qed.

 Theorem interaction_update_lookup: forall i: Loc,
         lookup i o update i ~~ id. (* Prop: 2.4: All Cases *)
 Proof. intros. apply axiom_1. Qed.

 Theorem commutation_lookup_lookup: forall i j: Loc, i<>j ->
         (prod id (lookup j)) o (inv_pi1 o lookup i)
         ==
         permut o ((prod id (lookup i)) o (inv_pi1 o lookup j)).
         (* Prop: 2.5: All Cases *)
 Proof.
    intros. remember strong_unicity.
    specialize (@strong_unicity _ _ _
    (prod id (lookup j) o (inv_pi1 o lookup i))
    ((permut) o ((prod id (lookup i)) o (inv_pi1 o lookup j)))).
    intros. apply H0.
    (*Case pi1*)
    setoid_rewrite assoc at 1. remember wsc.
    rewrite strong_proj_pi1_purero_rect; try decorate. rewrite id_tgt.
    rewrite assoc. unfold inv_pi1. rewrite strong_proj_pi1_purero; try decorate.
    rewrite id_tgt. apply weak_sym.
    (*Step 2*)
    rewrite assoc. apply strong_to_weak. remember sc.
    rewrite strong_pi1_permut__pi2. rewrite assoc.
    rewrite strong_proj_pi2_purero_rect; try decorate. rewrite assoc.
    setoid_rewrite <- assoc at 2. rewrite strong_proj_pi2_purero; try decorate.
    rewrite <- assoc. rewrite E_1_4; try decorate. rewrite id_src. apply strong_refl.
    (*Case pi2*)
    rewrite assoc. remember sc. rewrite strong_proj_pi2_purero_rect; try decorate.
    rewrite assoc. setoid_rewrite <- assoc at 2. rewrite strong_pi2_inv_pi1__unit.
    rewrite <- assoc. rewrite E_1_4; try decorate. rewrite id_src. apply strong_sym.
    (*Step 2*)
    rewrite assoc. rewrite strong_pi2_permut__pi1. rewrite assoc.
    rewrite strong_proj_pi1_purero_rect; try decorate. rewrite id_tgt.
    rewrite assoc. unfold inv_pi1. rewrite strong_proj_pi1_purero; try decorate.
    rewrite id_tgt. apply strong_refl.
 Qed.

 Theorem commutation_lookup_constant: forall i: Loc, forall c: Z,
         (lookup i o (update i o (constant c)))
         ==
         (constant c) o update i o (constant c).
         (*Prop 2.8: All Cases*)
 Proof.
     intros. remember comp_final_unique. specialize (@comp_final_unique _ _
     (lookup i o (update i o (constant c)))
     ((constant c) o (update i o (constant c)))).
     intros. setoid_rewrite <- assoc at 1. apply H.
     (* Case 1: <> o f == <> o g *)
     rewrite assoc. specialize (@E_1_4 _ (lookup i)). intros. remember sc.
     rewrite H0; try decorate. rewrite id_tgt. apply strong_sym. rewrite assoc.
     specialize (@E_0_4 _ (constant c)).  intros. rewrite H1; try decorate.
     rewrite id_tgt. apply strong_refl.
     (* Case 2: f ~ g *)
     rewrite assoc. remember wsc. rewrite axiom_1. rewrite id_tgt.
     rewrite <- id_src at 1. apply wrc; try decorate. apply weak_final_unique.
 Qed.

 Lemma commutation_lookup_constant_update: forall (m: Loc) (p q: Z),
      (pair (lookup m) (constant q)) o (update m o constant p)
      ==
      (pair (constant p) (constant q)) o (update m o constant p).
 Proof.
      intros. apply strong_unicity. repeat rewrite assoc. remember wrc.
      rewrite weak_proj_pi1_rorw;  try decorate. rewrite axiom_1.
      rewrite id_tgt. apply weak_sym.
      repeat rewrite assoc. rewrite weak_proj_pi1_rorw;  try decorate.
      setoid_rewrite <- id_src at 6. rewrite <- assoc.
      apply wrc; (solve[decorate] || idtac). apply weak_final_unique.
      repeat rewrite assoc. remember sc.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_sym.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_refl.
 Qed.

 Lemma commutation_constant_lookup_update: forall (m: Loc) (p q: Z),
      (pair (constant q) (lookup m)) o (update m o constant p)
      ==
      (pair (constant q) (constant p)) o (update m o constant p).
 Proof.
      intros. apply strong_unicity. repeat rewrite assoc. remember wrc.
      rewrite weak_proj_pi1_rorw;  try decorate. apply weak_sym.
      rewrite weak_proj_pi1_rorw;  try decorate. apply weak_refl.
      repeat rewrite assoc. remember sc.
      rewrite strong_proj_pi2_rorw;  try decorate.
      specialize(@commutation_lookup_constant m p). intros.
      rewrite <- assoc. rewrite H. apply strong_sym.
      rewrite strong_proj_pi2_rorw;  try decorate. apply strong_refl.
 Qed.

Lemma commutation_update_update: forall {x y: Loc}, forall (n m: Z), x<>y ->
	(update y o constant m) o (update x o constant n) ==
        (update x o constant n) o (update y o constant m).
 Proof.
    intros. apply observation. intros.
    (* i = y *)
    destruct (Loc_dec i y). rewrite e. repeat rewrite assoc. rewrite axiom_1.
    intros. apply weak_sym. rewrite  axiom_2; try decorate. specialize(@E_0_4 _ (constant n)).
    intros. setoid_rewrite <- assoc at 3. rewrite H0; try decorate.
    setoid_rewrite id_src. rewrite axiom_1. rewrite id_tgt. apply weak_sym.
    specialize(@weak_final_unique _ (update x o (constant n)) (@id unit)).
    intros. rewrite <- assoc. rewrite H1. rewrite id_src. apply weak_refl.
    (* i = x *)
    destruct (Loc_dec i x). rewrite e. repeat rewrite assoc. rewrite  axiom_2.
    specialize(@E_0_4 _ (constant m)). intros. setoid_rewrite <- assoc at 3.
    rewrite H0; try decorate. setoid_rewrite id_src. rewrite axiom_1. rewrite id_tgt.
    setoid_rewrite <- id_src at 1. rewrite <- assoc. apply wrc; try decorate.
    apply weak_final_unique. auto.
    (* i <> x and i <> y *)
    repeat rewrite assoc. rewrite axiom_2; (auto || idtac). specialize(@E_0_4 _ (constant m)).
    intros. setoid_rewrite <- assoc at 3. rewrite H0; (solve[decorate] || idtac).
    rewrite id_src. rewrite axiom_2; (auto || idtac). rewrite <- assoc. apply weak_sym.
    remember E_0_4. specialize(@E_0_4 _ (constant n)). intros.
    remember wsc. rewrite H1 at 1; try decorate. rewrite id_src. rewrite assoc.
    rewrite axiom_2; auto. repeat rewrite <- assoc. apply strong_to_weak. apply sc.
    apply strong_refl. apply one_weak_to_strong; try decorate. apply weak_final_unique.
 Qed.

(* -------------------- End of Main Proofs -------------------- *)

End Make.


From mathcomp Require Import all_ssreflect.
From mathcomp.analysis Require Import classical_sets boolp.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevanceFacts ProofIrrelevance.

Lemma funext (A B : Type) (f g : A -> B) : f =1 g -> f = g.
Proof.
  move=> H. extensionality x. apply: H.
Qed.

Export classical_sets boolp FunctionalExtensionality ProofIrrelevance ProofIrrelevanceFacts.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Properties of [abs] and [sgn] *)

Require Import ZMulOrder.

(** Since we already have [max], we could have defined [abs]. *)

Module GenericAbs (Import Z : ZAxiomsMiniSig')
                  (Import ZP : ZMulOrderProp Z) <: HasAbs Z.
 Definition abs n := max n (-n).
 Lemma abs_eq : forall n, 0<=n -> abs n == n.
 Proof.
  intros. unfold abs. apply max_l.
  apply le_trans with 0; auto.
  rewrite opp_nonpos_nonneg; auto.
 Qed.
 Lemma abs_neq : forall n, n<=0 -> abs n == -n.
 Proof.
  intros. unfold abs. apply max_r.
  apply le_trans with 0; auto.
  rewrite opp_nonneg_nonpos; auto.
 Qed.
End GenericAbs.

(** We can deduce a [sgn] function from a [compare] function *)

Module Type ZDecAxiomsSig := ZAxiomsMiniSig <+ HasCompare.
Module Type ZDecAxiomsSig' := ZAxiomsMiniSig' <+ HasCompare.

Module Type GenericSgn (Import Z : ZDecAxiomsSig')
                       (Import ZP : ZMulOrderProp Z) <: HasSgn Z.
 Definition sgn n :=
  match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end.
 Lemma sgn_null : forall n, n==0 -> sgn n == 0.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_pos : forall n, 0<n -> sgn n == 1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
 Lemma sgn_neg : forall n, n<0 -> sgn n == -1.
 Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed.
End GenericSgn.

(** Derived properties of [abs] and [sgn] *)

Module Type ZSgnAbsProp (Import Z : ZAxiomsSig')
                        (Import ZP : ZMulOrderProp Z).

Ltac destruct_max n :=
 destruct (le_ge_cases 0 n);
  [rewrite (abs_eq n) by auto | rewrite (abs_neq n) by auto].

Instance abs_wd : Proper (eq==>eq) abs.
Proof.
 intros x y EQ. destruct_max x.
 rewrite abs_eq; trivial. now rewrite <- EQ.
 rewrite abs_neq; try order. now rewrite opp_inj_wd.
Qed.

Lemma abs_max : forall n, abs n == max n (-n).
Proof.
 intros n. destruct_max n.
 rewrite max_l; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonpos_nonneg; auto.
 rewrite max_r; auto with relations.
 apply le_trans with 0; auto.
 rewrite opp_nonneg_nonpos; auto.
Qed.

Lemma abs_neq' : forall n, 0<=-n -> abs n == -n.
Proof.
 intros. apply abs_neq. now rewrite <- opp_nonneg_nonpos.
Qed.

Lemma abs_nonneg : forall n, 0 <= abs n.
Proof.
 intros n. destruct_max n; auto.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_eq_iff : forall n, abs n == n <-> 0<=n.
Proof.
 split; try apply abs_eq. intros EQ.
 rewrite <- EQ. apply abs_nonneg.
Qed.

Lemma abs_neq_iff : forall n, abs n == -n <-> n<=0.
Proof.
 split; try apply abs_neq. intros EQ.
 rewrite <- opp_nonneg_nonpos, <- EQ. apply abs_nonneg.
Qed.

Lemma abs_opp : forall n, abs (-n) == abs n.
Proof.
 intros. destruct_max n.
 rewrite (abs_neq (-n)), opp_involutive. reflexivity.
 now rewrite opp_nonpos_nonneg.
 rewrite (abs_eq (-n)). reflexivity.
 now rewrite opp_nonneg_nonpos.
Qed.

Lemma abs_0 : abs 0 == 0.
Proof.
 apply abs_eq. apply le_refl.
Qed.

Lemma abs_0_iff : forall n, abs n == 0 <-> n==0.
Proof.
 split. destruct_max n; auto.
 now rewrite eq_opp_l, opp_0.
 intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl.
Qed.

Lemma abs_pos : forall n, 0 < abs n <-> n~=0.
Proof.
 intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ].
 intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0).
 assert (LE : 0 <= abs n) by apply abs_nonneg.
 rewrite lt_eq_cases in LE; destruct LE; auto.
 elim NEQ; auto with relations.
Qed.

Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n.
Proof.
 intros. destruct_max n; auto with relations.
Qed.

Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n.
Proof.
 intros. destruct_max n; rewrite ? opp_involutive; auto with relations.
Qed.

Lemma abs_involutive : forall n, abs (abs n) == abs n.
Proof.
 intros. apply abs_eq. apply abs_nonneg.
Qed.

Lemma abs_spec : forall n,
  (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n).
Proof.
 intros. destruct (le_gt_cases 0 n).
 left; split; auto. now apply abs_eq.
 right; split; auto. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_case_strong :
  forall (P:t->Prop) n, Proper (eq==>iff) P ->
    (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n).
Proof.
 intros. destruct_max n; auto.
Qed.

Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P ->
 P n -> P (-n) -> P (abs n).
Proof. intros. now apply abs_case_strong. Qed.

Lemma abs_eq_cases : forall n m, abs n == abs m -> n == m \/ n == - m.
Proof.
 intros n m EQ. destruct (abs_or_opp_abs n) as [EQn|EQn].
 rewrite EQn, EQ. apply abs_eq_or_opp.
 rewrite EQn, EQ, opp_inj_wd, eq_opp_l, or_comm. apply abs_eq_or_opp.
Qed.

Lemma abs_lt : forall a b, abs a < b <-> -b < a < b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_neg_pos; order.
 rewrite opp_lt_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply lt_le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
Qed.

Lemma abs_le : forall a b, abs a <= b <-> -b <= a <= b.
Proof.
 intros a b.
 destruct (abs_spec a) as [[LE EQ]|[LT EQ]]; rewrite EQ; clear EQ.
 split; try split; try destruct 1; try order.
 apply le_trans with 0; trivial. apply opp_nonpos_nonneg; order.
 rewrite opp_le_mono, opp_involutive.
 split; try split; try destruct 1; try order.
 apply le_trans with 0. order. apply opp_nonpos_nonneg; order.
Qed.

(** Triangular inequality *)

Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m.
Proof.
 intros. destruct_max n; destruct_max m.
 rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 destruct_max (n+m); try rewrite opp_add_distr;
  apply add_le_mono_l || apply add_le_mono_r.
 apply le_trans with 0; auto. now rewrite opp_nonneg_nonpos.
 apply le_trans with 0; auto. now rewrite opp_nonpos_nonneg.
 rewrite abs_neq, opp_add_distr. apply le_refl.
 now apply add_nonpos_nonpos.
Qed.

Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m).
Proof.
 intros.
 rewrite le_sub_le_add_l, add_comm.
 rewrite <- (sub_simpl_r n m) at 1.
 apply abs_triangle.
Qed.

(** Absolute value and multiplication *)

Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m.
Proof.
 assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m).
  intros. destruct_max m.
  rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg.
  rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos .
 intros. destruct_max n. now apply H.
 rewrite <- mul_opp_opp, H, abs_opp. reflexivity.
 now apply opp_nonneg_nonpos.
Qed.

Lemma abs_square : forall n, abs n * abs n == n * n.
Proof.
 intros. rewrite <- abs_mul. apply abs_eq. apply le_0_square.
Qed.

(** Some results about the sign function. *)

Ltac destruct_sgn n :=
 let LT := fresh "LT" in
 let EQ := fresh "EQ" in
 let GT := fresh "GT" in
 destruct (lt_trichotomy 0 n) as [LT|[EQ|GT]];
 [rewrite (sgn_pos n) by auto|
  rewrite (sgn_null n) by auto with relations|
  rewrite (sgn_neg n) by auto].

Instance sgn_wd : Proper (eq==>eq) sgn.
Proof.
 intros x y Hxy. destruct_sgn x.
 rewrite sgn_pos; auto with relations. rewrite <- Hxy; auto.
 rewrite sgn_null; auto with relations. rewrite <- Hxy; auto with relations.
 rewrite sgn_neg; auto with relations. rewrite <- Hxy; auto.
Qed.

Lemma sgn_spec : forall n,
  0 < n /\ sgn n == 1 \/
  0 == n /\ sgn n == 0 \/
  0 > n /\ sgn n == -1.
Proof.
 intros n.
 destruct_sgn n; [left|right;left|right;right]; auto with relations.
Qed.

Lemma sgn_0 : sgn 0 == 0.
Proof.
 now apply sgn_null.
Qed.

Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n.
Proof.
 split; try apply sgn_pos. destruct_sgn n; auto.
 intros. elim (lt_neq 0 1); auto. apply lt_0_1.
 intros. elim (lt_neq (-1) 1); auto.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
Qed.

Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0.
Proof.
 split; try apply sgn_null. destruct_sgn n; auto with relations.
 intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0.
Proof.
 split; try apply sgn_neg. destruct_sgn n; auto with relations.
 intros. elim (lt_neq (-1) 1); auto with relations.
 apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1.
 intros. elim (lt_neq (-1) 0); auto with relations.
 rewrite opp_neg_pos. apply lt_0_1.
Qed.

Lemma sgn_opp : forall n, sgn (-n) == - sgn n.
Proof.
 intros. destruct_sgn n.
 apply sgn_neg. now rewrite opp_neg_pos.
 setoid_replace n with 0 by auto with relations.
  rewrite opp_0. apply sgn_0.
 rewrite opp_involutive. apply sgn_pos. now rewrite opp_pos_neg.
Qed.

Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n.
Proof.
 split.
 destruct_sgn n; intros.
 now apply lt_le_incl.
 order.
 elim (lt_irrefl 0). apply lt_le_trans with 1; auto using lt_0_1.
  now rewrite <- opp_nonneg_nonpos.
 rewrite lt_eq_cases; destruct 1.
 rewrite sgn_pos by auto. apply lt_le_incl, lt_0_1.
 rewrite sgn_null by auto with relations. apply le_refl.
Qed.

Lemma sgn_nonpos : forall n, sgn n <= 0 <-> n <= 0.
Proof.
 intros. rewrite <- 2 opp_nonneg_nonpos, <- sgn_opp. apply sgn_nonneg.
Qed.

Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m.
Proof.
 intros. destruct_sgn n; nzsimpl.
 destruct_sgn m.
  apply sgn_pos. now apply mul_pos_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_neg. now apply mul_pos_neg.
 apply sgn_null. rewrite eq_mul_0; auto with relations.
 destruct_sgn m; try rewrite mul_opp_opp; nzsimpl.
  apply sgn_neg. now apply mul_neg_pos.
  apply sgn_null. rewrite eq_mul_0; auto with relations.
  apply sgn_pos. now apply mul_neg_neg.
Qed.

Lemma sgn_abs : forall n, n * sgn n == abs n.
Proof.
 intros. symmetry.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl.
 apply abs_eq. now apply lt_le_incl.
 rewrite abs_0_iff; auto with relations.
 apply abs_neq. now apply lt_le_incl.
Qed.

Lemma abs_sgn : forall n, abs n * sgn n == n.
Proof.
 intros.
 destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto.
 apply abs_eq. now apply lt_le_incl.
 rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl.
Qed.

Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x.
Proof.
 intros.
 destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ.
 apply sgn_pos, lt_0_1.
 now apply sgn_null.
 apply sgn_neg. rewrite opp_neg_pos. apply lt_0_1.
Qed.

End ZSgnAbsProp.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.MSets.MSets.
Require Import CoqMSetInterface.

(* *********************************************************************** *)
(** * Interface *)

Module Type WSfun (X : DecidableType).

  Include CoqMSetInterface.WSetsOn X.

  (** Definition of when two sets are disjoint. *)

  Definition disjoint E F := inter E F [=] empty.

  (** We make [notin] a definition for [~ In x L].  We use this
      definition whenever possible, so that the [intuition] tactic
      does not turn [~ In x L] into [In x L -> False]. *)

  Definition notin x L := ~ In x L.

  (** The predicate [fresh_list L n xs] holds when [xs] is a list of
      length [n] such that the elements are distinct from each other
      and from the elements of [L]. *)

  Fixpoint fresh_list
      (L : t) (n : nat) (xs : list X.t) {struct xs} : Prop :=
    match xs, n with
      | nil, O =>
        True
      | cons x xs', S n' =>
        notin x L /\ fresh_list (union L (singleton x)) n' xs'
      | _, _ =>
        False
    end.

End WSfun.

(* *********************************************************************** *)
(** * Implementation *)

Module Make (X : DecidableType) <: WSfun X.

  Include Coq.MSets.MSetWeakList.Make X.

  Definition disjoint E F := Equal (inter E F) empty.

  Definition notin x L := ~ In x L.

  Fixpoint fresh_list
      (L : t) (n : nat) (xs : list X.t) {struct xs} : Prop :=
    match xs, n with
      | nil, O =>
        True
      | cons x xs', S n' =>
        notin x L /\ fresh_list (union L (singleton x)) n' xs'
      | _, _ =>
        False
    end.

End Make.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Rfunctions NaryFunctions.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop tuple.

Require Import MathComp.

(*
This library defines polymorphic definitions rec1up (resp. rec2up) that
make it possible to compute the list [:: u(0); u(1);...; u(n)] for
a given function u defined by an order-1 (resp. order-2) recurrence.
*)

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

Ltac flatten := repeat
  first[rewrite<-pred_of_minus in *| rewrite<-plusE in *|rewrite<-minusE in *].
Ltac iomega := intros; flatten; (omega || apply/leP; omega).
Ltac iomega_le := (repeat move/leP=>?); iomega.

(** * Additional lemmas about [seq] *)

Notation nth_defaults := set_nth_default. (* for backward compatibility *)

Lemma behead_rcons (T : Type) (s : seq T) (x : T) :
  s <> [::] -> behead (rcons s x) = rcons (behead s) x.
Proof. by case: s. Qed.

Lemma behead_rev_take (T : Type) (s : seq T) (n : nat) :
  n <= size s -> behead (rev (take n s)) = rev (take n.-1 s).
Proof.
elim: n s =>[//|n IHn] [//|x s] H //.
rewrite ltnS -/size in H.
rewrite /=.
case: n IHn H =>[//|n] /= IHn H; first by rewrite take0 //.
rewrite [in RHS]rev_cons -IHn // rev_cons behead_rcons //.
move/(f_equal size).
fold (@take T); fold (@size T) in H.
rewrite size_rev size_take.
case: leq =>//=.
by move=> top; rewrite top in H.
Qed.

(** * Order-1 recurrences *)

Section Defix1.

Variable T : Type.

Variable F : T -> nat -> T.
(** to be instantiated by a function satisfying u(n) = F(u(n-1), n). *)

Fixpoint loop1 (n p : nat) (a : T) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let c := F a p in loop1 m p.+1 c (c :: s)
  end.

Variable a0 : T.

Definition rec1down n := loop1 n 1 a0 [:: a0].

Definition rec1up n := rev (rec1down n).

Lemma size_loop1 n p a s : size (loop1 n p a s) = n + size s.
Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed.

Lemma size_rec1down n : size (rec1down n) = n.+1.
Proof. by case: n => [//|n]; rewrite size_loop1 addn1. Qed.

Lemma size_rec1up n : size (rec1up n) = n.+1.
Proof. by rewrite size_rev size_rec1down. Qed.

Variable d : T.

Lemma head_loop1S n s a p :
  head d s = a ->
  head d (loop1 n.+1 p a s) = F (head d (loop1 n p a s)) (n+p).
Proof.
by elim: n s a p => [_ _ _->//|n IHn s a p H]; rewrite !IHn // addSnnS.
Qed.

Theorem head_loop1 (n p : nat) a s :
  head d s = a ->
  head d (loop1 n p a s) = iteri n (fun i c => F c (i + p)) a.
Proof.
elim: n p a s =>[//|n IHn] p a s H.
move E: (n.+1) => n'.
rewrite /= -{}E IHn //.
clear; elim: n =>[//=|n IHn].
by rewrite /= IHn /= addSnnS.
Qed.

Lemma head_rec1downS n :
  head d (rec1down n.+1) = F (head d (rec1down n)) n.+1.
Proof. by rewrite head_loop1S ?addn1. Qed.

Lemma nth_rec1up_last k : nth d (rec1up k) k = last d (rec1up k).
Proof. by rewrite (last_nth d) size_rec1up. Qed.

Lemma last_rec1up k : last d (rec1up k) = head d (loop1 k 1 a0 [:: a0]).
Proof. by rewrite /rec1up /rec1down last_rev. Qed.

Lemma nth_rec1upS k :
  nth d (rec1up k.+1) k.+1 = F (nth d (rec1up k) k) k.+1.
Proof. by rewrite !nth_rec1up_last !last_rev head_rec1downS. Qed.

Lemma loop1S_ex n p a s :
  exists c, loop1 n.+1 p a s = c :: (loop1 n p a s).
Proof.
elim: n p a s=> [|n IH] p a s; first by exists (F a p).
remember (S n) as n'; simpl.
case: (IH p.+1 (F a p) (F a p :: s))=> [c Hc].
rewrite Hc {}Heqn' /=.
by exists c.
Qed.

Lemma behead_rec1down n : behead (rec1down n.+1) = rec1down n.
Proof. by rewrite /rec1down; case: (loop1S_ex n 1 a0 [:: a0])=> [c ->]. Qed.

Lemma nth_rec1downD d1 p q n :
  nth d1 (rec1down (p+q+n)) (p+q) = nth d1 (rec1down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_rec1down.
Qed.

Lemma nth_rec1downD_dflt2 d1 d2 p q n :
  nth d1 (rec1down (p+q+n)) (p+q) = nth d2 (rec1down (p+n)) p.
Proof.
rewrite nth_rec1downD (nth_defaults d1 d2) // size_rec1down.
by iomega.
Qed.

Lemma nth_rec1down_indep d1 d2 m1 m2 n :
  n <= m1 -> n <= m2 ->
  nth d1 (rec1down m1) (m1 - n) = nth d2 (rec1down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm; last first.
- by rewrite Hm (nth_defaults d1 d2) // size_rec1down; iomega.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n by rewrite -Hpq subnK.
  exact: nth_rec1downD_dflt2.
set p := m1 - n in h1' *.
rewrite -h1' addnC.
pose q := m2 - m1.
have Hpq : m2 - n = p + q.
  rewrite /p /q in h2' *.
  by rewrite addnC addnBA // subnK // ltnW.
rewrite Hpq.
have->: m2 = p + q + n by rewrite -Hpq subnK.
symmetry; exact: nth_rec1downD_dflt2.
Qed.

Lemma nth_rec1up_indep d1 d2 m1 m2 n :
  n <= m1 -> n <= m2 ->
  nth d1 (rec1up m1) n = nth d2 (rec1up m2) n.
Proof.
move=> h1 h2.
rewrite !nth_rev; first last.
- by rewrite size_loop1 /=; move: h1 h2; iomega_le.
- by rewrite size_loop1 /=; move: h1 h2; iomega_le.
rewrite !size_loop1 /= !addn1 !subSS.
exact: nth_rec1down_indep.
Qed.

Theorem nth_rec1up n k :
  nth d (rec1up n) k =
  if n < k then d
  else iteri k (fun i c => F c (i + 1)) a0.
Proof.
case: (ltnP n k) => H; first by rewrite nth_default // size_rec1up.
rewrite (@nth_rec1up_indep d d n k k) //.
by rewrite nth_rec1up_last last_rec1up head_loop1.
Qed.

(** For the base case *)

Lemma rec1down_co0 n: nth d (rec1down n) n = a0.
Proof.
elim: n=> [//|n IH].
by rewrite /rec1down; have [c ->] := loop1S_ex n 1 a0 [:: a0].
Qed.

Lemma rec1up_co0 n : nth d (rec1up n) 0 = a0.
Proof. by rewrite nth_rev size_rec1down // subn1 rec1down_co0. Qed.

End Defix1.

Section GenDefix1.

Variables A T : Type.

Variable F : A -> nat -> A. (* may involve symbolic differentiation *)
(** to be instantiated by a function satisfying a(n+1)=F(a(n),n+1). *)

Variable G : A -> nat -> T.
(** to be instantiated by a function satisfying u(N+n)=G(a(n),N+n).
Here, N is the size of the list [init]. *)

Fixpoint gloop1 (n p : nat) (a : A) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let r := G a p in
              let p1 := p.+1 in
              let c := F a p1 in gloop1 m p1 c (r :: s)
  end.

Variable a0 : A.

Variable init : seq T.
(** Remark: [init] can be nil *)

Definition grec1down n :=
  if (n.+1 - size init) is n'.+1
    then gloop1 n'.+1 (size init) a0 (rev init)
    else rev (take n.+1 init).

Lemma grec1downE (n : nat) :
  grec1down n =
  if n >= size init
    then gloop1 (n - size init).+1 (size init) a0 (rev init)
    else rev (take n.+1 init).
Proof.
rewrite /grec1down.
case: (leqP (size init) n)=>H; first by rewrite subSn //.
by move: H; rewrite -subn_eq0; move/eqP->.
Qed.

Definition grec1up n := rev (grec1down n).

Lemma size_gloop1 n p a s : size (gloop1 n p a s) = n + size s.
Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed.

Lemma size_grec1down n : size (grec1down n) = n.+1.
Proof.
rewrite /grec1down.
case E: (n.+1 - size init) =>[|k].
  rewrite size_rev size_take.
  move/eqP: E; rewrite subn_eq0 leq_eqVlt.
  case/orP; last by move->.
  move/eqP->; rewrite ifF //.
  by rewrite ltnn.
rewrite size_gloop1 /= -E.
by rewrite size_rev subnK // ltnW // -subn_gt0 E.
Qed.

Lemma size_grec1up n : size (grec1up n) = n.+1.
Proof. by rewrite size_rev size_grec1down. Qed.

Theorem grec1up_init n :
  n < size init ->
  grec1up n = take n.+1 init.
Proof. by rewrite /grec1up /grec1down -subn_eq0; move/eqP ->; rewrite revK. Qed.

Theorem last_grec1up (d : T) (n : nat) :
  size init <= n ->
  last d (grec1up n) =
  head d (gloop1 (n - size init).+1 (size init) a0 (rev init)).
Proof. by move=> Hn; rewrite /grec1up /grec1down subSn // last_rev. Qed.

Theorem head_gloop1 (d : T) (n p : nat) (a : A) (s : seq T):
  head d (gloop1 n.+1 p a s) = G (iteri n (fun i c => F c (i + p).+1) a) (n + p).
Proof.
elim: n p a s =>[//|n IHn] p a s.
move E: (n.+1) => n'.
rewrite /= -{}E IHn.
congr G; last by rewrite addSnnS.
clear; elim: n =>[//=|n IHn].
by rewrite /= IHn /= addSnnS.
Qed.

Lemma gloop1S_ex n p a s :
  exists c, gloop1 n.+1 p a s = c :: (gloop1 n p a s).
Proof.
elim: n p a s => [|n IH] p a s; first by exists (G a p).
remember (S n) as n'; simpl.
case: (IH p.+1 (F a p.+1) (G a p :: s))=> [c Hc].
rewrite Hc {}Heqn' /=.
by exists c.
Qed.

Theorem behead_grec1down (n : nat) :
  behead (grec1down n.+1) = grec1down n.
Proof.
pose s := rev init.
pose m := size init.
rewrite !grec1downE.
case: (leqP (size init) n) => H.
  rewrite leqW // subSn //.
  have [c Hc] := gloop1S_ex (n - m).+1 m a0 s.
  by rewrite Hc.
rewrite leq_eqVlt in H; case/orP: H; [move/eqP|] => H.
  rewrite -H subnn /= ifT H //.
  by rewrite take_oversize.
rewrite ifF 1?leqNgt ?H //.
by rewrite behead_rev_take.
Qed.

Lemma nth_grec1downD d1 p q n:
  nth d1 (grec1down (p+q+n)) (p+q) = nth d1 (grec1down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_grec1down.
Qed.

Lemma nth_grec1downD_dflt2 d1 d2 p q n:
  nth d1 (grec1down (p+q+n)) (p+q) = nth d2 (grec1down (p+n)) p.
Proof.
rewrite nth_grec1downD (set_nth_default d1 d2) //.
by rewrite size_grec1down ltnS leq_addr.
Qed.

Theorem nth_grec1down_indep (d1 d2 : T) (m1 m2 n : nat) :
  n <= m1 -> n <= m2 ->
  nth d1 (grec1down m1) (m1 - n) = nth d2 (grec1down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm.
- set p := m1 - n in h1' *.
  rewrite -h1' addnC.
  pose q := m2 - m1.
  have Hpq : m2 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m2 = p + q + n.
    by rewrite -Hpq subnK.
  symmetry; exact: nth_grec1downD_dflt2.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n.
    by rewrite -Hpq subnK.
  exact: nth_grec1downD_dflt2.
- rewrite Hm (nth_defaults d1 d2) // size_grec1down.
  exact: leq_ltn_trans (@leq_subr n m2) _.
Qed.

Theorem nth_grec1up_indep (d1 d2 : T) (m1 m2 n : nat) :
  n <= m1 -> n <= m2 ->
  nth d1 (grec1up m1) n = nth d2 (grec1up m2) n.
Proof.
move=> h1 h2; rewrite !nth_rev; try by rewrite size_grec1down.
rewrite !size_grec1down !subSS; exact: nth_grec1down_indep.
Qed.

Arguments nth_grec1up_indep [d1 d2 m1 m2 n] _ _.

Lemma nth_grec1up_last (d : T) k : nth d (grec1up k) k = last d (grec1up k).
Proof. by rewrite (last_nth d) size_grec1up. Qed.

Theorem nth_grec1up d n k :
  nth d (grec1up n) k =
  if n < k then d
  else
    if k < size init then nth d init k
    else G (iteri (k - size init) (fun i c => F c (i + size init).+1) a0) k.
Proof.
case: (ltnP n k) => H; first by rewrite nth_default // size_grec1up.
rewrite (nth_grec1up_indep (d2 := d) (m2 := k)) //.
case: (ltnP k (size init)) => H'; first by rewrite grec1up_init // nth_take.
rewrite nth_grec1up_last last_grec1up // head_gloop1; congr G.
by rewrite subnK.
Qed.

Arguments nth_grec1up [d] n k.

End GenDefix1.

Section Defix2.

Variable T : Type.

Variable F : T -> T -> nat -> T.
(** to be instantiated by a function satisfying u(n) = F(u(n-2), u(n-1), n). *)

Fixpoint loop2 (n p : nat) (a b : T) (s : seq T) {struct n} : seq T :=
  match n with
    | 0 => s
    | m.+1 => let c := F a b p in loop2 m p.+1 b c (c :: s)
  end.

Variables a0 a1 : T.

Definition rec2down n :=
  if n is n'.+1 then (loop2 n' 2 a0 a1 [:: a1; a0]) else [:: a0].

Definition rec2up n := rev (rec2down n).

Lemma size_loop2 n p a b s : size (loop2 n p a b s) = n + size s.
Proof. by elim: n p a b s => [//|n IHn] *; rewrite IHn !addSnnS. Qed.

Lemma size_rec2down n : size (rec2down n) = n.+1.
Proof. by case: n => [//|[//|n]]; rewrite size_loop2 addn2. Qed.

Lemma size_rec2up n : size (rec2up n) = n.+1.
Proof. by rewrite size_rev size_rec2down. Qed.

Variable d : T.

Lemma head_loop2S n s a b p :
  hb d s = a -> head d s = b ->
  let s' := (loop2 n p a b s) in
  head d (loop2 n.+1 p a b s) = F (hb d s') (head d s') (n+p).
Proof.
elim: n s a b p => [|n IHn] s a b p Ha Hb; first by rewrite /= Ha Hb.
by rewrite IHn // addSnnS.
Qed.

Lemma head_rec2downSS n :
  head d (rec2down n.+2) =
  F (hb d (rec2down n.+1)) (head d (rec2down n.+1)) n.+2.
Proof. by case: n => [//|n]; rewrite head_loop2S ?addn2. Qed.

Lemma behead_loop2 n s a b p : behead (loop2 n.+1 p a b s) = loop2 n p a b s.
Proof. by elim: n s a b p => [//|n IHn] s a b p; rewrite IHn. Qed.

Lemma behead_rec2down n : behead (rec2down n.+1) = rec2down n.
Proof. by case: n => [//|n]; rewrite behead_loop2. Qed.

(* Let coa k := nth d (rec2up k) k.
Let coa' k := last d (rec2up k). *)

Lemma nth_rec2up_last k : nth d (rec2up k) k = last d (rec2up k).
Proof. by case: k => [//|k]; rewrite (last_nth d) size_rec2up. Qed.

Theorem last_rec2up k :
  last d (rec2up k.+1) = head d (loop2 k 2 a0 a1 [:: a1; a0]).
Proof. by rewrite /rec2up /rec2down last_rev. Qed.

Lemma nth_rec2downSS' k :
  nth d (rec2down k.+2) 0 =
  F (nth d (rec2down k) 0) (nth d (rec2down k.+1) 0) k.+2.
Proof. by rewrite !nth0 -[rec2down k]behead_rec2down head_rec2downSS. Qed.

Lemma nth_rec2upSS' k :
  nth d (rec2up k.+2) k.+2 =
  F (nth d (rec2up k) k) (nth d (rec2up k.+1) k.+1) k.+2.
Proof.
by rewrite /rec2up !nth_rev ?size_rec2down // !subnn nth_rec2downSS'.
Qed.

Lemma nth_rec2downD d1 p q n :
  nth d1 (rec2down (p+q+n)) (p+q) = nth d1 (rec2down (p+n)) p.
Proof.
elim: q=> [|q IH]; first by rewrite addn0.
by rewrite !addnS addSn -nth_behead behead_rec2down.
Qed.

Lemma nth_rec2downD_dflt2 d1 d2 p q n :
  nth d1 (rec2down (p+q+n)) (p+q) = nth d2 (rec2down (p+n)) p.
Proof.
rewrite nth_rec2downD (nth_defaults d1 d2) // size_rec2down.
by iomega.
Qed.

Lemma nth_rec2down_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 ->
  nth d1 (rec2down m1) (m1 - n) = nth d2 (rec2down m2) (m2 - n).
Proof.
move=> h1 h2.
have h1' := subnKC h1; have h2' := subnKC h2.
case: (ltngtP m1 m2)=> Hm; last first.
- rewrite Hm (nth_defaults d1 d2) //.
  by rewrite size_rec2down; iomega.
- set p := m2 - n in h2' *.
  rewrite -h2' addnC.
  pose q := m1 - m2.
  have Hpq : m1 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m1 = p + q + n by rewrite -Hpq subnK.
  exact: nth_rec2downD_dflt2.
- set p := m1 - n in h1' *.
  rewrite -h1' addnC.
  pose q := m2 - m1.
  have Hpq : m2 - n = p + q.
    rewrite /p /q in h2' *.
    by rewrite addnC addnBA // subnK // ltnW.
  rewrite Hpq.
  have->: m2 = p + q + n by rewrite -Hpq subnK.
symmetry; exact: nth_rec2downD_dflt2.
Qed.

Lemma nth_rec2up_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 ->
  nth d1 (rec2up m1) n = nth d2 (rec2up m2) n.
Proof.
move=> h1 h2.
rewrite !nth_rev; first last.
- by rewrite size_rec2down /=; move: h1 h2; iomega_le.
- by rewrite size_rec2down /=; move: h1 h2; iomega_le.
rewrite !size_rec2down /= !subSS.
exact: nth_rec2down_indep.
Qed.

End Defix2.

Section RecZ.

(* Helper functions to compute
[1/0!; p/1!; ...; p*(p-1)*...*(p-n+1)/n!] *)

Definition fact_rec (a : Z) (n : nat) : Z := Z.mul a (Z.of_nat n).
Definition fact_seq := rec1up fact_rec 1%Z.

Theorem fact_seq_correct (d : Z) (n k : nat) :
  k <= n ->
  nth d (fact_seq n) k = Z.of_nat (fact k).
Proof.
elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0.
move/(_ (ltnW Hkn)) in IHk.
move: IHk.
rewrite /fact_seq.
rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn.
move => IHk.
rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //.
rewrite nth_rec1upS IHk /fact_rec.
rewrite fact_simpl.
zify; ring.
Qed.

Lemma size_fact_seq n : size (fact_seq n) = n.+1.
Proof. by rewrite size_rec1up. Qed.

Definition falling_rec (p : Z) (a : Z) (n : nat) : Z :=
  (a * (p - (Z.of_nat n) + 1))%Z.
Definition falling_seq (p : Z) := rec1up (falling_rec p) 1%Z.

Canonical Zmul_monoid := Monoid.Law Z.mul_assoc Z.mul_1_l Z.mul_1_r.

Theorem falling_seq_correct (d : Z) (p : Z) (n k : nat) :
  k <= n ->
  nth d (falling_seq p n) k =
  \big[Z.mul/1%Z]_(0 <= i < k) (p - Z.of_nat i)%Z.
Proof.
elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0 big_mkord big_ord0.
move/(_ (ltnW Hkn)) in IHk.
move: IHk.
rewrite /falling_seq.
rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn.
move => IHk.
rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //.
rewrite nth_rec1upS IHk /falling_rec.
rewrite big_nat_recr //=.
congr Z.mul.
zify; ring.
Qed.

Lemma size_falling_seq p n : size (falling_seq p n) = n.+1.
Proof. by rewrite size_rec1up. Qed.

End RecZ.

(** Refinement proofs for rec1, rec2, grec1 *)

Section rec_proofs.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Hypothesis H0 : Rel dv dt.
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).

Lemma grec1up_correct (A := seq V) Fi (F : A -> nat -> A) Gi (G : A -> nat -> V) ai a si s n :
  (forall qi q m, RelP q qi -> RelP (F q m) (Fi qi m)) ->
  (forall qi q m, RelP q qi -> Rel (G q m) (Gi qi m)) ->
  RelP a ai ->
  RelP s si ->
  size s = size si ->
  RelP (grec1up F G a s n) (grec1up Fi Gi ai si n).
Proof.
move=> HF HG Ha Hs Hsize k.
pose s1 := (size (grec1up F G a s n)).-1.
case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_grec1up.
have H1 : k = (size (grec1up F G a s k)).-1 by rewrite size_grec1up.
have H2 : k = (size (grec1up Fi Gi ai si k)).-1 by rewrite size_grec1up.
rewrite ?(@nth_grec1up_indep _ _ _ _ _ _ dv dv n k k)
  ?(@nth_grec1up_indep _ _ _ _ _ _ dt dt n k k) //.
case: (ltnP k (size s)) => Hk.
- have Hki : k < size si by rewrite -Hsize.
  rewrite ?(grec1up_init _ _ _ Hk, grec1up_init _ _ _ Hki) ?nth_take_dflt ltnn.
  exact: Hs.
- have Hki : size si <= k by rewrite -Hsize.
  rewrite {4}H2 {2}H1 !nth_last !last_grec1up ?head_gloop1 // Hsize.
  apply: HG => j; set l := k - size si.
  elim: l j => [|l IHl] j /=; by [apply: Ha | apply: HF; apply: IHl].
Qed.

Lemma rec1up_correct fi f fi0 f0 n :
  (forall ai a m, Rel a ai -> Rel (f a m) (fi ai m)) ->
  Rel f0 fi0 ->
  RelP (rec1up f f0 n) (rec1up fi fi0 n).
Proof.
move=> Hf Hf0 k.
case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_rec1up.
have H1 : k = (size (rec1up f f0 k)).-1 by rewrite size_rec1up.
have H2 : k = (size (rec1up fi fi0 k)).-1 by rewrite size_rec1up.
rewrite (@nth_rec1up_indep _ _ _ dv dv n k k) //
        (@nth_rec1up_indep _ _ _ dt dt n k k) //.
rewrite !(nth_rec1up_last, last_rec1up).
rewrite !head_loop1 //.
elim: k Hnk {H1 H2} => [|k IHk] Hnk //=.
apply: Hf; apply: IHk; exact: ltnW.
Qed.

Lemma rec2up_correct fi f fi0 f0 fi1 f1 n :
  (forall ai bi a b m, Rel a ai -> Rel b bi -> Rel (f a b m) (fi ai bi m)) ->
  Rel f0 fi0 ->
  Rel f1 fi1 ->
  RelP (rec2up f f0 f1 n) (rec2up fi fi0 fi1 n).
Proof.
move=> Hf Hf0 Hf1 k.
case: (ltnP n k) => Hn; first by rewrite !nth_default ?size_rec2up.
have H1 : k = (size (rec2up f f0 f1 k)).-1 by rewrite size_rec2up.
have H2 : k = (size (rec2up fi fi0 fi1 k)).-1 by rewrite size_rec2up.
rewrite (@nth_rec2up_indep _ _ _ _ dv dv n k k) //
        (@nth_rec2up_indep _ _ _ _ dt dt n k k) //.
case: k Hn {H1 H2} => [//|k] Hn.
rewrite !(nth_rec2up_last, last_rec2up).
elim: k {-2}k (leqnn k) Hn => [|k IHk] k' Hk' Hn.
- by rewrite leqn0 in Hk'; move/eqP: Hk'->.
- rewrite leq_eqVlt in Hk'; case/orP: Hk'=> Hk'; last exact: IHk =>//.
  move/eqP: (Hk')->; rewrite !head_loop2S //; apply: Hf.
  + case: k IHk Hn Hk' => [|k] IHk Hn Hk' //.
    rewrite /hb !behead_loop2.
    apply: IHk =>//.
    move/eqP in Hk'; rewrite Hk' in Hn; apply: ltnW; exact: ltnW.
  + apply: IHk =>//.
    move/eqP in Hk'; rewrite Hk' in Hn; exact: ltnW.
Qed.

End rec_proofs.


Require Import init.

Require Import analysis_topology.

(* begin hide *)
Section IVT.

Existing Instance real_order_topology.
Existing Instance subspace_topology.
(* end hide *)
(* TODO: Make the domain of this better *)
Theorem real_ivt : ∀ f : real → real, continuous f →
    ∀ a b r, a < b → f a < r → r < f b → ∃ c, f c = r ∧ a ≤ c ∧ c ≤ b.
Proof.
    intros f f_cont a b r ab r_gt r_lt.
    pose (S := closed_interval a b).
    pose (g (x : set_type S) := f [x|]).
    assert (continuous g) as g_cont.
    {
        unfold g.
        apply comp_continuous.
        -   intros x A [A_open Ax].
            exists (λ x, A [x|]).
            split.
            +   split.
                *   exists A.
                    split; try exact A_open.
                    reflexivity.
                *   exact Ax.
            +   intros y y_in.
                destruct y_in as [y' [Ay' y_eq]].
                rewrite y_eq.
                exact Ay'.
        -   exact f_cont.
    }
    assert (closed_interval a b a) as a_in.
    {
        split.
        -   apply refl.
        -   apply ab.
    }
    assert (closed_interval a b b) as b_in.
    {
        split.
        -   apply ab.
        -   apply refl.
    }
    pose proof (ivt
        (closed_interval_connected a b)
        g
        g_cont
        [a|a_in]
        [b|b_in]
        r
        r_gt
        r_lt
    ) as [[c [c_gt c_lt]] eq].
    exists c.
    repeat split; assumption.
Qed.
(* begin hide *)
End IVT.
(* end hide *)


CoInductive Tree (A : Type) : Type :=
{
  root  : A;
  trees : TreeStream A;
}

with TreeStream (A : Type) : Type :=
{
  hd : Tree A;
  tl : TreeStream A;
}.

Arguments root  {A} _.
Arguments trees {A} _.

Arguments hd {A} _.
Arguments tl {A} _.

CoFixpoint stmap {A B : Type} (f : A -> B) (t : Tree A) : Tree B :=
{|
  root  := f (root t);
  trees := smap f (trees t);
|}

with smap {A B : Type} (f : A -> B) (s : TreeStream A) : TreeStream B :=
{|
  hd := stmap f (hd s);
  tl := smap  f (tl s);
|}.

CoInductive TreeStreamSim {A : Type} (TS : Tree A -> Tree A -> Type) (s1 s2 : TreeStream A) : Type :=
{
  hds : TS (hd s1) (hd s2);
  tls : TreeStreamSim TS (tl s1) (tl s2);
}.

CoInductive TreeSim {A : Type} (t1 t2 : Tree A) : Type :=
{
  roots  : root t1 = root t2;
  treess : TreeStreamSim TreeSim (trees t1) (trees t2);
}.

Fail CoInductive TreeSim {A : Type} (t1 t2 : Tree A) : Type :=
{
  roots  : root t1 = root t2;
  treess : TreeStreamSim (trees t1) (trees t2);
}

with TreeStreamSim {A : Type} (s1 s2 : TreeStream A) : Type :=
{
    hds : TreeSim (hd s1) (hd s2);
    tls : TreeStreamSim (tl s1) (tl s2);
}.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* ** Object-level encoding of bounded universal quantification II *)

Require Import Arith List Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums bool_nat.

From Undecidability.H10.Matija
  Require Import cipher.

From Undecidability.H10.Dio
  Require Import dio_logic dio_expo dio_binary.

Set Implicit Arguments.

Local Infix "≲" := binary_le (at level 70, no associativity).
Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).
Local Infix "⇣" := nat_meet (at level 40, left associativity).
Local Infix "⇡" := nat_join (at level 50, left associativity).

(* seqs_of_ones l q u u1 iff

            l+1 < q
       and  u  = ∑(i<l) r^(2^(1+i))
       and  u1 = ∑(i<l) r^(2^(2+i))
       with r := 2^(4q)

  *)

Theorem dio_rel_seqs_of_ones l q u u1 : 𝔻F l -> 𝔻F q -> 𝔻F u -> 𝔻F u1
          -> 𝔻R (fun v => seqs_of_ones (l v) (q v) (u v) (u1 v)).
Proof.
  dio by lemma (fun v => seqs_of_ones_dio (l v) (q v) (u v) (u1 v)).
Defined.

#[export] Hint Resolve dio_rel_seqs_of_ones : dio_rel_db.

(* a is the q-cipher of some l-tuple *)

Theorem dio_rel_Code l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                          -> 𝔻R (fun v => Code (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => Code_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_Code : dio_rel_db.

(* c is the q-cipher of the l-tuple <x,...,x> *)

Theorem dio_rel_Const l q c x : 𝔻F l -> 𝔻F q -> 𝔻F c -> 𝔻F x
                             -> 𝔻R (fun v => Const (l v) (q v) (c v) (x v)).
Proof.
  dio by lemma (fun v => Const_dio (l v) (q v) (c v) (x v)).
Defined.

#[export] Hint Resolve dio_rel_Const : dio_rel_db.

(* a is the q-cipher of the l-tuple <0,...,l-1> *)

Theorem dio_rel_CodeNat l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                             -> 𝔻R (fun v => CodeNat (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => CodeNat_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_CodeNat : dio_rel_db.

(* Testing whether a is the q cipher of the sum of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_plus a b c : 𝔻F a -> 𝔻F b -> 𝔻F c
                               -> 𝔻R (fun v => Code_plus (a v) (b v) (c v)).
Proof. intros; unfold Code_plus; dio auto. Defined.

(* Testing whether a is the q cipher of the product of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_mult l q a b c : 𝔻F l -> 𝔻F q -> 𝔻F a -> 𝔻F b -> 𝔻F c
                                   -> 𝔻R (fun v => Code_mult (l v) (q v) (a v) (b v) (c v)).
Proof. intros; unfold Code_mult; dio auto. Defined.

#[export] Hint Resolve dio_rel_Code_plus dio_rel_Code_mult : dio_rel_db.

(* Now we have diophantine representations of q-cipher of the following l-tuple

    1) <x,...,x>  (for x < 2^q)
    2) <0,...,l-1>
    3) testing whether some code is a q-cipher of some tuple
    4) testing sum and product equality among q-ciphers

*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable rE_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cR_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrectangle_1 : (forall A B C D : Universe, (rE_ A B C D -> (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))))).
Variable defrectangle2_2 : (forall A B C D : Universe, ((per_ D A B /\ (per_ A B C /\ (per_ B C D /\ (per_ C D A /\ cR_ A C B D)))) -> rE_ A B C D)).
Variable lemma_rightangleNC_3 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable defcross_4 : (forall A B C D : Universe, (exists X : Universe, (cR_ A B C D -> (betS_ A X B /\ betS_ C X D)))).
Variable defcross2_5 : (forall A B C D X : Universe, ((betS_ A X B /\ betS_ C X D) -> cR_ A B C D)).
Variable defmeet_6 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_7 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable lemma_collinearorder_8 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_8_2_9 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinearright_11 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_8_7_12 : (forall A B C : Universe, (per_ C B A -> ~(per_ A C B))).
Variable lemma_NCdistinct_13 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable defcollinear_14 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_15 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_16 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_17 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_18 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_19 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_20 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable axiom_betweennesssymmetry_21 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defparallel_22 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_23 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable defparallelogram_24 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_25 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).

Theorem lemma_rectangleparallelogram_26 : (forall A B C D : Universe, (rE_ A B C D -> pG_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Definition plus (n:nat)(m:nat):nat:=n+m.

Definition id:forall(A:Type),A->A:=fun A x =>x.

Definition prop0:forall(A:Prop),A->A:=fun A x=>x.

Definition prop1:forall(A B C:Prop), (B->C)->(A->B)->(A->C) :=
 fun A B C f g x => f(g x).