(* In this file we explain how to do prove the counter specifications from
   Section 7.7 of the notes. This involves construction and manipulation of
   resource algebras, the explanation of which is the focus of this file. We
   assume the reader has experimented with coq-intro-example-1.v example, and
   thus we do not explain the features we have explained therein already. *)

From iris.program_logic Require Export weakestpre.
From iris.base_logic.lib Require Export invariants.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode.
From iris.heap_lang Require Import notation lang.
From iris.algebra Require Import numbers.
From iris.prelude Require Import options.

From iris.heap_lang.lib Require Import par.

(* The counter module definition. *)
Definition read : val := λ: "c", !"c".
Definition incr : val := rec: "incr" "c" := let: "n" := !"c" in
                                            let: "m" := #1 + "n" in
                                            if: CAS "c" "n" "m" then #() else "incr" "c".

Definition newCounter : val := λ: <>, ref #0.

Section monotone_counter.
  (* For the first example we will only give the weaker specification, as we did
     in the notes. In this specification we only know the lower bound on the
     counter value, since the isCounter predicate is freely duplicable.

     Before we start with the actual verification we will define the resource
     algebra we shall be using. The Iris library contains all the ingredients
     needed to compose this particular resource algebra from simpler components,
     however to illustrate how to define our own we will define it from scratch.

     In the subsequent section we show how to obtain an equivalent resource
     algebra from the building blocks provided by the Iris Coq library.
  *)

  (* The carrier of our resource algebra is the set ℕ_{⊥,⊤} × ℕ. NBT (Natural
     numbers with Top and Bottom) is the first component of this product. We
     wrap the project into a record to avoid ambiguous type class search. *)
  Inductive NBT :=
    Bot : NBT (* Bottom *)
  | Top : NBT (* Top *)
  | NBT_incl : nat → NBT. (* Inclusion of natural numbers into our new type. *)

  (* The carrier of our RA. *)
  Record mcounterRAT := MCounter { mcounter_auth : NBT; mcounter_flag : nat }.

  (* The notion of a resource algebra as used in Iris is more general than the one
     currently described. It is called a cmra (standing roughly for complete
     metric resource algebra). For most verification purposes it is not
     important what that is. It is a step-indexed generalization of the resource
     algebra we have described in Section 7. The main difference is that the
     carrier is not simply a set, but comes equipped with a set of equivalence
     relations indexed by natural numbers (the "step-indices").

     The notion we have defined in Section 7 is that of a "discrete" CMRA. There
     is special support in the library for such CMRAs, and that is why in the
     remainder of this file we will often use, e.g., special lemmas for discrete
     CMRAs.
   *)

  (*
     To tell Coq we wish to use such a discrete CMRA we use the constructor leibnizO.
     This takes a Coq type and makes it an instance of an OFE (a step-indexed generalization of sets).
     This is not the place do describe Canonical Structures.
     A very good introduction is available at https://hal.inria.fr/hal-00816703v1/document
  *)
  Canonical Structure mcounterRAC := leibnizO mcounterRAT.

  (* To make the type mcounterRAT into an RA we need an operation. This is
     defined in the standard way, except we use the typeclass Op so we can reuse
     a lot of the notation mechanism (we can write x ⋅ y for the operation), and
     some other infrastucture and generic lemmas. *)
  Instance mcounterRAop : Op mcounterRAT :=
    λ '(MCounter x n) '(MCounter y m),
    match x with
      Bot => MCounter y (max n m)
    | _ => match y with
             Bot => MCounter x (max n m)
           | _ => MCounter Top (max n m)
           end
    end.

  (* The set of valid elements. Valid A is simply abbreviation for A → Prop,
     i.e., for the set of subsets of A. Importantly Valid is a typeclass, and
     thus we make our definition an instance of it. This will enable the Coq
     typeclass search and various interactive proof mode tactics automatically
     deal with many boring use cases. *)
  Instance mcounterRAValid : Valid mcounterRAT :=
    λ x, match x with
           MCounter Bot _ => True
         | MCounter (NBT_incl x) m => x ≥ m
         | _ => False
         end.

  (* The core of the RA. PCore stands for "partial core", and is an abbreviation
     for a partial function, which in Coq is encoded as a function from A →
     option A. Again, PCore is a typeclass for better automation support, and
     thus our definition is an instance. *)
  Instance mcounterRACore : PCore mcounterRAT :=
    λ '(MCounter _ n), Some (MCounter Bot n).

  (* We can then package these definitions up into an RA structure, used by the
     Iris library. *)

  (* We need these auxiliary lemmas in the proof below.
     We need the type  annotation to guide the type inference. *)
  Lemma mcounterRA_op_second (x y : NBT) n m :
    ∃ z, MCounter x n ⋅ MCounter y m = MCounter z (max n m).
  Proof.
    destruct x as [], y as []; eexists; unfold op, mcounterRAop; simpl; auto.
  Qed.

  Lemma mcounterRA_included_aux x y (n m : nat) :
    MCounter x n ≼ MCounter y m → (n ≤ m)%nat.
  Proof.
    intros [[z k] [=H]].
    revert H.
    destruct (mcounterRA_op_second x z n k) as [? ->].
    inversion 1; subst; auto with arith.
  Qed.

  Lemma mcounterRA_included_frag (n m : nat) :
    MCounter Bot n ≼ MCounter Bot m ↔ (n ≤ m)%nat.
  Proof.
    split.
    - apply mcounterRA_included_aux.
    - intros H%Max.max_r; exists (MCounter Bot m); unfold op, mcounterRAop; rewrite H; auto.
  Qed.

  Lemma mcounterRA_valid x (n : nat): ✓ (MCounter (NBT_incl x) n) ↔ (n ≤ x)%nat.
  Proof.
    split; auto.
  Qed.

  (* An RAMixin is a structure which combines all the parts of an RA into one
     Coq structure, together with all the properties that the operations and
     functions satisfy. *)
  Definition mcounterRA_mixin : RAMixin mcounterRAT.
  Proof.
    split; try apply _; try done.
    - unfold valid, op, mcounterRAop, mcounterRAValid. intros ? ? cx -> ?; exists cx. done.
    (* The operation is associative. *)
    - unfold op, mcounterRAop. intros [[]] [[]] [[]]; rewrite !Nat.max_assoc; reflexivity.
    (* The operation is commutative. *)
    - unfold op, mcounterRAop. intros [[]] [[]]; rewrite Nat.max_comm; reflexivity.
    (* Core axioms. *)
    - unfold pcore, mcounterRACore, op, mcounterRAop; intros [[]] [[]] [=->]; rewrite Max.max_idempotent; auto.
    - unfold pcore, mcounterRACore, op, mcounterRAop; intros [[]] [[]] [=->]; auto.
    - unfold pcore, mcounterRACore, op, mcounterRAop.
      intros [x n] [y m] cx Hleq%mcounterRA_included_aux [=<-].
      exists (MCounter Bot m); split; first auto.
      by apply mcounterRA_included_frag.
    - (* Validity axiom: validity is down-closed with respect to the extension order. *)
      intros [[]].
      + reflexivity.
      + unfold op, mcounterRAop; intros [[]] [].
      + unfold op, mcounterRAop; intros [[]].
        * rewrite !mcounterRA_valid. eauto with arith.
        * intros [].
        * intros [].
  Qed.

  (* We finally wrap the type and the above mixin and make the structure
  available for typeclass search. The discreteR is a wrapper for when our CMRA is
  "discrete" as described above. *)
  Canonical Structure mcounterRA := discreteR mcounterRAT mcounterRA_mixin.

  (* Some tactics and lemmas only apply for discrete CMRAs (what we called RAs).
     To be able to use these we need to register our CMRA as a discrete one, to
     make this information available to typeclass search. *)
  Instance mcounterRA_cmra_discrete : CmraDiscrete mcounterRA.
  Proof. apply discrete_cmra_discrete. Qed.

  (* A total CMRA (or RA) is the one where the core operation is a total
     function, i.e., the core of every element is defined. Some properties and
     lemmas only apply for such CMRAs, and so we register the fact that our CMRA
     is of this form.
   *)
  Instance mcounterRA_cmra_total : CmraTotal mcounterRA.
  Proof. intros [[]]; eauto. Qed.

  (* We define some abbreviation. We only define it as notation in this section
     since the same notation is already defined for the general authoritative RA
     construction in the Iris Coq library.
   *)
  Local Notation "◯ n" := (MCounter Bot n%nat) (at level 20).
  Local Notation "● m" := (MCounter (NBT_incl m%nat) 0%nat) (at level 20).

  (* We now prove the three properties we claim were required from the resource
     algebra in Section 7.7.
   *)
  (* CoreId x states that the core of x is x, which is one of the properties we claimed for the
     fragments. CoreId is a typeclass. *)
  Instance mcounterRA_frag_core (n : nat): CoreId (◯ n).
  Proof.
    rewrite /CoreId; reflexivity.
  Qed.

  Lemma mcounterRA_valid_auth_frag m n: ✓ (● m ⋅ ◯ n) ↔ (n ≤ m)%nat.
  Proof.
    apply mcounterRA_valid.
  Qed.

  Lemma mcounterRA_update m n: ((● m ⋅ ◯ n) : mcounterRA) ~~> (● (1 + m) ⋅ ◯ (1 + n)).
  Proof.
    (* Use the specialized definition of update, since our RA is a nice one. *)
    apply cmra_discrete_update.
    intros [[] k].
    - rewrite /op /cmra_op !mcounterRA_valid; lia.
    - intros [].
    - intros [].
  Qed.

  (* We now need to tell Coq to use our RA as one of the RA's in the instantiation of Iris. *)
  (* This is achieved via the subG constructor. All of this is boilerplate, so
     the proofs are trivial, with the tactics provided by the library. *)
  Class mcounterG Σ := MCounterG { mcounter_inG :> inG Σ mcounterRA }.
  Definition mcounterΣ : gFunctors := #[GFunctor mcounterRA].

  Instance subG_mcounterΣ {Σ} : subG mcounterΣ Σ → mcounterG Σ.
  Proof. solve_inG. Qed.

  (* We can now verify the programs. *)
  (* We start off as in the previous example, with some boilerplate code. *)
  Context `{!heapGS Σ, !mcounterG Σ} (N : namespace).
  Notation iProp := (iProp Σ).

  (* The counter invariant as defined in the notes. The only difference is that
     we are using the namespace N for the invariant, instead of existentially
     quantifying the invariant name. *)
  Definition counter_inv (ℓ : loc) (γ : gname) : iProp := (∃ (m : nat), ℓ ↦ #m ∗ own γ (● m))%I.

  (* the isCounter predicate as in the notes. *)
  Definition isCounter (ℓ : loc) (n : nat) : iProp :=
    (∃ γ, own γ (◯ n) ∗ inv N (counter_inv ℓ γ))%I.

  (* isCounter is a persistent predicate. This is needed so we can share it among threads. *)
  (* We first need an auxiliary lemma, which tells Coq that ownership of fragments is persistent.
     This follows from the persistently-core axiom of the logic.
     Instead of proving this as a lemma we make it an instance of the Persistent class.
     This way Coq will be able to infer automatically whenever it needs the fact
     that ownership of fragments is persistent.
   *)
  Instance ownFrac_persistent γ n: Persistent (own γ (◯ n)).
  Proof.
   apply own_core_persistent, _.
  Qed.

  (* Now the proof of the main counter predicate is simple: Coq's typeclass
     search can automatically deduce that isCounter is persistent. It knows the
     closure properties of persistent propositions, e.g., existential
     quantification over a persistent predicate is persistent, and it knows that
     invariants are persistent. The final part it needs is that own γ (◯ n) is
     persistent, and we have just taught it that in the preceding lemma. *)
  Instance isCounter_persistent ℓ n: Persistent (isCounter ℓ n).
  Proof.
    apply _.
  Qed.

  (* We can now perform the main proofs. They are not very different from the
     proofs we have done previously. *)
  Lemma newCounter_spec: {{{ True }}} newCounter #() {{{ v, RET #v; isCounter v 0 }}}.
  Proof.
    iIntros (Φ) "_ HCont".
    rewrite /newCounter.
    wp_lam.
    (* We allocate ghost state using the rule/lemma own_alloc. Since the
       conclusion of the rule is under a modality we wrap the application of
       this lemma with the call to the iMod tactic, which takes care of the
       bookkeeping, using the primitive rules of the modality.
       In this case the tactic knows that |==> WP ... implies WP ... and thus removes it from the goal.
     *)
    iMod (own_alloc (● 0 ⋅ ◯ 0)) as (γ) "[HAuth HFrac]".
    - apply mcounterRA_valid_auth_frag; auto. (* NOTE: We use the validity property of the RA we have constructed. *)
    - wp_alloc ℓ as "Hpt".
      (* We now allocate an invariant. *)
      iMod (inv_alloc N _ (counter_inv ℓ γ) with "[Hpt HAuth]") as "HInv".
      + iExists 0%nat; iFrame.
      + iApply ("HCont" with "[HFrac HInv]").
        iExists γ; iFrame.
  Qed.

  (* The read method specification. *)
  Lemma read_spec ℓ n: {{{ isCounter ℓ n }}} read #ℓ {{{ m, RET #m; ⌜n ≤ m⌝%nat }}}.
  Proof.
    iIntros (Φ) "HCounter HCont".
    iDestruct "HCounter" as (γ) "[HOwnFrag HInv]".
    rewrite /read.
    wp_lam.
    iInv N as (m) ">[Hpt HOwnAuth]" "HClose".
    wp_load.
    (* NOTE: We use the validity property of the RA we have constructed. From the fact that we own
             ◯ n and ● m to conclude that n ≤ m. *)
    iDestruct (own_valid_2 with "HOwnAuth HOwnFrag") as %H%mcounterRA_valid_auth_frag.
    iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
    { iNext; iExists m; iFrame. }
    iModIntro.
    iApply "HCont"; done.
  Qed.

  (* The read method specification. *)
  Lemma incr_spec ℓ n: {{{ isCounter ℓ n }}} incr #ℓ {{{ RET #(); isCounter ℓ (1 + n)%nat }}}.
  Proof.
    iIntros (Φ) "HCounter HCont".
    iDestruct "HCounter" as (γ) "[HOwnFrag #HInv]".
    iLöb as "IH".
    rewrite /incr.
    wp_lam.
    wp_bind (! _)%E.
    iInv N as (m) ">[Hpt HOwnAuth]" "HClose".
    wp_load.
    iDestruct (@own_valid_2 _ _ _ γ with "HOwnAuth HOwnFrag") as %H%mcounterRA_valid_auth_frag.
    iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
    { iNext; iExists m; iFrame. }
    iModIntro.
    wp_let; wp_op; wp_let.
    wp_bind (CmpXchg _ _ _)%E.
    iInv N as (k) ">[Hpt HOwnAuth]" "HClose".
    destruct (decide (k = m)); subst.
    + wp_cmpxchg_suc.
      (* If the CAS succeeds we need to update our ghost state. This is achieved using the own_update rule/lemma.
         The arguments are the ghost name and the ghost resources x from which and to which we are updating.
         Finally we need to give up own γ x to get ownership of the new resources.
         We do this using the "with ..." syntax.
         Again, the conclusion of the update rule is under the update modality,
         and thus we wrap the application of the lemma with the iMod tactic. *)
      iMod (own_update γ ((● m ⋅ ◯ n) : mcounterRA) (● (1 + m) ⋅ ◯ (1 + n)) with "[HOwnFrag HOwnAuth]") as "[HOwnAuth HOwnFrag]".
      { apply mcounterRA_update. } (* We need the final property of the RA we proved above: the frame preserving update from (● m ⋅ ◯ n) to (● (1 + m) ⋅ ◯ (1 + n)). *)
      { rewrite own_op; iFrame. }
      iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
      { iNext; iExists (1 + m)%nat.
        rewrite Nat2Z.inj_succ Z.add_1_l; iFrame. }
      iModIntro; wp_pures; iApply ("HCont" with "[HInv HOwnFrag]").
      iExists γ; iFrame "#"; iFrame.
    + wp_cmpxchg_fail; first intros ?; simplify_eq.
      iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
      - iExists k; iFrame.
      - iModIntro. wp_proj. wp_if.
        iApply ("IH" with "HOwnFrag HCont"); iFrame.
  Qed.
End monotone_counter.

(* In the preceding section we spent a lot of time defining our own resource
   algebra and proving it satisfies all the needed properties. The same patterns
   appear often in proof development, and thus the iris Coq library provides
   several building blocks for constructing resource algebras.

   In the following section we repeat the above specification, but with a
   resource algebra constructed using these building blocks. We will see that
   this will save us quite a bit of work.

   As we stated in an exercise in the counter modules section of the lecture
   notes, the resource algebra we constructed above is nothing but Auth(N_max).
   Auth and N_max are both part of the iris Coq library. They are called authR
   and max_natUR (standing for authoritative Resource algebra and max nat Unital
   Resource algebra). *)

(* Auth is defined in iris.algebra.auth. *)
From iris.algebra Require Import auth.

(* The following section is a generic update property of the authoritative construction.
   In the Iris Coq library there are several update lemmas, using the concept of local updates
   (notation x ~l~> y, and the definition is called local_update).

   The two updates in the following section are the same as stated in the exercise in the notes.
*)
Section auth_update.
  Context {U : ucmra}.

  Lemma auth_update_add (x y z : U): ✓ (x ⋅ z) → ● x ⋅ ◯ y ~~> ● (x ⋅ z) ⋅ ◯ (y ⋅ z).
  Proof.
    intros ?.
    (* auth_update is the generic update rule for the auth RA. It reduces a
       frame preserving update to that of a local update. *)
    apply auth_update.
    intros ? mz ? Heq.
    split.
    - apply cmra_valid_validN; auto.
    - simpl in *.
      rewrite Heq.
      destruct mz; simpl; auto.
      rewrite -assoc (comm _ _ z) assoc //.
  Qed.

  Lemma auth_update_add' (x y z w : U): ✓ (x ⋅ z) → w ≼ z → ● x ⋅ ◯ y ~~> ● (x ⋅ z) ⋅ ◯ (y ⋅ w).
  Proof.
    (* The proof of this lemma uses the previous lemma, together with the fact
       that ~~> is transitive, and the fact that we always have the frame
       preserving update from a ⋅ b to a. This is proved in cmra_update_op_l in
       the Coq library.
    *)
    intros Hv [? He].
    etransitivity.
    { apply (auth_update_add x y z Hv). }
    rewrite {2}He assoc auth_frag_op assoc.
    apply cmra_update_op_l.
  Qed.
End auth_update.

Section monotone_counter'.
  (* We tell Coq that our Iris instantiation has the following resource
     algebras. Note that the only diffference from above is that we use authR
     max_natUR in place of the resource algebra mcounterRA we constructed above. *)
  Class mcounterG' Σ := MCounterG' { mcounter_inG' :> inG Σ (authR max_natUR)}.
  Definition mcounterΣ' : gFunctors := #[GFunctor (authR max_natUR)].

  Instance subG_mcounterΣ' {Σ} : subG mcounterΣ' Σ → mcounterG' Σ.
  Proof. solve_inG. Qed.

  (* We now prove the same three properties we claim were required from the resource
     algebra in Section 7.7.  *)
  Instance mcounterRA_frag_core' (n : max_natUR): CoreId (◯ n).
  Proof.
    apply _.
    (* CoreID is a typeclass, so typeclass search can automatically deduce what
       we want. Concretely, the proof follows by lemmas auth_frag_core_id and
       max_nat_core_id proved in the Iris Coq library. *)
  Qed.

  Lemma mcounterRA_valid_auth_frag' (m n : max_natUR): ✓ (● m ⋅ ◯ n) ↔ (max_nat_car n ≤ max_nat_car m)%nat.
  Proof.
    (* Use a simplified definition of validity for when the underlying CMRA is discrete, i.e., an RA.
       The general definition also involves the use of step-indices, which is not needed in our case. *)
    rewrite auth_both_valid_discrete.
    split.
    - intros [? _]; by apply max_nat_included.
    - intros ?%max_nat_included; done.
  Qed.

  Lemma max_nat_op_succ m : MaxNat (S m) = MaxNat m ⋅ MaxNat (S m).
  Proof. rewrite max_nat_op. apply f_equal. lia. Qed.

  Lemma mcounterRA_update' (m n : max_natUR) :
    ● m ⋅ ◯ n ~~> ● MaxNat (S (max_nat_car m)) ⋅ ◯ MaxNat (S (max_nat_car n)).
  Proof.
    destruct m as [m], n as [n]. simpl.
    rewrite (max_nat_op_succ m) (max_nat_op_succ n).
    apply cmra_update_valid0. intros ?%cmra_discrete_valid%mcounterRA_valid_auth_frag'.
    simpl in *. apply auth_update_add'; first reflexivity.
    exists (MaxNat (S m)). rewrite max_nat_op. apply f_equal. lia.
  Qed.

  (* We can now verify the programs. *)
  (* We start off as in the previous example, with some boilerplate code. *)
  Context `{!heapGS Σ, !mcounterG' Σ} (N : namespace).
  Notation iProp := (iProp Σ).

  (* The rest of this section is exactly the same as the preceding one. We use
     the properties of the RA we have proved above. *)
  Definition counter_inv' (ℓ : loc) (γ : gname) : iProp := (∃ (m : nat), ℓ ↦ #m ∗ own γ (● MaxNat m))%I.

  Definition isCounter' (ℓ : loc) (n : max_natUR) : iProp :=
    (∃ γ, own γ (◯ n) ∗ inv N (counter_inv' ℓ γ))%I.

  Global Instance isCounter_persistent' ℓ n: Persistent (isCounter' ℓ n).
  Proof.
    apply _.
  Qed.

  Lemma newCounter_spec': {{{ True }}} newCounter #() {{{ v, RET #v; isCounter' v (MaxNat 0) }}}.
  Proof.
    iIntros (Φ) "_ HCont".
    rewrite /newCounter.
    wp_lam.
    iMod (own_alloc (● MaxNat 0 ⋅ ◯ MaxNat 0)) as (γ) "[HAuth HFrac]".
    - apply mcounterRA_valid_auth_frag'; auto.
    - wp_alloc ℓ as "Hpt".
      iMod (inv_alloc N _ (counter_inv' ℓ γ) with "[Hpt HAuth]") as "HInv".
      + iExists 0%nat; iFrame.
      + iApply ("HCont" with "[HFrac HInv]").
        iExists γ; iFrame.
  Qed.

  (* The read method specification. *)
  Lemma read_spec' ℓ n : {{{ isCounter' ℓ (MaxNat n) }}} read #ℓ {{{ m, RET #m; ⌜n ≤ m⌝%nat }}}.
  Proof.
    iIntros (Φ) "HCounter HCont".
    iDestruct "HCounter" as (γ) "[HOwnFrag HInv]".
    rewrite /read.
    wp_lam.
    iInv N as (m) ">[Hpt HOwnAuth]" "HClose".
    wp_load.
    iDestruct (@own_valid_2 _ _ _ γ with "HOwnAuth HOwnFrag") as %H%mcounterRA_valid_auth_frag'.
    iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
    { iNext; iExists m; iFrame. }
    iModIntro.
    iApply "HCont"; done.
  Qed.

  (* The read method specification. *)
  Lemma incr_spec' ℓ n : {{{ isCounter' ℓ (MaxNat n) }}} incr #ℓ {{{ RET #(); isCounter' ℓ (MaxNat (1 + n)) }}}.
  Proof.
    iIntros (Φ) "HCounter HCont".
    iDestruct "HCounter" as (γ) "[HOwnFrag #HInv]".
    iLöb as "IH".
    rewrite /incr.
    wp_lam.
    wp_bind (! _)%E.
    iInv N as (m) ">[Hpt HOwnAuth]" "HClose".
    wp_load.
    iDestruct (@own_valid_2 _ _ _ γ with "HOwnAuth HOwnFrag") as %H%mcounterRA_valid_auth_frag'.
    iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
    { iNext; iExists m; iFrame. }
    iModIntro.
    wp_let; wp_op; wp_let.
    wp_bind (CmpXchg _ _ _)%E.
    iInv N as (k) ">[Hpt HOwnAuth]" "HClose".
    destruct (decide (k = m)); subst.
    + wp_cmpxchg_suc.
      iMod (own_update γ (● (MaxNat m) ⋅ ◯ (MaxNat n)) (● (MaxNat (S m)) ⋅ (◯ (MaxNat (S n)))) with "[HOwnFrag HOwnAuth]") as "[HOwnAuth HOwnFrag]".
      { apply mcounterRA_update'. }
      { rewrite own_op; iFrame. }
      iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
      { iNext; iExists (1 + m)%nat.
        rewrite Nat2Z.inj_succ Z.add_1_l; iFrame. }
      iModIntro; wp_pures; iApply ("HCont" with "[HInv HOwnFrag]").
      iExists γ; iFrame "#"; iFrame.
    + wp_cmpxchg_fail; first intros ?; simplify_eq.
      iMod ("HClose" with "[Hpt HOwnAuth]") as "_".
      - iExists k; iFrame.
      - iModIntro. wp_proj. wp_if.
        iApply ("IH" with "HOwnFrag HCont"); iFrame.
  Qed.
End monotone_counter'.

(* Counter with contributions. *)
(* As a final example in this example file we give the more precise specification to the counter. *)
(* As explained in the lecture notes we need a different resource algebra: the
   authoritative resource algebra on the product of the RA of fractions and the
   RA of natural numbers, with an added unit.

   The combination of the RA of fractions and the authoritative RA in this way
   is fairly common, and so the Iris Coq library provides frac_authR (CM)RA. *)

From iris.algebra Require Import frac_auth.

Section ccounter.
  (* We start as we did before, telling Coq what we assume from the Iris instantiation. *)
  (* Note that now we use natR as the underlying resource algebra. This is the
     RA of natural numbers with addition as the operation. *)
  Class ccounterG Σ := CCounterG { ccounter_inG :> inG Σ (frac_authR natR) }.
  Definition ccounterΣ : gFunctors := #[GFunctor (frac_authR natR)].

  Instance subG_ccounterΣ {Σ} : subG ccounterΣ Σ → ccounterG Σ.
  Proof. solve_inG. Qed.

  (* The first thing we are going to prove are the properties of the resource
     algebra, specialized to our use case. These are listed in the exercise in
     the relevant section of the lecture notes. *)
  (* We are using some new notation. The frac_auth library defines the notation
     ◯F{q} n to mean ◯ (q, n) as we used in the lecture notes. Further, ●F m
     means ● (1, m) and ◯F n means ◯ (1, n). *)
  Lemma ccounterRA_valid (m n : natR) (q : frac): ✓ (●F m ⋅ ◯F{q} n) → (n ≤ m)%nat.
  Proof.
    intros ?.
    (* This property follows directly from the generic properties of the relevant RAs. *)
    apply nat_included. by apply: (frac_auth_included_total q).
  Qed.

  Lemma ccounterRA_valid_full (m n : natR): ✓ (●F m ⋅ ◯F n) → (n = m)%nat.
  Proof.
    by intros ?%frac_auth_agree.
  Qed.

  Lemma ccounterRA_update (m n : natR) (q : frac): (●F m ⋅ ◯F{q} n) ~~> (●F (S m) ⋅ ◯F{q} (S n)).
  Proof.
    apply frac_auth_update, (nat_local_update _ _ (S _) (S _)).
    lia.
  Qed.

  (* We have all the properties of the RAs needed and thus we can proceed with
     the proof, which proceeds largely as before, modulo the changes in
     invariants.

     There is one important difference in the definition of is_ccounter. The
     ghost name γ is not hidden. This is because now is_ccounter is not
     persistent, and to share it we have the is_ccounter_op lemma, which would
     not hold if we were to existentially quantify γ as we did in the previous
     examples.
  *)
  Context `{!heapGS Σ, !ccounterG Σ} (N : namespace).

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

  Definition is_ccounter (γ : gname) (l : loc) (q : frac) (n : natR) : iProp Σ :=
    (own γ (◯F{q} n) ∗ inv N (ccounter_inv γ l))%I.

  (** The main proofs. *)

  (* As explained in the notes the is_ccounter predicate for this specificatin is not persistent.
     However it is still shareable in the following restricted way.
   *)
  Lemma is_ccounter_op γ ℓ q1 q2 (n1 n2 : nat) :
    is_ccounter γ ℓ (q1 + q2) (n1 + n2)%nat ⊣⊢ is_ccounter γ ℓ q1 n1 ∗ is_ccounter γ ℓ q2 n2.
  Proof.
    apply bi.equiv_entails; split; rewrite /is_ccounter frac_auth_frag_op own_op.
    - iIntros "[? #?]".
      iFrame "#"; iFrame.
    - iIntros "[[? #?] [? _]]".
      iFrame "#"; iFrame.
  Qed.

  Lemma newcounter_contrib_spec (R : iProp Σ) :
    {{{ True }}}
        newCounter #()
    {{{ γ ℓ, RET #ℓ; is_ccounter γ ℓ 1 0%nat }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite /newCounter /=. wp_lam. wp_alloc ℓ as "Hpt".
    iMod (own_alloc (●F O%nat ⋅ ◯F 0%nat)) as (γ) "[Hγ Hγ']"; first by apply auth_both_valid_discrete.
    iMod (inv_alloc N _ (ccounter_inv γ ℓ) with "[Hpt Hγ]").
    { iNext. iExists 0%nat. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /is_ccounter; eauto.
  Qed.

  Lemma incr_contrib_spec γ ℓ q n :
    {{{ is_ccounter γ ℓ q n  }}}
        incr #ℓ
    {{{ RET #(); is_ccounter γ ℓ q (S n) }}}.
  Proof.
    iIntros (Φ) "[Hown #Hinv] HΦ". iLöb as "IH". wp_rec.
    wp_bind (! _)%E. iInv N as (c) ">[Hγ Hpt]" "Hclose".
    wp_load. iMod ("Hclose" with "[Hpt Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iModIntro. wp_let. wp_op. wp_let.
    wp_bind (CmpXchg _ _ _). iInv N as (c') ">[Hγ Hpt]" "Hclose".
    destruct (decide (c' = c)) as [->|].
    - iMod (own_update_2 with "Hγ Hown") as "[Hγ Hown]".
      { apply ccounterRA_update. } (* We use the update lemma for our RA. *)
      wp_cmpxchg_suc. iMod ("Hclose" with "[Hpt Hγ]") as "_".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      iModIntro. wp_pures. iApply "HΦ". by iFrame "Hinv".
    - wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]).
      iMod ("Hclose" with "[Hpt Hγ]") as "_"; [iNext; iExists c'; by iFrame|].
      iModIntro. wp_pures. by iApply ("IH" with "[Hown] [HΦ]"); auto.
  Qed.

  Lemma read_contrib_spec γ ℓ q n :
    {{{ is_ccounter γ ℓ q n }}}
        read #ℓ
    {{{ c, RET #c; ⌜n ≤ c⌝%nat ∧ is_ccounter γ ℓ q n }}}.
  Proof.
    iIntros (Φ) "[Hown #Hinv] HΦ".
    rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hpt]" "Hclose". wp_load.
    iDestruct (own_valid_2 with "Hγ Hown") as % ?%ccounterRA_valid. (* We use the validity property of our RA. *)
    iMod ("Hclose" with "[Hpt Hγ]") as "_"; [iNext; iExists c; by iFrame|].
    iApply ("HΦ" with "[-]"); rewrite /is_ccounter; eauto.
  Qed.

  Lemma read_contrib_spec_1 γ ℓ n :
    {{{ is_ccounter γ ℓ 1 n }}} read #ℓ
    {{{ m, RET #m; ⌜m = n⌝ ∗ is_ccounter γ ℓ 1 m }}}.
  Proof.
    iIntros (Φ) "[Hown #Hinv] HΦ".
    rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hpt]" "Hclose". wp_load.
    iDestruct (own_valid_2 with "Hγ Hown") as % <-%ccounterRA_valid_full. (* We use the validity property of our RA. *)
    iMod ("Hclose" with "[Hpt Hγ]") as "_"; [iNext; iExists n; by iFrame|].
    iApply "HΦ"; iModIntro. iFrame "Hown #"; done.
  Qed.
End ccounter.


(*File containing lists and poly examples*)

(** Before getting started, we need to import all of our
    definitions from the previous chapter: *)

From LF Require Export Basics.
Module MyLists.

Inductive natprod : Type :=
| pair (n1 n2 : nat).

Notation "( x , y )" := (pair x y).

Definition minus'' (p: natprod) : nat :=
  match p with
  | (x, y) => x-y
  end.

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | h :: t => h :: (app t l2)
  end.

(*Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h::t => match (h =? v) with
                | true => 1+(count v t)
                | false => (count v t)
                end
  end.
*)

Inductive id : Type :=
  | Id (n : nat).

Inductive partial_map : Type :=
  | empty
  | record (i : id) (v : nat) (m : partial_map).

Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42  (* arbitrary! *)
  | a :: l' => match n =? O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match n =? O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

(*Examples for reasoning about lists*)
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

(*Example 1: simpl*)
Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. simpl. reflexivity. Qed.

(*Example 2: destruct*)
Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    simpl. reflexivity.
  - (* l = cons n l' *)
    simpl. reflexivity.  Qed.

(*Example 3: induction*)
Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    simpl. reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.  Qed.

End MyLists.
(**********************Polymorphism******************************)

Module MyPoly.
Export MyLists.

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

(*Check list.
(* ===> list : Type -> Type *)*)

Check nil.

(*Type Annotation Inference*)
Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(*Type Argument Inference*)
Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(*Implict Arguments*)
Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Check nil.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** Now lists can be written just the way we'd hope: *)
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).

Definition list123''' := [1; 2; 3].

(*Polymorphism Pairs*)
Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

(*Note: Module MyPoly is need, as constructor [pair] has used in natprod*)

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Fail Definition mynil : list := nil.

Check nil.

Definition mynil : list nat := nil.
Check mynil.
Definition mynil' := @nil nat.
Check mynil'.

(*Polymorphic Options*)
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l  with
  | nil => None
  | a::l' => Some a
  end.

(*High-order functions*)
Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

(*Anonymous Functions*)
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(*Functions That Construct Functions*)
Definition constfun {X: Type} x : nat->X :=
  fun (k:nat) => x.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(*************************Example: Map*****************************)

(*Input f, l=[n1,n2......]   output: [f n1, f n2, ......]*)
Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. simpl. reflexivity.  Qed.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

(**)
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
(**)

(**)
Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f.
  induction l as [| h t Ht].
  - (* l = [] *)
    simpl. reflexivity.
  - (* l = h t *)
    simpl. rewrite <- Ht. simpl. reflexivity.
Qed.
(**)

Theorem map_app_distr : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2.
  induction l1 as [| h1 t1 IHt1].
  - (* l1 = [] *)
    simpl. reflexivity.
  - (* l1 = h1 t1 *)
    simpl. rewrite -> IHt1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f.
  induction l as [| h t Ht].
  - (* l = [] *)
    simpl. reflexivity.
  - (* l = h t *)
    simpl.  rewrite <- Ht. rewrite -> map_app_distr. simpl. reflexivity.
Qed.

End MyPoly.


Require Export RTopology.
Require Export SeparatednessAxioms.

Local Unset Standard Proposition Elimination Names.

(* This proof of the Tietze extension theorem is heavily based on
   the proof described on planetmath.org. *)

Section Tietze_extension_construction.

Variable X:TopologicalSpace.
Variable F:Ensemble (point_set X).
Hypothesis F_closed: closed F.
Variable f:point_set (SubspaceTopology F) -> point_set RTop.
Hypothesis f_continuous: continuous f.
Hypothesis f_bound: forall x:point_set (SubspaceTopology F), -1 <= f x <= 1.
Hypothesis X_nonempty: inhabited (point_set X).

Variable Urysohns_lemma_function: forall F G:Ensemble (point_set X),
  closed F -> closed G -> Intersection F G = Empty_set ->
  { f:point_set X -> point_set RTop |
    continuous f /\ (forall x:point_set X, 0 <= f x <= 1) /\
    (forall x:point_set X, In F x -> f x = 0) /\
    (forall x:point_set X, In G x -> f x = 1)
  }.

Lemma subspace_inc_takes_closed_to_closed:
  forall G:Ensemble (point_set (SubspaceTopology F)),
  closed G -> closed (Im G (subspace_inc F)).
Proof.
intros.
destruct (subspace_topology_topology _ _ _ H) as [U []].
replace (Im G (subspace_inc F)) with (Intersection F (Complement U)).
apply closed_intersection2; trivial.
red; rewrite Complement_Complement; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
exists (exist _ x H2); trivial.
apply NNPP; intro.
change (In (Complement G) (exist (In F) x H2)) in H4.
rewrite H1 in H4.
destruct H4.
simpl in H4.
contradiction H3.

destruct H2 as [[y]].
rewrite H3; clear y0 H3.
constructor.
trivial.
intro.
absurd (In (Complement G) (exist (fun x => In F x) y i)).
intro.
contradiction H4.
rewrite H1.
constructor.
trivial.
Qed.

Lemma Rle_order: order Rle.
Proof.
constructor.
red; intros; apply Rle_refl.
red; intros; eapply Rle_trans; [ apply H | apply H0 ].
red; intros; apply Rle_antisym; trivial.
Qed.

Section extension_approximation.

Variable f0:point_set (SubspaceTopology F) -> point_set RTop.
Hypothesis f0_cont: continuous f0.
Hypothesis f0_bound: forall x:point_set (SubspaceTopology F), -1 <= f0 x <= 1.

Definition extension_approximation: point_set X -> point_set RTop.
refine (
  let F0:=Im [ x:point_set (SubspaceTopology F) | f0 x <= -1/3 ] (subspace_inc F) in
  let G0:=Im [ x:point_set (SubspaceTopology F) | f0 x >= 1/3 ] (subspace_inc F) in
  let g:=proj1_sig (Urysohns_lemma_function F0 G0 _ _ _) in
  fun x:point_set X => -1/3 + 2/3 * g x).
apply subspace_inc_takes_closed_to_closed.
replace ([ x:point_set (SubspaceTopology F) | f0 x <= -1/3 ]) with
  (inverse_image f0 [ y:point_set RTop | y <= -1/3 ]).
red.
rewrite <- inverse_image_complement.
apply f0_cont.
apply lower_closed_interval_closed.
apply Rle_order.
intros.
destruct (total_order_T x y) as [[|]|]; auto with real.
apply Extensionality_Ensembles; split; red; intros.
destruct H as [[]]; constructor; trivial.
destruct H; constructor; constructor; trivial.
apply subspace_inc_takes_closed_to_closed.
replace ([ x:point_set (SubspaceTopology F) | f0 x >= 1/3 ]) with
  (inverse_image f0 [ y:point_set RTop | 1/3 <= y ]).
red.
rewrite <- inverse_image_complement.
apply f0_cont.
apply upper_closed_interval_closed.
apply Rle_order.
intros; destruct (total_order_T x y) as [[|]|]; auto with real.
apply Extensionality_Ensembles; split; red; intros.
destruct H as [[]]; constructor; auto with real.
destruct H; constructor; constructor; auto with real.
apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H.
destruct H as [[y] []].
simpl in H1.
destruct H0 as [[z] []].
simpl in H2.
destruct H1; destruct H2.
destruct (proof_irrelevance _ i i0).
Require Import Fourier.
fourier.
Defined.

Lemma extension_approximation_bound: forall x:point_set X,
  -1/3 <= extension_approximation x <= 1/3.
Proof.
intros.
unfold extension_approximation.
destruct Urysohns_lemma_function as [g].
simpl.
destruct a as [? [? []]].
destruct (H0 x).
split; fourier.
Qed.

Lemma extension_approximation_diff_bound:
  forall x:point_set (SubspaceTopology F),
  -2/3 <= f0 x - extension_approximation (subspace_inc F x) <= 2/3.
Proof.
intros.
unfold extension_approximation; destruct Urysohns_lemma_function as
  [g [? [? []]]]; simpl.
destruct (f0_bound x).
destruct (Rle_or_lt (f0 x) (-1/3)).
replace (g (subspace_inc F x)) with 0.
split; fourier.
symmetry; apply e.
econstructor; trivial.
constructor; trivial.

destruct (Rle_or_lt (1/3) (f0 x)).
replace (g (subspace_inc F x)) with 1.
split; fourier.
symmetry; apply e0.
econstructor; trivial.
constructor; auto with real.

destruct (a (subspace_inc F x)).
split; fourier.
Qed.

Lemma extension_approximation_continuous:
  continuous extension_approximation.
Proof.
unfold extension_approximation; destruct Urysohns_lemma_function as
  [g [? [? []]]]; simpl.
apply pointwise_continuity; intros.
Require Import RFuncContinuity.
apply sum_continuous.
apply continuous_func_continuous_everywhere; apply continuous_constant.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere; trivial.
Qed.

End extension_approximation.

Lemma missing_pow_mult: forall (x y:R) (n:nat),
  (x*y)^n = x^n * y^n.
Proof.
induction n.
simpl; ring.
simpl.
rewrite IHn; ring.
Qed.

Definition extension_approximation_seq: forall n:nat,
  { g0:point_set X -> point_set RTop |
    continuous g0 /\
    (forall x:point_set X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
    (forall x:point_set (SubspaceTopology F),
      -(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) }.
simple refine (fix g (n:nat) {struct n} := match n return
  { g0:point_set X -> point_set RTop |
    continuous g0 /\
    (forall x:point_set X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
    (forall x:point_set (SubspaceTopology F),
      -(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) } with
| O => exist _ (fun _ => 0) _
| S m => match g m with
         | exist gm y =>
         let H := _ in
         let approx := extension_approximation
                       (fun x:point_set (SubspaceTopology F) =>
                       (3/2)^m * (f x - gm (subspace_inc F x))) H in
         exist _ (fun x:point_set X => gm x + (2/3)^m * approx x) _
         end
end); clear g; [ | | clearbody H ].
simpl.
split.
apply continuous_constant.
split.
intros; split; ring_simplify; auto with real.
intros.
destruct (f_bound x).
split; fourier.
apply pointwise_continuity; intros.
apply const_multiple_continuous.
apply diff_continuous.
apply continuous_func_continuous_everywhere; trivial.
apply continuous_composition_at.
destruct y.
apply continuous_func_continuous_everywhere; trivial.
apply continuous_func_continuous_everywhere; apply subspace_inc_continuous.

assert (forall x:point_set (SubspaceTopology F),
  -1 <= (3/2)^m * (f x - gm (subspace_inc F x)) <= 1).
intros.
destruct y.
destruct H1.
destruct (H2 x).
assert ((3/2)^m * (2/3)^m = 1).
rewrite <- missing_pow_mult.
replace (3/2*(2/3)) with 1 by field.
apply pow1.
replace (-1) with ((3/2)^m * (- (2/3)^m)).
pattern 1 at 21; replace 1 with ((3/2)^m * (2/3)^m).
assert (0 <= (3/2)^m).
apply pow_le.
fourier.
split; apply Rmult_le_compat_l; trivial.
replace ((3/2)^m * -(2/3)^m) with (- ((3/2)^m * (2/3)^m)) by ring.
f_equal; trivial.

assert (forall x:point_set X, -1/3 <= approx x <= 1/3).
apply extension_approximation_bound.
assert (forall x:point_set (SubspaceTopology F),
  -2/3 <= (3/2)^m * (f x - gm (subspace_inc F x)) -
          approx (subspace_inc F x) <= 2/3).
apply extension_approximation_diff_bound; trivial.
destruct y as [? []].
split.
apply pointwise_continuity; intros.
apply sum_continuous.
apply continuous_func_continuous_everywhere; trivial.
apply const_multiple_continuous.
apply continuous_func_continuous_everywhere.
apply extension_approximation_continuous.

split; intros.
destruct (H4 x).
simpl.
destruct (H1 x).
assert (0 <= (2/3)^m).
apply pow_le; fourier.
assert ((2/3)^m * (-1/3) <= (2/3)^m * approx x <= (2/3)^m * (1/3)).
split; apply Rmult_le_compat_l; trivial.
destruct H11.
split; fourier.

simpl.
replace (-(2/3*(2/3)^m)) with ((2/3)^m * (-2/3)) by field.
replace (2/3*(2/3)^m) with ((2/3)^m * (2/3)) by ring.
replace (f x - (gm (subspace_inc F x) + (2/3)^m * approx (subspace_inc F x)))
  with ((2/3)^m * ((3/2)^m * (f x - gm (subspace_inc F x)) -
                   approx (subspace_inc F x))).
assert (0 <= (2/3)^m).
apply pow_le; fourier.
destruct (H2 x).
split; apply Rmult_le_compat_l; trivial.
ring_simplify.
replace ((2/3)^m*(3/2)^m) with 1.
ring.
rewrite <- missing_pow_mult.
replace (2/3*(3/2)) with 1 by field.
symmetry; apply pow1.
Defined.

Lemma extension_approximation_seq_diff: forall (n:nat) (x:point_set X),
  -(1/3 * (2/3)^n) <= proj1_sig (extension_approximation_seq (S n)) x -
                      proj1_sig (extension_approximation_seq n) x
                   <= 1/3*(2/3)^n.
Proof.
intros.
simpl extension_approximation_seq.
destruct extension_approximation_seq; simpl.
match goal with |- context [extension_approximation ?A ?B x] =>
  cut (-1/3 <= extension_approximation A B x <= 1/3);
  [ generalize (extension_approximation A B x) |
    apply extension_approximation_bound ] end.
intros.
assert (0 <= (2/3)^n).
apply pow_le; fourier.
replace (-(1/3*(2/3)^n)) with ((2/3)^n*(-1/3)) by field.
replace (1/3*(2/3)^n) with ((2/3)^n*(1/3)) by ring.
replace (x0 x + (2/3)^n*p - x0 x) with ((2/3)^n*p) by ring.
destruct H.
split; apply Rmult_le_compat_l; trivial.
Qed.

(* now we've gotten what we need from the concrete definition, make
   it opaque so it doesn't slow down searches in the future *)
Global Opaque extension_approximation_seq.
Opaque extension_approximation_seq.

Lemma Rle_R1_pow: forall (x:R) (m n:nat), 0 <= x <= 1 -> (m <= n)%nat ->
  x^n <= x^m.
Proof.
induction 2.
auto with real.
simpl.
replace (x^m) with (1*x^m) by auto with real.
destruct H.
apply Rmult_le_compat; trivial.
apply pow_le; trivial.
Qed.

Lemma extension_approximation_seq_cauchy_aux:
  forall (m n:nat) (x:point_set X),
  Rabs (proj1_sig (extension_approximation_seq m) x -
        proj1_sig (extension_approximation_seq n) x) <=
  Rabs ((2/3)^m - (2/3)^n).
Proof.
cut (forall (m n:nat) (x:point_set X), (m <= n)%nat ->
  Rabs (proj1_sig (extension_approximation_seq m) x -
        proj1_sig (extension_approximation_seq n) x) <=
  (2/3)^m - (2/3)^n).
intros.
destruct (le_or_lt m n).
rewrite (Rabs_right ((2/3)^m - (2/3)^n)).
apply H; trivial.
apply Rge_minus.
cut ((2/3)^n <= (2/3)^m); auto with real.
apply Rle_R1_pow; trivial.
split; fourier.
apply lt_le_weak in H0.
rewrite (Rabs_left1 ((2/3)^m - (2/3)^n)).
replace (- ((2/3)^m - (2/3)^n)) with ((2/3)^n - (2/3)^m) by ring.
rewrite Rabs_minus_sym.
apply H; trivial.
apply Rle_minus.
apply Rle_R1_pow; trivial.
split; fourier.

induction 1.
repeat match goal with |- context [ ?y - ?y ] =>
  replace (y-y) with 0 by ring end.
rewrite Rabs_R0; apply Rle_refl.

simpl pow.
apply Rle_trans with
  (Rabs (proj1_sig (extension_approximation_seq m) x -
         proj1_sig (extension_approximation_seq m0) x) +
   Rabs (proj1_sig (extension_approximation_seq m0) x -
         proj1_sig (extension_approximation_seq (S m0)) x)).
rewrite Rplus_comm.
apply R_metric_is_metric.
pose proof (extension_approximation_seq_diff m0 x).
assert (Rabs (proj1_sig (extension_approximation_seq m0) x -
              proj1_sig (extension_approximation_seq (S m0)) x) <=
        1/3 * (2/3)^m0).
destruct H0.
unfold Rabs.
destruct Rcase_abs; fourier.
fourier.
Qed.

Require Import UniformTopology.

Definition convert_approx_to_uniform_space:
  nat -> uniform_space R_metric (fun _:point_set X => 0).
refine (fun n:nat => exist _ (proj1_sig (extension_approximation_seq n)) _).
destruct extension_approximation_seq as [g [? []]].
simpl.
unfold R_metric.
exists (1 - (2/3)^n).
red; intros.
destruct H.
rewrite H0; clear y H0.
destruct (a x).
unfold Rabs; destruct Rcase_abs; fourier.
Defined.

Lemma extension_approximation_seq_cauchy:
  cauchy (uniform_metric R_metric (fun _:point_set X => 0)
          R_metric_is_metric X_nonempty)
    convert_approx_to_uniform_space.
Proof.
red; intros.
assert (Rabs (2/3) < 1).
rewrite Rabs_right; fourier.
assert (0 < eps/2) by fourier.
destruct (pow_lt_1_zero (2/3) H0 (eps/2) H1) as [N].
exists N.
intros.
apply Rle_lt_trans with (Rabs ((2/3)^m - (2/3)^n)).
unfold uniform_metric; unfold convert_approx_to_uniform_space;
  destruct sup; simpl.
apply i.
red; intros.
destruct H5.
rewrite H6; clear y H6.
rewrite metric_sym.
apply extension_approximation_seq_cauchy_aux.
exact R_metric_is_metric.
apply Rle_lt_trans with (Rabs ((2/3)^m) + Rabs((2/3)^n)).
rewrite <- (Rabs_Ropp ((2/3)^n)).
unfold Rminus.
apply Rabs_triang.
replace eps with (eps/2 + eps/2) by field.
apply Rplus_lt_compat; apply H2; trivial.
Qed.

Definition Tietze_extension_func : point_set X -> point_set RTop.
Require Import Description.
refine (proj1_sig (proj1_sig (constructive_definite_description
  (fun f:point_set (UniformTopology R_metric (fun _:point_set X => 0)
                    R_metric_is_metric X_nonempty) =>
  net_limit convert_approx_to_uniform_space f
    (I:=nat_DS) (X:=UniformTopology R_metric (fun _:point_set X => 0)
                    R_metric_is_metric X_nonempty)) _))).
apply -> unique_existence; split.
assert (complete (uniform_metric R_metric (fun _:point_set X => 0)
                    R_metric_is_metric X_nonempty)
          (uniform_metric_is_metric _ _ _ _ _ _)).
apply uniform_metric_complete.
exact R_metric_complete.
apply H.
exact extension_approximation_seq_cauchy.
apply Hausdorff_impl_net_limit_unique.
apply T3_sep_impl_Hausdorff.
apply normal_sep_impl_T3_sep.
apply metrizable_impl_normal_sep.
exists (uniform_metric R_metric (fun _:point_set X => 0)
          R_metric_is_metric X_nonempty).
apply (uniform_metric_is_metric _ _ R_metric (fun _:point_set X => 0)
          R_metric_is_metric X_nonempty).
apply MetricTopology_metrizable.
Defined.

Lemma Tietze_extension_func_bound: forall x:point_set X,
  -1 <= Tietze_extension_func x <= 1.
Proof.
intros.
cut (Rabs (Tietze_extension_func x) <= 1).
intros.
unfold Rabs in H; destruct Rcase_abs in H;
  split; fourier.

unfold Tietze_extension_func;
  destruct constructive_definite_description as [[g]].
simpl.
assert (bound (Im Full_set (fun x:point_set X => R_metric 0 0))).
exists 0.
red; intros.
destruct H.
right.
rewrite H0; apply R_metric_is_metric.
apply Rle_trans with (uniform_metric _ _ R_metric_is_metric X_nonempty
                    (exist _ (fun _:point_set X => 0) H)
                    (exist _ g b)).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
exists x.
constructor.
unfold R_metric; f_equal; auto with real.

apply lt_plus_epsilon_le; intros.
unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n eps H0 in _); [ | | clearbody H1 ]; shelve_unifiable.
apply MetricTopology_metrizable.
destruct H1 as [N].
refine (Rle_lt_trans _ _ _
  (triangle_inequality _ _ _ _ (convert_approx_to_uniform_space N) _) _).
apply uniform_metric_is_metric.
apply Rplus_lt_compat.
apply Rle_lt_trans with (1 - (2/3)^N).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
red; intros.
destruct H2.
rewrite H3; clear y H3.
unfold R_metric.
destruct extension_approximation_seq as [h [? []]].
destruct (a x1).
simpl.
unfold Rabs; destruct Rcase_abs; fourier.
assert ((2/3)^N > 0).
apply pow_lt; fourier.
fourier.
rewrite metric_sym; try apply uniform_metric_is_metric.
apply H1.
unfold DS_ord; constructor.
Qed.

Lemma Tietze_extension_func_is_extension:
  forall x:point_set (SubspaceTopology F),
  Tietze_extension_func (subspace_inc F x) = f x.
Proof.
intros.
apply R_metric_is_metric.
apply Rle_antisym; try (apply Rge_le; apply R_metric_is_metric).
apply lt_plus_epsilon_le; intros.
unfold Tietze_extension_func;
  destruct constructive_definite_description as [[g]]; simpl.
assert (eps/2 > 0) by fourier.
unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n (eps/2) H0
          in _); [ | | clearbody H1 ]; shelve_unifiable.
apply MetricTopology_metrizable.
destruct H1 as [N1].
assert (Rabs (2/3) < 1).
rewrite Rabs_right; fourier.

destruct (pow_lt_1_zero (2/3) H2 (eps/2) H0) as [N2].
Require Import Max.
pose (N := max N1 N2).
apply Rle_lt_trans with (R_metric (g (subspace_inc F x))
          (proj1_sig (extension_approximation_seq N) (subspace_inc F x)) +
  R_metric (proj1_sig (extension_approximation_seq N) (subspace_inc F x))
    (f x)).
apply triangle_inequality; apply R_metric_is_metric.
replace (0+eps) with (eps/2+eps/2) by field.
apply Rplus_lt_compat.
rewrite metric_sym; try apply R_metric_is_metric.
assert (DS_ord N1 N) by apply le_max_l.
apply Rle_lt_trans with (2:=H1 N H4).
unfold uniform_metric; simpl; destruct sup; simpl.
apply i.
exists (subspace_inc F x).
constructor.
apply R_metric_is_metric.

assert ((N >= N2)%nat) by apply le_max_r.
apply Rle_lt_trans with (2:=H3 N H4).
rewrite Rabs_right.
destruct extension_approximation_seq as [h [? []]]; simpl.
unfold R_metric.
destruct (a0 x).
unfold Rabs; destruct Rcase_abs; fourier.
apply Rle_ge.
apply pow_le; fourier.
Qed.

Let convert_continuity: forall h:point_set X -> R,
  continuous h (Y:=RTop) <-> continuous h (Y:=MetricTopology R_metric
                                           R_metric_is_metric).
Proof.
assert (continuous (fun x:R => x)
  (X:=RTop) (Y:=MetricTopology R_metric R_metric_is_metric)).
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric; intros.
apply RTop_metrization.
apply MetricTopology_metrizable.
exists eps; split; trivial.
assert (continuous (fun x:R => x)
  (X:=MetricTopology R_metric R_metric_is_metric) (Y:=RTop)).
apply pointwise_continuity; intros.
apply metric_space_fun_continuity with R_metric R_metric; intros.
apply MetricTopology_metrizable.
apply RTop_metrization.
exists eps; split; trivial.

intros; split; intros.
apply continuous_composition with (1:=H) (2:=H1).
apply continuous_composition with (1:=H0) (2:=H1).
Qed.

Lemma Tietze_extension_func_continuous: continuous Tietze_extension_func.
Proof.
unfold Tietze_extension_func;
  destruct constructive_definite_description as [g];
  simpl.
apply net_limit_in_closure with
  (S:=fun h:point_set (UniformTopology R_metric (fun _:point_set X => 0)
                           R_metric_is_metric X_nonempty) =>
     continuous (proj1_sig h)
     (Y:=MetricTopology R_metric R_metric_is_metric)) in n.
rewrite closure_fixes_closed in n.
unfold In in n.
apply <- convert_continuity; trivial.
apply continuous_functions_closed_in_uniform_metric.
red; intros.
exists i; split.
simpl; constructor.
red.
unfold convert_approx_to_uniform_space; simpl.
destruct extension_approximation_seq as [h [? []]]; simpl.
apply -> convert_continuity; trivial.
Qed.

End Tietze_extension_construction.

Lemma bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
                                point_set RTop),
  normal_sep X -> closed F -> continuous f ->
  (forall x:point_set (SubspaceTopology F), -1 <= f x <= 1) ->
  exists g:point_set X -> point_set RTop,
    continuous g /\ (forall x:point_set (SubspaceTopology F),
                     g (subspace_inc F x) = f x) /\
    (forall x:point_set X, -1 <= g x <= 1).
Proof.
intros.
destruct (classic (inhabited (point_set X))) as [Hinh|Hempty].
Require Import ClassicalChoice.
destruct (choice (fun
  (FG:{FG:Ensemble (point_set X) * Ensemble (point_set X) | let (F,G):=FG in
                    closed F /\ closed G /\ Intersection F G = Empty_set})
  (phi:point_set X -> point_set RTop) =>
   let (F,G):=proj1_sig FG in
   continuous phi /\ (forall x:point_set X, 0 <= phi x <= 1) /\
   (forall x:point_set X, In F x -> phi x = 0) /\
   (forall x:point_set X, In G x -> phi x = 1))) as [choice_fun].
intros.
destruct x as [[F' G] [? []]].
simpl.
Require Import UrysohnsLemma.
apply UrysohnsLemma; trivial.
pose (Urysohns_lemma_function := fun (F G:Ensemble (point_set X))
  (HF:closed F) (HG:closed G) (Hdisj:Intersection F G = Empty_set) =>
  exist (fun (f:point_set X -> point_set RTop) =>
           continuous f /\ (forall x:point_set X, 0 <= f x <= 1) /\
           (forall x:point_set X, In F x -> f x = 0) /\
           (forall x:point_set X, In G x -> f x = 1))
    (choice_fun (exist _ (F,G) (conj HF (conj HG Hdisj))))
    (H3 (exist _ (F,G) (conj HF (conj HG Hdisj))))).
clearbody Urysohns_lemma_function; clear choice_fun H3.
exists (Tietze_extension_func X F H0 f H1 H2 Hinh
  Urysohns_lemma_function).
split.
apply Tietze_extension_func_continuous.
split; intros.
apply Tietze_extension_func_is_extension.
apply Tietze_extension_func_bound.

exists (fun x:point_set X => False_rect _ (Hempty (inhabits x))).
split.
apply pointwise_continuity.
intros.
destruct (Hempty (inhabits x)).
split.
intros.
destruct x.
destruct (Hempty (inhabits x)).
intros.
destruct (Hempty (inhabits x)).
Qed.

Lemma open_bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
                                point_set RTop),
  normal_sep X -> closed F -> continuous f ->
  (forall x:point_set (SubspaceTopology F), -1 < f x < 1) ->
  exists g:point_set X -> point_set RTop,
    continuous g /\ (forall x:point_set (SubspaceTopology F),
                     g (subspace_inc F x) = f x) /\
    (forall x:point_set X, -1 < g x < 1).
Proof.
intros.
destruct (bounded_Tietze_extension_theorem _ F f) as [g0 [? []]]; trivial.
intros; split; left; apply H2.

pose (G := characteristic_function_to_ensemble (fun x:point_set X =>
  g0 x = 1 \/ g0 x = -1)).
destruct (UrysohnsLemma _ H G F) as [phi [? [? []]]]; trivial.
replace G with (inverse_image g0 (Union (Singleton 1) (Singleton (-1)))).
red; rewrite <- inverse_image_complement.
apply H3.
apply (closed_union2 (X:=RTop)); apply Hausdorff_impl_T1_sep;
  apply T3_sep_impl_Hausdorff; apply normal_sep_impl_T3_sep;
  apply metrizable_impl_normal_sep; exists R_metric;
  (apply R_metric_is_metric || apply RTop_metrization).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
constructor.
destruct H6.
left; destruct H6; trivial.
right; destruct H6; trivial.
destruct H6.
constructor.
destruct H6; [ left | right ]; rewrite H6; constructor.

apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H6.
destruct H6.
assert (-1 < g0 x < 1).
replace x with (subspace_inc F (exist _ x H7)) by reflexivity.
rewrite H4.
apply H2.
destruct H8.
destruct H6.
absurd (1 < 1); [ apply Rlt_irrefl | congruence ].
absurd (-1 < -1); [ apply Rlt_irrefl | congruence ].

exists (fun x:point_set X => phi x * g0 x).
split.
apply pointwise_continuity; intros.
apply product_continuous; apply continuous_func_continuous_everywhere;
  trivial.
split.
intros.
rewrite H9.
replace (1*g0 (subspace_inc F x)) with (g0 (subspace_inc F x)) by
  auto with real.
apply H4.
destruct x; trivial.

intros.
apply and_comm; apply Rabs_def2.
rewrite Rabs_mult.
rewrite (Rabs_right (phi x)); try (apply Rle_ge; apply H7).
destruct (classic (In G x)).
rewrite H8; trivial.
replace (0*Rabs (g0 x)) with 0; auto with real.
assert (Rabs (g0 x) < 1).
assert (Rabs (g0 x) <= 1).
destruct (H5 x).
unfold Rabs; destruct Rcase_abs; fourier.
destruct H11; trivial.
contradiction H10.
unfold Rabs in H11; destruct Rcase_abs in H11.
constructor; right.
replace (g0 x) with (- -(g0 x)) by auto with real.
f_equal; trivial.
constructor; left; trivial.
destruct (H7 x).
apply Rle_lt_trans with (Rabs (g0 x)); trivial.
pattern (Rabs (g0 x)) at 2; replace (Rabs (g0 x)) with (1*Rabs (g0 x)) by
  auto with real.
apply Rmult_le_compat_r; trivial.
apply Rabs_pos.
Qed.

Theorem Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble (point_set X)) (f:point_set (SubspaceTopology F) ->
                                point_set RTop),
  normal_sep X -> closed F -> continuous f ->
  exists g:point_set X -> point_set RTop,
    continuous g /\ (forall x:point_set (SubspaceTopology F),
                     g (subspace_inc F x) = f x).
Proof.
intros.
pose (U := characteristic_function_to_ensemble
      (fun x:point_set RTop => -1 < x < 1)).
pose proof (open_interval_homeomorphic_to_real_line).
fold U in H2.
simpl in H2.
destruct H2 as [a [b]].
pose (f0 := fun x:point_set (SubspaceTopology F) => subspace_inc U (a (f x))).
destruct (open_bounded_Tietze_extension_theorem X F f0) as [g0 [? []]];
  trivial. unfold f0.
apply continuous_composition.
apply subspace_inc_continuous.
apply continuous_composition; trivial.

intros.
unfold f0.
destruct (a (f x)).
destruct i; trivial.

assert (forall x:point_set X, In U (g0 x)).
intros.
constructor; apply H8.
Require Import ContinuousFactorization.
pose (g0_U := continuous_factorization g0 U H9).
assert (continuous g0_U).
apply factorization_is_continuous; trivial.

exists (fun x:point_set X => b (g0_U x)).
split.
apply continuous_composition; trivial.
intros.
unfold g0_U; unfold continuous_factorization.
generalize (H9 (subspace_inc F x)).
rewrite H7.
intros.
replace (exist _ (f0 x) i) with (a (f x)).
apply H4.
Require Import Proj1SigInjective.
apply (proj1_sig_injective (In U)).
simpl.
reflexivity.
Qed.


Require Import bnat.
Require Import FCF.
Require Import EqDec.
Set Implicit Arguments.
Check 0.

Definition vec_dotmod {n : nat} (q : nat) (a b : Vector.t nat n) :=
Vector.fold_left2 (fun acc v w => acc + (v * w) mod q)%nat 0%nat a b.

Check Vector.map2.

Definition vec_addmod {n : nat} (q : nat) (a b : Vector.t nat n) :=
Vector.map2 (fun x y => x + y mod q)%nat a b.

Definition ratRound01 (r : Rat) :=
if bleRat (ratDistance r 0) (ratDistance r 1) then false else true.

Fixpoint Sample_N {A : Set} {eqa : EqDec A} {eqva : forall n, EqDec (Vector.t A n)} (c : Comp A) (n : nat) : Comp (Vector.t A n) :=
match n with
| 0 => ret (Vector.nil A)
| S m => x <-$ c;
         tl <-$ Sample_N c m;
         ret (Vector.cons _ x _ tl)
end.

Definition Uniform_nat (N : nat) :=
x <-$ [0..N);
ret x.

Section LWE_Defs.
Context (q n : nat).
Context (posq : nz q).
Locate nz.
Definition LWEVec := Vector.t nat n.

Check Vector.fold_left2.

Definition Uniform_LWEVec := Sample_N (Uniform_nat q) n. (* computes x <-$ Z_q^n *)
Definition Uniform_q := Uniform_nat q. (* computes x <-$ Z_q *)
Context (chi : Comp (bnat q)).

Definition LWE_UniformDist (st input : unit) :=
a <-$ Uniform_LWEVec;
b <-$ Uniform_q;
ret ((a, b), tt).

Definition LWE_RealDist (s : LWEVec) (st input : unit) :=
a <-$ Uniform_LWEVec;
e <-$ chi;
ret ((a, (to_nat e) + (vec_dotmod q a s))%nat, tt).

Check LWE_RealDist.

Variable D : OracleComp unit (Vector.t nat n * nat) bool.

Definition LWE_Fake :=
[b, _] <-$2 D _ _ LWE_UniformDist tt;
ret b.

Definition LWE_Real (s : LWEVec) :=
[b, _] <-$2 D _ _ (LWE_RealDist s) tt;
ret b.

Definition LWE_Advantage (s : LWEVec) := |Pr[LWE_Fake] - Pr[LWE_Real s]|. (* this is a concrete rational number *)
End LWE_Defs.

(* should be able to say IND-CPA experiment for Regev LWE PKE is such that for all s,
|Regev_Advantage - LWE_Advantage| < negl(n) *)

Section Regev_PKE.
Context (q n m : nat).
Context (posq : nz q).
Context (chi : Comp (bnat q)).
Check Uniform_LWEVec.
Definition Sample_SK := Uniform_LWEVec q n.
Check Sample_SK.
Definition Regev_SecretKey := (Vector.t nat n).

Check LWEVec.

Check LWE_RealDist.

Definition Sample_PK (s : LWEVec n) := Sample_N
([a, b, _] <-$3 LWE_RealDist chi s tt tt;
 ret (a, b))
m.

Check Sample_PK.
Definition Regev_PublicKey := (Vector.t (Vector.t nat n * nat) m).

Definition Generate_SelectVector := Sample_N ({0,1}) m.
Definition SelectVector := Vector.t bool m.

Check Vector.const.

Check vec_addmod.

Definition SubsetSum (pk: Regev_PublicKey) (sel : SelectVector) :=
Vector.fold_left2 (fun acc p (b : bool) => if b then
                   match p, acc with
                   | (a, b), (aa, ab) => (vec_addmod q a aa, b + ab mod q)%nat
                   end
                    else acc)
                   (Vector.const 0%nat n, 0%nat) pk sel.

Check SubsetSum.

Check div.

Check bnat_mod_nat.

Definition Regev_PKEnc (pk: Regev_PublicKey) (m : bool) :=
sel <-$ Generate_SelectVector;
[a, b] <-2 SubsetSum pk sel;
b <- if m then
      (b + (div q 2) mod q)%nat
      else b;
ret (a, b).

Definition Regev_Ciphertext := (Vector.t nat n * nat)%type.

Definition Regev_PKDec (s : Regev_SecretKey) (c : Regev_Ciphertext) := match c with
| (a, b) => let r := (b - (vec_dotmod q a s)) in
            ratRound01 ( (r/1) * (2 / 1) * (1 / q))%rat
end.

Check Vector.fold_left.

Definition admissible_chi (k : nat) :=
es <-$ Sample_N chi k;
sum <- Vector.fold_left (fun a b => a + (to_nat b))%nat (0%nat) es;
ret (leb sum (div q 4)).

Lemma correct_decrypt (delta : Rat) (s : Regev_SecretKey) (pk: Regev_PublicKey) (c : Regev_Ciphertext) (msg : bool) :
In pk (getSupport (Sample_PK s)) ->
In c (getSupport (Regev_PKEnc pk msg)) ->
(forall k : nat, k < m -> Pr[admissible_chi k] <= delta) ->
Regev_PKDec s c = msg.
Abort.


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Import Turing.Turing.
Require Import Turing.LangRed.
Require Import Turing.LangDec.

(* ---------------------------------------------------------------------------*)

(* ------------------------ BEGIN UTILITY RESULTS ---------------------- *)
(** See Example 5.26 (pp 237):
    Let <M> = p.

    Function F3 (defined below) maps the input <M> to the output <M, M1>,
    where M1 is the machine that rejects all inputs.
*)

Definition F3 p :=
    encode_pair (p , [[ Build (fun _ => REJECT) ]]).

Lemma false_equiv_reject:
    PRecognizes (fun _ => REJECT) (fun _ => False).
Proof.
    intros.
    apply p_recognizes_def; intros; run_simpl_all.
Qed.

Lemma E_tm_inv:
    forall w,
    E_tm w ->
    exists m, m = decode_machine w /\
    forall i, run m i <> Accept.
Proof.
    intros.
    unfold E_tm in *.
    rewrite is_empty_never_accept_rw in H.
    unfold NeverAccept in *.
    eauto.
Qed.

Lemma EQ_tm_inv:
    forall w,
    EQ_tm w ->
    exists m1 m2, w = encode_pair (encode_machine m1, encode_machine m2) /\
    forall i, run m1 i = Accept <-> run m2 i = Accept.
Proof.
    intros.
    unfold EQ_tm in *.
    destruct (decode_pair w) as (w1, w2) eqn:Hr.
    exists (decode_machine w1).
    exists (decode_machine w2).
    split. {
    run_simpl_all.
    rewrite <- Hr.
    run_simpl_all.
    reflexivity.
    }
    intros.
    unfold Lang, Equiv in *.
    auto.
Qed.

(* Given two machines m1 m2 you will need to show:
    1. Whenever m1 accepts, m2 accepts.
    2. Whenever m2 accepts, m1 accepts.
    Then EQ_tm (m1, m2) holds.
*)
Lemma EQ_tm_def:
    forall m1 m2 w,
    w = encode_pair (encode_machine m1, encode_machine m2) ->
    (forall i, run m1 i = Accept -> run m2 i = Accept) ->
    (forall i, run m2 i = Accept -> run m1 i = Accept) ->
    EQ_tm w.
Proof.
    intros.
    unfold EQ_tm in *.
    destruct (decode_pair w) as (w1, w2) eqn:Hr.
    rewrite H in *.
    run_simpl_all.
    inversion Hr; subst; clear Hr.
    unfold Equiv.
    unfold Lang.
    run_simpl_all.
    split; intros; auto.
Qed.

(**
  To construct a term of E_tm we must show that the machine
  does _not_ accept any input.
  *)
Lemma E_tm_def:
    forall m w,
    w = encode_machine m ->
    (forall i, run m i <> Accept) ->
    E_tm w.
Proof.
    intros.
    unfold E_tm.
    unfold IsEmpty, Empty, Recognizes.
    subst.
    run_simpl_all.
    split; intros. {
    assert (Hx := H0 i).
    contradiction.
    }
    contradiction.
Qed.

Lemma f3_rw:
    forall w,
    F3 w = encode_pair ([[decode_machine w]], [[Build (fun _ => REJECT)]]).
Proof.
    intros.
    run_simpl_all.
    unfold F3.
    reflexivity.
Qed.

Lemma f3_inv:
    forall w m1 m2,
    F3 w = encode_pair ([[m1]], [[m2]]) ->
    w = [[m1]] /\ m2 = Build (fun _ => REJECT).
Proof.
    unfold F3; intros.
    apply encode_pair_ext in H.
    inversion H; subst; clear H.
    apply encode_machine_ext in H2.
    auto.
Qed.
(* -------------------------- END OF UTILITY RESULTS ---------------------- *)

(**

Medium.
* Use E_def, EQ_tm_def to construct an EQ_tm/E_tm.
* Use E_tm_inv, EQ_tm_inv to destruct an EQ/E assumption.
* Use run_simpl_all to simplify assumptions `run (Build _)`.
 *)
Theorem E_tm_red_EQ_tm_1:
  forall w, E_tm w -> EQ_tm (F3 w).
Proof.

Admitted.

(**

Medium.

* Use E_def, EQ_tm_def to construct an EQ_tm/E_tm.
* Use E_tm_inv, EQ_tm_inv to destruct an EQ/E assumption.
* Use run_simpl_all to simplify assumptions `run (Build _)`.

 *)
Theorem E_tm_red_EQ_tm_2:
  forall w, EQ_tm (F3 w) -> E_tm w.
Proof.

Admitted.

(**

Easy. Solve Exercise 5.26 of the book (pp 237).

 *)
Theorem E_tm_red_EQ_tm:
  E_tm <=m EQ_tm.
Proof.

Admitted.

(**

Easy. Prove Theorem 5.4 (pp 220) using map-reducibility (Exercise 5.26).

 *)
Theorem thm_5_4:
  ~ Decidable EQ_tm.
Proof.

Admitted.

(**

Easy. Solve Exercise 5.6 (pp 239; solution in pp 242). You should use `reducible_def` and then unfold Reduction.

 *)
Theorem ex_5_6:
  forall A B C, A <=m B -> B <=m C -> A <=m C.
Proof.
intros A B C (f, Hab) (g, Hbc).

Admitted.

(**

Solve Exercise 5.7 (pp 239; solution in pp 242).

 *)
Theorem ex_5_7:
  forall A, Recognizable A -> A <=m compl A -> Decidable A.
Proof.

Admitted.

(**

Easy. Show that every recognizable language is map-reducible to A_tm.

 *)
Theorem ex_5_22_a:
  forall A, Recognizable A -> A <=m A_tm.
Proof.
intros A (M, Hd). apply reducible_def with (f:= fun w => <[ M, w ]> ).

Admitted.

(**

Easy. Show that every language map-reducible to A_tm is recognizable.

 *)
Theorem ex_5_22_b:
  forall A, A <=m A_tm -> Recognizable A.
Proof.

Admitted.

(**

Easy. Show that A is Turing-recognizable iff A <=m ATM (Exercise 5.22, pp 240).

 *)
Theorem ex_5_22:
  forall A, Recognizable A <-> A <=m A_tm.
Proof.

Admitted.

(**

Easy. One theorem can help you solve this result.

 *)
Theorem not_dec_to_not_rec:
  forall L, ~ Decidable L -> Recognizable (compl L) -> ~ Recognizable L.
Proof.

Admitted.

(**

Hard. Easy to solve if done in pen-and-paper first.
Some results needed to prove Exercise 5.22 are helpful here.

 *)
Theorem a_red_not_a_tm:
  forall A B, compl A <=m B -> Recognizable B -> A <=m compl A_tm.
Proof.

Admitted.


Require Export Reals.
Require Import ComhCoq.GenTacs.
Require Import ComhCoq.Extras.LibTactics.
Open Scope R_scope.

Ltac Rmult_le_zero :=
  match goal with
  | [ |- 0 <= ?y1 * ?y2] =>
    replace 0 with (0 * 0);[ | ring];
    apply Rmult_le_compat;[apply Rle_refl | apply Rle_refl | ..]
  end.

(** Splits the goal into 2 subgoals based on d <= t or t < d*)
Ltac Rleltcases d t U :=  let H := fresh in lets H : Rle_or_lt d t;
                                            let U1 := fresh U in elim_intro H U1 U1.

Lemma not_Rle_lt : forall (r1 r2 : R),
  ~r1 <= r2 -> r2 < r1. intros. addHyp (Rlt_or_le r1 r2). invertClear H0.
  apply False_ind. apply H. apply Rlt_le. assumption.
  apply Rle_lt_or_eq_dec in H1. invertClear H1. assumption.
  rewrite H0 in H. apply False_ind. apply H. apply Rle_refl. Qed.

Lemma RltMinusBothSides : forall (r1 r2 : R),
  r2 < r1 -> 0 < (r1 - r2).
  intros. apply Rnot_le_lt. unfold not. intros.
  apply Rplus_le_compat_l with (r := r2) in H0. rewrite Rplus_minus in H0.
  rewrite Rplus_0_r in H0. eapply Rle_not_lt. apply H0. apply H.
  Qed.

(**** Rle ****)

Ltac Rle_trans_red :=
  match goal with
  | [H1 : ?r1 <= ?r2, H2 : ?r2 <= ?r3 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[apply H1 | apply H2]
  | [H1 : ?r1 <= ?r2 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[apply H1 | ]
  | [H2 : ?r2 <= ?r3 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[ | apply H2]
  end.

Ltac Rle_trans_rev_red :=
  match reverse goal with
  | [H1 : ?r1 <= ?r2, H2 : ?r2 <= ?r3 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[apply H1 | apply H2]
  | [H1 : ?r1 <= ?r2 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[apply H1 | ]
  | [H2 : ?r2 <= ?r3 |- ?r1 <= ?r3] =>
    eapply Rle_trans;[ | apply H2]
  end.

Ltac Rplus_le_cancel_middle :=
  match goal with
  | [ |- ?x1 + ?r + ?x2 <= ?y1 + ?r + ?y2] =>
    replace (x1 + r + x2) with (x1 + x2 + r);[ | ring];
    replace (y1 + r + y2) with (y1 + y2 + r);[ | ring];
    apply Rplus_le_compat_r
  | [ |- ?x1 + ?r <= ?y1 + ?r + ?y2] =>
    replace (y1 + r + y2) with (y1 + y2 + r);[ | ring];
    apply Rplus_le_compat_r
  end.

Ltac Rle_ring_solve := apply Req_le; simpl; ring.

Ltac Rle_refl_solve := apply Rle_refl.

Lemma Rle_plus_r : forall (x y : R),
  0 <= y -> x <= x + y. intros. apply Rle_trans with (r2 := x + 0).
  replace (x + 0) with x. apply Rle_refl. ring.
  apply Rplus_le_compat. apply Rle_refl. assumption. Qed.

Lemma Rle_plus_l : forall (x y : R),
  0 <= y -> x <= y + x. intros. rewrite Rplus_comm.
  apply Rle_plus_r. assumption. Qed.

Lemma RleMinusBothSides : forall (r1 r2 : R),
  r2 <= r1 -> 0 <= (r1 - r2). intros. apply Rle_lt_or_eq_dec in H.
  inversion H. apply RltMinusBothSides in H0. apply Rlt_le. assumption.
  rewrite H0. rewrite Rminus_diag_eq. apply Rle_refl. reflexivity. Qed.

Lemma Rmult_le_0_compat : forall r1 r2 : R,
  0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2.
  intros. simpl. rewrite <- (Rmult_0_r 0). apply Rmult_le_compat;
  try assumption; try apply Rle_refl. Qed.

Lemma Rle_zero_plus : forall r1 r2 : R,
  0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2.
  intros. rewrite <- Rplus_0_r at 1. apply Rplus_le_compat; assumption. Qed.

Lemma Rle_zero_mult : forall r1 r2 : R,
  0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2. intros. rewrite <- (Rmult_0_l r2)at 1.
  apply Rmult_le_compat_r; assumption. Qed.

Lemma RlePlusExistsR : forall (r1 r2 : R),
  r1 <= r2 -> exists r3, r2 = r1 + r3 /\ 0 <= r3. intros.
  exists (r2 - r1). split. ring. apply (Rplus_le_reg_r r1).
  replace (r2 - r1 + r1) with r2; try ring. rewrite Rplus_0_l.
  assumption. Qed.

Lemma RlePlusExistsL : forall (r1 r2 : R),
  r1 <= r2 -> exists r3, r2 = r3 + r1 /\ 0 <= r3. intros.
  apply RlePlusExistsR in H. invertClear H.
  exists x. rewrite Rplus_comm. assumption. Qed.

Lemma Rle_or_le : forall (r1 r2 : R), r1 <= r2 \/ r2 <= r1.
  intros. addHyp (Rlt_or_le r1 r2). invertClear H. left.
  apply Rlt_le. assumption. right. assumption. Qed.

Lemma Rplus_le_swap_rr : forall (x y z : R),
  x <= y + z -> x - z <= y. intros. eapply Rplus_le_reg_r.
  eapply Rle_trans;[ | apply H ].
  apply Req_le. ring. Qed.

Lemma Rplus_le_swap_rl : forall (x y z : R),
  x <= y + z -> x - y <= z. intros. rewrite Rplus_comm in H.
  apply Rplus_le_swap_rr. assumption. Qed.

Lemma Rplus_le_swap_lr : forall (x y z : R),
  x + y <= z -> x <= z - y. intros. eapply Rplus_le_reg_r.
  eapply Rle_trans. apply H. apply Req_le. ring. Qed.

Lemma Rplus_le_swap_ll : forall (x y z : R),
  x + y <= z -> y <= z - x. intros. rewrite Rplus_comm in H.
  apply Rplus_le_swap_lr. assumption. Qed.

Lemma Rminus_le_swap_rr : forall (x y z : R),
  x <= y - z -> x + z <= y. intros. eapply Rplus_le_reg_r.
  eapply Rle_trans;[ | apply H]. apply Req_le. ring. Qed.

Lemma Rminus_le_swap_lr : forall (x y z : R),
  x - y <= z -> x <= z + y. intros. eapply Rplus_le_reg_r.
  eapply Rle_trans. apply H. apply Req_le. ring. Qed.

Lemma Rplus_le_weaken_lr : forall (x y z : R), x + y <= z -> 0 <= y -> x <= z.
  intros. eapply Rle_trans;[ |apply H]. apply Rle_plus_r. assumption. Qed.

Lemma Rplus_le_weaken_ll : forall (x y z : R), x + y <= z -> 0 <= x -> y <= z.
  intros. rewrite Rplus_comm in H. eapply Rplus_le_weaken_lr. apply H. assumption.
  Qed.

Lemma Rplus_le_weaken_rr : forall (x y z : R), 0 <= z -> x <= y -> x <= y + z.
  intros. replace x with (x + 0). eapply Rplus_le_compat; assumption.
  ring. Qed.

Lemma Rplus_le_weaken_rl : forall (x y z : R), 0 <= y -> x <= z -> x <= y + z.
  intros. rewrite Rplus_comm. apply Rplus_le_weaken_rr;assumption. Qed.

Lemma Rminus_le_weaken_lr : forall (x y z : R), 0 <= y -> x <= z -> x - y <= z.
  intros. replace z with (z - 0);[ | ring]. eapply Rplus_le_compat.
  assumption. apply Ropp_le_contravar. assumption. Qed.

(** Tries to solve an inequality on real numbers.*)
Ltac Rplus_le_tac :=
  match goal with
  | [ H1 : ?r1 <= ?r3, H2 : ?r2 <= ?r4 |- ?r1 + ?r2 <= ?r3 + ?r4] =>
    apply Rplus_le_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 <= ?r3, H2 : ?r2 <= ?r4 |- ?r2 + ?r1 <= ?r3 + ?r4] =>
    rewrite Rplus_comm; apply Rplus_le_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 <= ?r2|- ?r + ?r1 <= ?r + ?r2] =>
    apply Rplus_le_compat_l;apply H1
  | [ H1 : ?r1 <= ?r2|- ?r1 + ?r <= ?r2 + ?r] =>
    apply Rplus_le_compat_r;apply H1
  | [ |- ?r + ?r1 <= ?r + ?r2] =>
    apply Rplus_le_compat_l
  | [ |- ?r1 + ?r <= ?r2 + ?r] =>
    apply Rplus_le_compat_r
  | [ H : ?r1 + ?r <= ?r2 + ?r |- ?r1 <= ?r2] =>
    apply Rplus_le_reg_l in H; assumption
  | [ H : ?r + ?r1 <= ?r + ?r2 |- ?r1 <= ?r2] =>
    apply Rplus_le_reg_r in H; assumption
  | [ H : ?x <= ?y + ?z |- ?x - ?z <= ?y] =>
    apply Rplus_le_swap_rr; assumption
  | [ H : ?x + ?y <= ?z |- ?y <= ?z - ?x] =>
    apply Rplus_le_swap_ll; assumption
  | [ H : ?x + ?y <= ?z |- ?x <= ?z - ?y] =>
    apply Rplus_le_swap_lr; assumption
  | [ H : ?x <= ?y + ?z |- ?x - ?y <= ?z] =>
    apply Rplus_le_swap_rl; assumption
  | [ |- ?r1 <= ?r1 + _] => apply Rle_plus_r
  | [ |- ?r1 <= _ + ?r1] => apply Rle_plus_l
  | [ H : ?x + ?y <= ?z |- ?x <= ?z] =>
    eapply Rplus_le_weaken_lr; apply H
  | [ H : ?x + ?y <= ?z |- ?y <= ?z] =>
    eapply Rplus_le_weaken_ll; apply H
  end.

(**** Rlt ****)

Ltac Rlt_trans_red :=
  match goal with
  | [H1 : ?r1 < ?r2, H2 : ?r2 < ?r3 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[apply H1 | apply H2]
  | [H1 : ?r1 < ?r2 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[apply H1 | ]
  | [H2 : ?r2 < ?r3 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[ | apply H2]
  end.

Ltac Rlt_trans_rev_red :=
  match reverse goal with
  | [H1 : ?r1 < ?r2, H2 : ?r2 < ?r3 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[apply H1 | apply H2]
  | [H1 : ?r1 < ?r2 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[apply H1 | ]
  | [H2 : ?r2 < ?r3 |- ?r1 < ?r3] =>
    eapply Rlt_trans;[ | apply H2]
  end.

Ltac Rplus_lt_cancel_middle :=
  match goal with
  | [ |- ?x1 + ?r + ?x2 < ?y1 + ?r + ?y2] =>
    replace (x1 + r + x2) with (x1 + x2 + r);[ | ring];
    replace (y1 + r + y2) with (y1 + y2 + r);[ | ring];
    apply Rplus_lt_compat_r
  | [ |- ?x1 + ?r < ?y1 + ?r + ?y2] =>
    replace (y1 + r + y2) with (y1 + y2 + r);[ | ring];
    apply Rplus_lt_compat_r
  end.

Lemma Rlt_plus_r : forall (x y : R),
  0 < y -> x < x + y. intros. apply Rle_lt_trans with (r2 := x + 0).
  replace (x + 0) with x. apply Rle_refl. ring.
  apply Rplus_le_lt_compat. apply Rle_refl. assumption. Qed.

Lemma Rlt_plus_l : forall (x y : R),
  0 < y -> x < y + x. intros. rewrite Rplus_comm.
  apply Rlt_plus_r. assumption. Qed.

Lemma Rlt_zero_plus : forall r1 r2 : R,
  0 < r1 -> 0 < r2 -> 0 < r1 + r2.
  intros. rewrite <- Rplus_0_r at 1. apply Rplus_lt_compat; assumption. Qed.

Lemma RltPlusExistsR : forall (r1 r2 : R),
  r1 < r2 -> exists r3, r2 = r1 + r3 /\ 0 < r3. intros.
  exists (r2 - r1). split. ring. apply (Rplus_lt_reg_r r1).
  replace (r2 - r1 + r1) with r2; try ring. rewrite Rplus_0_l.
  assumption. Qed.

Lemma RltPlusExistsL : forall (r1 r2 : R),
  r1 < r2 -> exists r3, r2 = r3 + r1 /\ 0 < r3. intros.
  apply RltPlusExistsR in H. invertClear H.
  exists x. rewrite Rplus_comm. assumption. Qed.

Lemma RltExistsBetween (r1 r2 : R) : r1 < r2 -> exists r3,
  r1 < r3 < r2. intros. addHyp (RltPlusExistsL r1 r2 H). invertClear H0.
  invertClear H1. exists (r1 + x/2). assert (0 < x/2). rewrite double_var in H2.
  addHyp (Rlt_or_le 0 (x/2)). invertClear H1. assumption.
  assert (x / 2 + x / 2 <= 0 + 0). apply Rplus_le_compat;
  assumption. replace (0 + 0) with 0 in H1; [|ring].
  apply False_ind. eapply Rlt_not_le. apply H2. assumption.
  assert (x / 2 < x). rewrite double_var. apply Rlt_plus_l.
  assumption. split. apply Rlt_plus_r. assumption. rewrite H0.
  rewrite Rplus_comm. apply Rplus_lt_le_compat. assumption.
  apply Rle_refl. Qed.

Lemma Rplus_lt_swap_rl : forall (x y z : R),
  x < y + z -> x - y < z. intros. eapply Rplus_lt_compat_r in H.
  eapply Rlt_le_trans. unfold Rminus. apply H. apply Req_le.
  ring. Qed.

Lemma Rplus_lt_swap_rr : forall (x y z : R),
  x < y + z -> x - z < y. intros. rewrite Rplus_comm in H.
  apply Rplus_lt_swap_rl. assumption. Qed.

Lemma Rplus_lt_swap_ll : forall (x y z : R),
  x + y < z -> y < z - x. intros. eapply Rplus_lt_compat_r in H.
  unfold Rminus. eapply Rle_lt_trans;[| apply H]. apply Req_le.
  ring. Qed.

Lemma Rplus_lt_swap_lr : forall (x y z : R),
  x + y < z -> x < z - y. intros. rewrite Rplus_comm in H.
  apply Rplus_lt_swap_ll. assumption. Qed.

Lemma Rminus_lt_swap_rr : forall (x y z : R),
  x < y - z -> x + z < y. intros. rewrite <- (Ropp_involutive z).
  apply Rplus_lt_swap_rr. apply H. Qed.

Lemma Rminus_lt_swap_lr : forall (x y z : R),
  x - y < z -> x < z + y. intros. rewrite <- (Ropp_involutive y).
  apply Rplus_lt_swap_lr. apply H. Qed.

Lemma Rplus_lt_reg_l: forall r r1 r2 : R, r1 + r < r2 + r -> r1 < r2.
  intros. replace r2 with (r2 + r - r);[ | ring]. apply Rplus_lt_swap_lr.
  assumption. Qed.

Lemma Rplus_lt_reg_r: forall r r1 r2 : R, r + r1 < r + r2 -> r1 < r2.
  intros. apply (Rplus_lt_reg_l r). my_applys_eq H;ring. Qed.

Lemma Rplus_lt_weaken_lr : forall (x y z : R), x + y < z -> 0 <= y -> x < z.
  intros. eapply Rle_lt_trans;[ |apply H]. apply Rle_plus_r. assumption. Qed.

Lemma Rplus_lt_weaken_ll : forall (x y z : R), x + y < z -> 0 <= x -> y < z.
  intros. rewrite Rplus_comm in H. eapply Rplus_lt_weaken_lr. apply H. assumption.
  Qed.

Lemma Rplus_lt_weaken_rr : forall (x y z : R), 0 <= z -> x < y -> x < y + z.
  intros. replace x with (x + 0). eapply Rplus_lt_le_compat; assumption.
  ring. Qed.

Lemma Rplus_lt_weaken_rl : forall (x y z : R), 0 <= y -> x < z -> x < y + z.
  intros. rewrite Rplus_comm. apply Rplus_lt_weaken_rr;assumption. Qed.

Lemma Rminus_lt_weaken_lr : forall (x y z : R), 0 <= y -> x < z -> x - y < z.
  intros. replace z with (z - 0);[ | ring]. eapply Rplus_lt_le_compat.
  assumption. apply Ropp_le_contravar. assumption. Qed.

(** Tries to solve an inequality on real numbers.*)
Ltac Rplus_lt_tac :=
  match goal with
  | [ H1 : ?r1 < ?r3, H2 : ?r2 < ?r4 |- ?r1 + ?r2 < ?r3 + ?r4] =>
    apply Rplus_lt_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 <= ?r3, H2 : ?r2 < ?r4 |- ?r1 + ?r2 < ?r3 + ?r4] =>
    apply Rplus_le_lt_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 < ?r3, H2 : ?r2 <= ?r4 |- ?r1 + ?r2 < ?r3 + ?r4] =>
    apply Rplus_lt_le_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 < ?r3, H2 : ?r2 < ?r4 |- ?r2 + ?r1 < ?r3 + ?r4] =>
    rewrite Rplus_comm; apply Rplus_lt_compat;[apply H1 | apply H2]
  | [ H1 : ?r1 < ?r2|- ?r + ?r1 < ?r + ?r2] =>
    apply Rplus_lt_compat_l;apply H1
  | [ H1 : ?r1 < ?r2|- ?r1 + ?r < ?r2 + ?r] =>
    apply Rplus_lt_compat_r;apply H1
  | [ H : ?r1 + ?r < ?r2 + ?r |- ?r1 < ?r2] =>
    apply Rplus_lt_reg_l in H; assumption
  | [ H : ?r + ?r1 < ?r + ?r2 |- ?r1 < ?r2] =>
    apply Rplus_lt_reg_r in H; assumption
  | [ H : ?x < ?y + ?z |- ?x - ?z < ?y] =>
    apply Rplus_lt_swap_rr; assumption
  | [ H : ?x + ?y < ?z |- ?y < ?z - ?x] =>
    apply Rplus_lt_swap_ll; assumption
  | [ H : ?x < ?y + ?z |- ?x - ?y < ?z] =>
    apply Rplus_lt_swap_rl; assumption
  | [ H : ?x + ?y < ?z |- ?x < ?z - ?y] =>
    apply Rplus_lt_swap_lr; assumption
  | [ |- ?r1 < ?r1 + _] => apply Rlt_plus_r
  | [ |- ?r1 < _ + ?r1] => apply Rlt_plus_l
  | [ H : ?x + ?y < ?z |- ?x < ?z] =>
    eapply Rplus_lt_weaken_lr; apply H
  | [ H : ?x + ?y < ?z |- ?y < ?z] =>
    eapply Rplus_lt_weaken_ll; apply H
  end.

(** Takes a hypothesis H of type r1 < r2 and gives a hypothesis U of type
r2 = r1 + d'*)
Ltac Rlttoplus H d' U := let Q1 := fresh in lets Q1 : RltPlusExistsL H;
  let U1 := fresh U in let U2 := fresh U in decompExAnd Q1 d' U1 U2.