Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class SeparationLogic_Precise
        (L: Language)
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  precise: expr -> Prop;
  precise_sepcon: forall x y, precise x -> precise y -> precise (x * y)
}.

(*
This rule is not sound for garbage collect SL
precise_impp: forall x y, |-- x --> y -> precise y -> precise x

The following is not sound e.g. when x := a = 0 && emp, y := a = 1, z := a = 0
sepcon_cancel: forall x y z, |-- (x * z) --> (y * z) -> precise z -> |-- (x --> y)
*)

Class SeparationLogic_PureFact
        (L: Language)
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (Gamma: Provable L) := {
  pure_fact: expr -> Prop;
  pure_falsep: pure_fact FF;
  pure_andp: forall x y, pure_fact x -> pure_fact y -> pure_fact (x && y);
  pure_orp: forall x y, pure_fact x -> pure_fact y -> pure_fact (x || y);
  pure_impp: forall x y, pure_fact x -> pure_fact y -> pure_fact (x --> y);
  pure_specon: forall x y, pure_fact x -> pure_fact y -> pure_fact (x * y);
  pure_wand: forall x y, pure_fact x -> pure_fact y -> pure_fact (x -* y);
  andp_sepcon: forall x y z, pure_fact x -> |-- (x && (y * z)) <--> ((x && y) * z)
}.


(** *Notice: This file is very sketchy at the moment. Read at your own risk.*)

From mathcomp.ssreflect Require Import ssreflect seq ssrbool ssrnat.

Require Import Coq.ZArith.ZArith.

Require Import compcert.common.Memory.

(*Require Import VST.concurrency.juicy_machine.

Require Import VST.concurrency.common.HybridMachineSig.
Require Import VST.concurrency.common.scheduler.*)
Require Import VST.msl.eq_dec.

Require Import VST.concurrency.common.konig.

Require Import VST.msl.Axioms.

Section cardinality.
(*Here goes cardinality stuff*)
End cardinality.

(**  We will reduce the safety result
     to a subset of the type satisfign
     some predicate [Filter]. Given that
     the relation R presrves the predicate.
*)
Section filtered_konig.
  Variable X: Type.
  Variable Filter: X -> Prop.
  Variable R: X->X->Prop.
  Hypothesis em: forall P, P \/ ~ P.
  Hypothesis  preservation :  forall P P', Filter P -> R P P' -> Filter P'.

  (* From the relation R, we derive a, dependently typed relation
     RR for all elements satyisfying the predicate Filter*)
  Record TT :Type:= mkTT {thing: X; prf: Filter thing}.
  Inductive RR: TT->TT->Prop:=
  | stepstep: forall P x' (stp: R (thing P) x'), RR P (mkTT x' (preservation _ _ (prf P) stp)).

  Lemma filtered_to_unfiltered_safe:
    forall P,
      konig.safe _ RR P ->
      konig.safe X R (thing P).
  Proof.
    cofix COFIX.
    move => P sf.
    inversion sf; subst x.
    inversion H; subst P0.
    apply: (safe_cons _ _ (thing P) x'0 stp).
    replace x'0 with (thing x').
    by apply: COFIX.
    by rewrite -H2.
  Qed.
  Lemma unfiltered_to_filtered_safeN:
    forall n P,
      konig.safeN X R n (thing P) ->
      konig.safeN _ RR n P.
  Proof.
    induction n.
    - constructor.
    - move=> P sf.
      inversion sf.
      apply: (safeS _ _ n P (mkTT x' (preservation _ _ (prf P) H0)))=> /=.
      by constructor.
      by apply: IHn.
  Qed.

  (* the number of different elements in X is finite *)
  Inductive cardinality {X} (P:X->Prop): nat -> Prop:=
  |Cardinality n (f:nat-> X): (forall i j, i<n -> j<n -> i<>j -> f(i)<>f(j)) ->
                           (forall i, i<n -> P (f i)) ->
                           (forall x, P x -> exists i, i < n /\ f i = x) ->
                           cardinality P n.
  Inductive cardinality' {X} (P:X->Prop): nat -> Prop:=
  |Cardinality' n (f:nat-> X): (forall i j, i<n -> j<n -> i<>j  -> f(i)<>f(j)) ->
                            (forall i, i<n -> P (f i)) ->
                            cardinality' P n.

  Lemma repetition_dec: forall (f:nat -> X) x n,  (exists i, i<n /\ f(i) = x) \/ (forall i, i<n -> f i <> x).
              Proof.
                induction n=>//.
                - constructor 2 => //.
                - move: IHn=> [[]i [] A B| A].
                  + constructor; exists i; split =>//; auto.
                  + destruct (em (eq (f n) x)).
                    * left; exists n; split=> //.
                    * right=> i ineq.
                      { destruct (Nat.eq_dec i n).
                        - subst i => //.
                        - apply: A=>//.
                          destruct (le_lt_dec n i) as [HH|HH]; move: HH=> /leP // /leP ineq2.
                          contradict n0. move: ineq=> /leP ineq.
                        omega.
                      }
              Qed.
  Lemma finite_cardinality:
    forall (P:X->Prop) (EM: forall x, P x \/ ~ P x), finite P -> exists n, cardinality P n.
  Proof.
    move => P EM [] n [] f FIN.
    cut (forall n2,
            (exists f0 n0,
                (n0 <= n2) /\
               (forall i j, i<n0 -> j<n0 -> i <> j -> f0(i)<>f0(j)) /\
               (forall i, i<n0 -> P (f0 i)) /\
               (forall i, i<n2 -> P (f i) -> exists i0, i0<n0 /\ f i = f0 i0)  /\
               (forall i, i<n0 -> exists j, j<n2 /\ f j = f0 i)) \/
               (exists n1, n1<=n2 /\ cardinality P n1)
        ).
    { move => HH; move: (HH n) => [ [] f0 [] n0 [] A [] B []  C [] D E  | [] n0 [] HH0 HH1 ].
      - exists n0; exists f0 => //.
        move =>  x Px. move: (FIN x Px)=> [] i [] /leP /D D' fi.
        move: Px; rewrite -fi => /D' [] i0 [] ineqi0 fifi0. rewrite fifi0.
        by exists i0; split.
      - by exists n0.
    }
    { induction n2.
      - left; exists f, 0; repeat split=>//.
      - move: IHn2=> [].
        + move => [] f0 [] n0 [] ineq02 [] inject0 [] prf0 [] subset complete.
          destruct (Compare.le_or_le_S n n2) as [A | A]; move:A=> /leP ineq.
          * right. exists n0; split => //; auto.
            apply: (Cardinality P n0 f0)=> //.
            move=> x Px. move: (FIN x Px)=> [] i [] /leP ineq' fi.
            assert (H:i< n2).
            { apply/ltP; move: ineq' ineq=> /ltP ineq' /leP ineq; omega. }
            move: Px; rewrite -fi => /(subset _ H) []  i' [] ineq0' fifo.
            by rewrite fifo; exists i'; split.
          * { pose (new_x:= f n2).
              (*check if new_x is in P*)
              destruct (EM new_x) as [Pnew_x | nPnew_x].
              - left; destruct (repetition_dec f new_x n2) as [HH|HH]; move: HH.
                + move=> [] i [] ineq2 fi.
                  { exists f0, n0; repeat split=>//; auto.
                    - move=> j ineqj Px.
                      destruct (Nat.eq_dec j n2).
                      + subst j.
                        move: Px.
                        rewrite -/new_x -fi => /(subset i ineq2) => [] [] i' [] ineqi' fifi'.
                        by exists i'; split.
                      + apply: subset=>//.
                        destruct (lt_dec j n2) as [HH|HH];
                          move:HH ineqj=> /leP // /leP HH /leP ineqj. by contradict n1; omega.
                    - move => i0 /complete [] j [] ineq0 fjfi0.
                      exists j; split=>//.
                      apply/leP. move: ineq0=> /leP HH; omega.
                  }
                + { move => HH.
                    pose (f0':= eq_dec.upd f0 n0 new_x); exists f0', n0.+1; repeat split => //.
                    - move => i j ineqi ineqj diffij.
                      destruct (Nat.eq_dec i n0);destruct (Nat.eq_dec j n0); try subst=> //.
                      + rewrite /f0' eq_dec.upd_eq eq_dec.upd_neq=> // .
                        assert (Hj: j < n0).
                        { apply/ltP; move: ineqj=> /ltP ineqj; omega. }
                        move: Hj=> /complete [] j' []ineq' <-.
                        move => eq.
                        eapply HH.
                        exact ineq'.
                        symmetry; exact eq.
                      + rewrite /f0' eq_dec.upd_eq eq_dec.upd_neq=> // .
                        assert (Hi: i < n0).
                        { apply/ltP; move: ineqi=> /ltP ineqi; omega. }
                        move: Hi=> /complete [] i' []ineq' <-.
                        move => eq.
                        eapply HH.
                        exact ineq'.
                        exact eq.
                        move=> HHH; apply: diffij; symmetry; exact HHH.
                      + rewrite /f0' eq_dec.upd_neq=>//; auto;
                        rewrite eq_dec.upd_neq=>//; auto.
                        assert (ineqi':  i < n0).
                        { apply/ltP ; move: ineqi=> /ltP ineqi; omega. }
                        assert (ineqj':  j < n0).
                        { apply/ltP ; move: ineqj=> /ltP ineqj; omega. }
                          by move: inject0 => /(_ _ _ ineqi' ineqj' diffij).
                    - move=> i0 ineqi0; destruct (Nat.eq_dec i0 n0).
                        by subst; rewrite /f0' eq_dec.upd_eq.
                        rewrite /f0' eq_dec.upd_neq; [apply: prf0|
                                                      move=> HHH; apply: n1; symmetry; exact HHH].
                        apply/ltP ; move: ineqi0=> /ltP ineqi0; omega.
                    - move => i0 ineq0 Px; destruct (Nat.eq_dec i0 n2).
                        by subst; exists n0; split =>//; rewrite /f0' eq_dec.upd_eq.
                        move: (subset i0)=> [] //.
                        apply/ltP ; move: ineq0=> /ltP ineq0; omega.
                        move=> i0' [] A B. exists i0'; split=>//. auto.
                        rewrite /f0' eq_dec.upd_neq=> //.
                        move: A=>/ltP A. omega.
                    - move=> i ineq0; destruct (Nat.eq_dec n0 i).
                      + subst i; rewrite /f0' eq_dec.upd_eq=> //.
                        exists n2; split=>//.
                      + rewrite /f0' eq_dec.upd_neq=> //.
                        assert (ineqi':  i < n0).
                        { apply/ltP ; move: ineq0=> /ltP ineq0; omega. }
                        move: ineqi'=> /complete [] j [] ineqj <-.
                        exists j; split=>//. apply/ltP; move: ineqj=> /ltP ineqj; omega.

                  }
                + left; exists f0, n0; repeat split=> //.
                  * auto.
                  * move => i0 ineq0. destruct (Nat.eq_dec i0 n2).
                      by subst; move=> Px; exfalso; apply nPnew_x.
                      assert (H:i0<n2).
                      { apply/ltP ; move: ineq0=> /ltP ineq0; omega. }
                        by move /(subset _ H).
                  * move=> i /complete [] j [] ineq' eqj; exists j; split=> //.
                    apply/ltP; move: ineq' =>/ltP ineq';omega.

            }
        + move => [] n0 [] /leP /(le_trans _ _ n2.+1) A B; right; exists n0; split=> //.
          apply/leP; apply: A; omega.
    }
Qed.

  (* If every element in the filter, is finitely branching
     then finite safety safeN implies infinite safetyy safe.*)
  Lemma filtered_konigsafe:
    forall (x : X),
      (forall P : Prop, P \/ ~ P) ->
      (forall x0 : X, Filter x0 -> finite (R x0)) ->
      Filter x ->
      (forall n : nat, safeN X R n x) -> konig.safe X R x.
  Proof.
    move => x EM blah inF sfN.
    replace x with (thing (mkTT x inF)) by reflexivity.
    eapply filtered_to_unfiltered_safe.
    eapply VST.concurrency.common.konig.konigsafe => //.

    move=> [] xx prfx.
    rewrite /finite.

    assert (EM': forall x0, R xx x0 \/ ~ R xx x0) by (move=>x0; apply EM;auto).
    move: (blah _ prfx)=> /(finite_cardinality _ EM') [] n car.
    inversion car; subst n0.

    exists n.
    assert (HH: forall i, i < n -> Filter (f i)) by move => i / H0 / (preservation _ _ prfx) //.
    assert (refl:forall i n, (i < n)%coq_nat -> is_true (i < n)) by move => i' n' /ltP //.
    pose (f0:= fun i =>
                 match le_lt_dec n i with
                 | left _ =>  mkTT xx prfx
                 | right ineq => mkTT (f i) (HH i (refl i n ineq))
                 end ).

    exists f0 => [] [] xx' prfx' /= stepstep. inversion stepstep.
    move: stp0; subst x'=> /= /H1 [] i0 [] /ltP A B.
    exists i0; split=> //.
    rewrite /f0.
    destruct (le_lt_dec n i0) => //.
    move: A l=> /ltP A /leP.
    move: A => /ltP FALSE1 /leP FALSE2; omega.
    clear stepstep.
    remember (HH i0 (refl i0 n l)) as prfx''. clear Heqprfx''.
    move: prfx' prfx''.
    dependent rewrite B => P1 P2; f_equal.
    apply: ProofIrrelevance.PI.proof_irrelevance.

    move => n.
    apply: unfiltered_to_filtered_safeN=> //.
  Qed.

End filtered_konig.

Section Safety.
  Context (ST:Type)(SCH:Type).
  Context (STEP:ST->SCH->ST->SCH-> Prop).
  Context (valid: ST-> SCH -> Prop).
  Hypothesis em: forall P, P \/ ~ P.

  Lemma schedule_dec:
    forall (U U':SCH), (U=U') \/ (U<>U').
  Proof. intros; eapply em. Qed.

  Inductive ksafe (st:ST) U: nat -> Prop :=
  |sft0: ksafe st U 0
  |sft_step: forall n st' U', STEP st U st' U' -> (forall U'', valid st' U'' -> ksafe st' U'' n) -> ksafe st U (S n).

  CoInductive safe st U: Prop:=
  | csft_step: forall st' U', STEP st U st' U' -> (forall U'', valid st' U'' -> safe st' U'') -> safe st U.

  (*The proof relies on the sets of states: SST's*)
  Definition SST:= ST -> Prop.

  Definition is_in (st:ST)(P:SST):= P st.
  (*Notation enth:= (List.nth_error).*)
  Infix "\In":= (is_in) (at level 20, right associativity).

  (*Generalizes a non-deterministic relation to sets *)
  Inductive SStep {X Y: Type} (R: X -> X -> Y -> Prop)(valid:X->Y->Prop) (P P':X -> Prop) : Prop:=
  | blahblah: (forall x y, P x -> valid x y -> exists x', R x x' y /\ P' x') ->
              (forall x', P' x' -> exists x y, R x x' y /\ P x /\ valid x y) ->
              SStep R valid P P'.
  Definition SST_step : SST -> SST -> Prop := SStep (fun st st' U => exists U', STEP st U st' U') valid.
  Hypothesis  preservation : forall P0 P' : SST, finite P0 -> SST_step P0 P' -> finite P'.

  (*Instantiating koning's variables *)
  Definition SsafeN:= konig.safeN SST SST_step.
  Definition Ssafe:= konig.safe (SST) SST_step.
  (*Initial state is singleton.*)
  Inductive P_init {st_init:ST}: SST:=
  |ItIsMe: P_init st_init.

  Lemma finite_P_init: forall {st}, finite (@P_init st).
  Proof. by move =>st; exists 1, (fun _ => st) => st' []; exists 0; split. Qed.

  Lemma SsafeN_ksafe': forall n P,
      SsafeN n P -> forall st U, st \In P -> valid st U -> ksafe st U n.
  Proof.
    induction n.
    - constructor.
    - move=> P HH st U inP VAL.
      inversion HH; subst.
      inversion H0.
      move: VAL inP => /H H' /H'  [] st' [][] U' STP inx'.
      apply: (sft_step st U n st' U' STP)=> U'' VALID'.
      apply: (IHn x' _ )=>//.
  Qed.

  Corollary SsafeN_ksafe: forall n st,
      SsafeN n (@P_init st) -> forall U, valid st U -> ksafe st U n.
  Proof. move=> n st mysN U VAL. apply: (SsafeN_ksafe' n P_init mysN) => //. Qed.

  Lemma ksafe_SsafeN': forall n P,
      (forall st U, st \In P -> valid st U -> ksafe st U n) ->
      SsafeN n P.
  Proof.
    induction n.
    - constructor.
    - move=> P HH.
      pose (P':= fun st' => exists st U U',
                     P st /\
                     valid st U /\
                     STEP st U st' U' /\
                     (forall U'', valid st' U'' -> ksafe st' U'' n)).
      apply: (safeS _ _ n P P').
    - constructor.
      + move => st U inP VAL.
        move: (inP) (VAL)=> /HH HH' /HH' ksf.
        inversion ksf.
        exists st'; split; [exists U'| ] =>//.
        rewrite /is_in /P'.
        exists st, U, U'=>//.
      + move => st'.
        rewrite /is_in /P'=> [] [] st [] U [] U' []inP[] VAL[] STP CONDITION.
        exists st, U; split;[exists  U' | ]=>//.
    - eapply IHn => st' U [] st [] UU [] U' [] inP [] VAL [] STP COND;
      by apply: COND.
  Qed.

  Lemma ksafe_SsafeN: forall st_init,
      (forall U, valid st_init U) ->
      forall n, (forall U, ksafe st_init U n) ->
           SsafeN n (@P_init st_init).
  Proof.
    move => st_init all_valid n Uksf.
    apply ksafe_SsafeN' => st' U' [] val.
    apply: Uksf.
  Qed.

  Lemma Ssafe_safe': forall P,
      Ssafe P -> forall st U, st \In P -> valid st U -> safe st U.
  Proof.
    cofix COFIX=> P SF st U.
    inversion SF; subst x; rename x' into P'.
    inversion H => /H1 H1' /H1' [] st' [] [] U' STP inP'.
    apply: (csft_step _ _ st' U')=>// U'' VAL'.
    apply: (COFIX P')=> //.
  Qed.

  Lemma Ssafe_safe: forall st_init,
      (forall U, valid st_init U) ->
      Ssafe (@P_init st_init) -> forall U, safe st_init U.
  Proof.
    move=> st all_valid SF U.
    apply: (Ssafe_safe' _ SF).
    - by constructor.
    - by apply: all_valid.
  Qed.

  (* This is too weak... but is a good example*)
  Lemma SsafeN_Ssafe:
    (forall P: Prop, P \/ ~ P) ->
    forall P,
      (forall P, finite (SST_step P)) ->
      (forall n, SsafeN n P) ->
      Ssafe P.
  Proof. by move => EM P A B; apply: (VST.concurrency.common.konig.konigsafe). Qed.

  (*This is strong enough *)
  Lemma finite_Ssafe_safe':
    (forall P : Prop, P \/ ~ P) ->
    (forall P : ST -> Prop, finite P -> finite (SST_step P)) ->
    forall P, (finite P) ->
         ( forall n : nat, safeN (ST -> Prop) SST_step n P) ->
         Ssafe P.
  Proof. intros; eapply filtered_konigsafe; eauto. Qed.

  Lemma finite_Ssafe_safe:
    (forall P : Prop, P \/ ~ P) ->
    (forall P : ST -> Prop, finite P -> finite (SST_step P)) ->
    forall st, ( forall n : nat, safeN (ST -> Prop) SST_step n (@P_init st)) ->
          Ssafe (@P_init st).
  Proof. move => EM FIN P; apply: finite_Ssafe_safe'=>//. apply: finite_P_init. Qed.

  Definition possible_image {X Y} (STEP:X-> Y-> X (*-> Y*) -> Prop) (valid: X -> Y -> Prop)  st st' U:= valid st U /\ (* exists U',  *) STEP st U st' (* U' *).
  Definition finite_on_x {X Y} (A:X->Y->Prop):=
    exists n (f: nat -> X), forall x y, A x y -> exists i, (i < n) /\ f i = x.
  (** This lemma is actually easy. It's unique, under prop_ext. **)
  Lemma finite_rel_generalize' {X Y} (V: X -> Y -> Prop) (R: X -> X -> Y -> Prop):
    (forall x, finite_on_x (possible_image (fun x x' y => R x y x') V x)) ->
    forall (P:X -> Prop), finite P ->
                 finite (fun x' => exists x y, P x /\ V x y /\ R x x' y).
  Proof.
    move=> FINx P [] n [] Pf FINp.
    unfold possible_image, finite_on_x in FINx.
    pose (PN:= fun n x => exists i, Pf i = x /\ i < n /\ P x).
    cut (forall n, finite (fun x' => exists x y, (PN n) x /\ V x y /\ R x x' y)).
    { move => /(_ n) [] N [] F HH.
      exists N, F => x' [] x [] y [] Px [] Vxy Rxx.
      cut (exists x y, PN n x /\ V x y /\ R x x' y).
      - by move=> /HH.
      - exists x, y; repeat split; [ |assumption| assumption].
        move: (Px) => /FINp [] i [] ineq Pfi.
        exists i; repeat split=> //; by apply/ltP.
    }
    { (*Prove the cut condition*)
      induction n0.
      - exists 1, (fun _ => Pf 0) => x' [] x [] y [] PNx [] Vxy Rxx'.
        exists 0; move : PNx => [] i []Pfi [] /ltP HH.
        contradict HH; clear; omega.
      - move: IHn0 => [] N [] F HH.
        pose (new_x:= Pf n0).
        move: (FINx new_x)=> [] nn [] fn HHH.
        exists (N + nn).
        exists (fun i => if (i < N) then F i else fn (i - N)) => x' [] x [] y [][] i [] Pfi []ineqi Px.
        destruct (Nat.eq_dec i n0) as [e|ne].
        + rewrite e in Pfi.
          rewrite /new_x Pfi in HHH.
          move => /HHH [] i0 [] ineqi0 fni0 .
          exists (N + i0); split.
          * apply/ltP; rewrite ltn_add2l; assumption.
          * replace (N + i0 < N) with false.
            replace (N + i0 - N) with i0.
            assumption.
            rewrite /addn /addn_rec /subn /subn_rec;
              omega.
            symmetry.
            cut (~ (N + i0 < N)).
            apply: introF; apply: idP.
            move: ineqi0=> /ltP ineqi0 /ltP.
            rewrite /addn /addn_rec => NN.
            clear - NN ineqi0. omega.
        + move=> [] Vxy Rxxy.
          cut ((exists (x0 : X) (y : Y), PN n0 x0 /\ V x0 y /\ R x0 x' y)).
          move=> /HH [] i0 [] ineqi0  Fi0.
          exists i0; split.
          * rewrite /addn /addn_rec ;omega.
          * by move: ineqi0=> /ltP ->.

            {
              exists x, y; repeat split=> //.
              exists i; repeat split=>//.
              apply/ltP. move: ineqi=> /ltP ineqi'; omega. }
  }
  Qed.
  Lemma power_set_finite {X}:
    (forall P : Prop, P \/ ~ P) ->
    forall P: X-> Prop, finite P ->
               finite (fun A => subset A P).
  Proof.
    move => EM P [] n; move: P.
    induction n.
    - move => P [] f FINp.
      exists 1, (fun _ _ => False).
      move=> P'. rewrite /subset => SUB.
      exists 0; split; [omega|].
      apply extensionality=> x'; apply prop_ext; split.
      move=>HH;exfalso; assumption.
      move=>/SUB /FINp []i [] HH _. omega. (* i < 0 -> False*)
    - move => P [] f FIN.
      cut ((exists f0 : nat -> X,
           forall x : X,
           (fun x0 : X => P x0 /\ f n <> x0) x ->
           exists i : nat, (i < n)%coq_nat /\ f0 i = x)).
      move=> /IHn [] n' [] f' FIN'.
      exists (2 * n').
      exists (fun i x => if odd i then  f' ((i - 1) /2) x \/ x = f n else  f' (i/ 2) x).
      move=> P'  SUB.
      cut (subset (fun x : X => P' x /\ f n <> x) (fun x : X => P x /\ f n <> x)).
      move=> /FIN' [] i [] ineqi fi'.
      destruct (EM (P' (f n))) as [yes|no].
      + { exists (2 * i + 1); split;
          [rewrite /addn /addn_rec /muln /muln_rec; omega|].
          rewrite odd_add addbC odd_mul.
          replace ((2 * i + 1 - 1) / 2) with i.
          - simpl; apply extensionality=> x'; apply prop_ext; rewrite fi'; split.
            + move=> [[] | ->] //.
            + destruct (EM (f n = x')).
              * by move=> Px'; right.
              * by move=> Px'; left; split.
                rewrite /addn /addn_rec /subn /subn_rec /muln /muln_rec.
                rewrite Nat.add_sub Nat.mul_comm Nat.div_mul; [reflexivity | omega].
        }

      + { exists (2 * i); split.
        rewrite /addn /addn_rec /muln /muln_rec; omega.
        rewrite odd_mul.
        rewrite /muln /muln_rec Nat.mul_comm Nat.div_mul /= ; [|omega].
        apply extensionality=> x'; apply prop_ext; rewrite fi'; split.
          * by move=> [].
          * move => Px'; split => // EQ.
              by apply:no; rewrite EQ.

        }
      (*CUT: subset (fun x : X => P' x /\ f n <> x) (fun x : X => P x /\ f n <> x)*)
        { move=> x [] Px' fnx'; split=> //.
            by apply: SUB. }
        { exists f => x [] /FIN [] i [] ineqi fi fnx.
        exists i; split; [|assumption].
        destruct (Nat.eq_dec i n) as [e|ne].
        - subst i; contradict fnx; assumption.
        - omega.
        }
  Qed.

  Lemma subset_finite {X}: forall (P P': X-> Prop), finite P -> subset P' P -> finite P'.
  Proof. move=> P P' [] n [] f HH SUB. by exists n, f => x / SUB / HH. Qed.

  Lemma finite_rel_generalize {X Y} (V: X -> Y -> Prop) (R: X -> X -> Y -> Prop):
    forall (propositional_extentionality: True),
      (forall P : Prop, P \/ ~ P) ->
      (forall x, finite_on_x (possible_image (fun x x' y => R x y x') V x)) ->
      forall (P:X -> Prop), finite P ->
                   finite (SStep R V P).
  Proof.
    move => _ EM /finite_rel_generalize' H P /H HH.
    apply: subset_finite.
    - apply: power_set_finite; [assumption|apply: HH].
    - clear=> Pp HH x' Ppx.
      inversion HH.
      move: Ppx=> / H0 [] x [] y [] Rxxy [] Px Vx.
      exists x, y; repeat split=> //.
  Qed.

  Lemma ksafe_safe':
    (forall P: Prop, P \/ ~ P) ->
    forall (propositional_extentionality: True),
    forall (branches_finitely_on_the_state: forall x : ST,
          @finite_on_x _ _ (possible_image (fun x y x' => exists y', STEP x y x' y') valid x)),
    forall st,
      (forall n U, valid st U -> ksafe st U n) ->
      (forall U, valid st U -> safe st U).
  Proof.
    move => EM PROP_EXT FINIT st KS U VAL.
    apply: (Ssafe_safe' (@P_init st)) => // .
    apply: finite_Ssafe_safe' =>//.
    - by move => st' FINst; apply: (finite_rel_generalize _ _ PROP_EXT).
      - apply: finite_P_init.
      - move=> n. eapply ksafe_SsafeN'; eauto.
        move => st0 U0 ImIn VAL0.
        inversion ImIn as [H0].
        subst. apply KS=> //.
  Qed.

  Lemma ksafe_safe:
    (forall P: Prop, P \/ ~ P) ->
    forall (propositional_extentionality: True),
    forall (branches_finitely_on_the_state: forall x : ST,
          @finite_on_x _ _ (possible_image (fun x y x' => exists y', STEP x y x' y') valid x)),
    forall st,
      (forall U : SCH, valid st U) ->
      (forall n U, ksafe st U n) ->
      (forall U, safe st U).
  Proof.
    move => EM PROP_EXT FINIT st all_valid SF.
    apply: Ssafe_safe =>//.
    apply: finite_Ssafe_safe=>//.
      by move => st' FINst; apply: (finite_rel_generalize _ _ PROP_EXT).
        by move=> n; apply: ksafe_SsafeN.
  Qed.
   Lemma safe_ksafe':
    forall st,
      (forall U, valid st U -> safe st U) ->
      (forall U, valid st U -> forall n, ksafe st U n).
  Proof.
    move => st SF U VAL n; move: st SF U VAL.
    induction n.
    - constructor.
    - move=> st SF U VAL; specialize (SF _ VAL); inversion SF.
      apply: (sft_step _ _ _ st' U' H)=> U'' VAL'.
      apply: IHn=>//.
  Qed.

  Lemma safe_ksafe:
    forall st,
      (forall U : SCH, valid st U) ->
      (forall U, safe st U) ->
      (forall n U, ksafe st U n).
  Proof. move => st all_valid SF n U; apply: safe_ksafe'=>//. Qed.

End Safety.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e452m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Set Warnings "-parsing".
Require Import mathcomp.ssreflect.ssreflect mathcomp.ssreflect.ssrbool mathcomp.ssreflect.eqtype mathcomp.ssreflect.seq.
Set Warnings "+parsing".
Require Import Coquelicot.Coquelicot.
Require Import Reals.Rbase.
Require Import Reals.Rfunctions.
Require Import Reals.R_sqrt.
Require Import Rtrigo_def.
Require Import Rtrigo1.
Require Import Reals.Rtrigo_calc.
Require Import Lra.

Require Import fixed_point.
Require Import LibUtils.

Set Bullet Behavior "Strict Subproofs".

Lemma sqrt2_neq0 :
  sqrt 2 <> 0.
Proof.
  apply Rgt_not_eq.
  apply Rlt_gt.
  apply Rlt_sqrt2_0.
Qed.

Lemma sqrt_2PI_nzero : sqrt(2*PI) <> 0.
Proof.
  assert (PI > 0) by apply PI_RGT_0.
  apply Rgt_not_eq.
  apply sqrt_lt_R0.
  lra.
Qed.

Lemma sqrt_PI_neq0 : sqrt(PI) <> 0.
Proof.
  assert (PI > 0) by apply PI_RGT_0.
  apply Rgt_not_eq.
  apply sqrt_lt_R0.
  lra.
Qed.

Lemma ex_Rbar_plus_Finite_l x y : ex_Rbar_plus (Finite x) y.
  destruct y; simpl; trivial.
Qed.

Lemma ex_Rbar_plus_Finite_r x y : ex_Rbar_plus x (Finite y).
  destruct x; simpl; trivial.
Qed.

Lemma ex_Rbar_minus_Finite_l x y : ex_Rbar_minus (Finite x) y.
  destruct y; simpl; trivial.
Qed.

Lemma ex_Rbar_minus_Finite_r x y : ex_Rbar_minus x (Finite y).
  destruct x; simpl; trivial.
Qed.

Lemma Rbar_mult_p_infty_pos (z:R) :
  0 < z -> Rbar_mult p_infty z = p_infty.
Proof.
  intros.
  apply is_Rbar_mult_unique.
  apply is_Rbar_mult_p_infty_pos.
  simpl; auto.
Qed.

Lemma Rbar_mult_m_infty_pos (z:R) :
  0 < z -> Rbar_mult m_infty z = m_infty.
Proof.
  intros.
  apply is_Rbar_mult_unique.
  apply is_Rbar_mult_m_infty_pos.
  simpl; auto.
Qed.

Lemma Rbar_mult_p_infty_neg (z:R) :
  0 > z -> Rbar_mult p_infty z = m_infty.
Proof.
  intros.
  apply is_Rbar_mult_unique.
  apply is_Rbar_mult_p_infty_neg.
  simpl; auto.
Qed.

Lemma Rbar_mult_m_infty_neg (z:R) :
  0 > z -> Rbar_mult m_infty z = p_infty.
Proof.
  intros.
  apply is_Rbar_mult_unique.
  apply is_Rbar_mult_m_infty_neg.
  simpl; auto.
Qed.

Lemma Rint_lim_gen_m_infty_p_infty f (l:R) :
  (forall x y, ex_RInt f x y) ->
  filterlim (fun x => RInt f (fst x) (snd x))
            (filter_prod (Rbar_locally' m_infty) (Rbar_locally' p_infty))
            (Rbar_locally l) ->
  is_RInt_gen (V:=R_CompleteNormedModule) f (Rbar_locally m_infty) (Rbar_locally p_infty) l.
Proof.
  intros fex.
  unfold is_RInt_gen.
  unfold filterlimi, filterlim.
  unfold filtermap, filtermapi.
  unfold filter_le; intros.
  simpl in *.
  specialize (H P H0).
  replace (Rbar_locally' m_infty) with (Rbar_locally m_infty)  in * by reflexivity.
  replace (Rbar_locally' p_infty) with (Rbar_locally p_infty)  in * by reflexivity.
  revert H.
  apply filter_prod_ind; intros.
  eapply Filter_prod; eauto.
  intros.
  eexists; split; try eapply H2; eauto.
  apply RInt_correct.
  simpl.
  auto.
Qed.

Lemma lim_rint_gen_Rbar (f : R->R) (a:R) (b:Rbar) (l:R):
  (forall y, ex_RInt f a y) ->
  is_lim (fun x => RInt f a x) b l -> is_RInt_gen f (at_point a) (Rbar_locally' b) l.
Proof.
  intros fex.
  unfold is_lim.
  intros.
  unfold filterlim in H.
  unfold filter_le in H.
  unfold filtermap in H.
  simpl in *.
  intros P Plocal.
  specialize (H P Plocal).
  destruct b.
  - destruct H as [M PltM].
    eexists (fun x => x=a) (fun y => P (RInt f a y)); try easy.
    + simpl.
      unfold locally', within, locally in *.
      eauto.
    + simpl.
      intros.
      subst.
      simpl in *.
      exists (RInt f a y).
      split; trivial.
      now apply (@RInt_correct).
  - destruct H as [M PltM].
    eexists (fun x => x=a) (fun y => _); try easy.
    + simpl.
      eauto.
    + simpl.
      intros.
      subst.
      simpl in *.
      exists (RInt f a y).
      split; trivial.
      now apply (@RInt_correct).
  - destruct H as [M PltM].
    eexists (fun x => x=a) (fun y => _); try easy.
    + simpl.
      eauto.
    + simpl.
      intros.
      subst.
      simpl in *.
      exists (RInt f a y).
      split; trivial.
      now apply (@RInt_correct).
Qed.

Lemma rint_gen_lim_Rbar {f : R->R} {a:R} {b:Rbar} {l:R} :
  is_RInt_gen f (at_point a) (Rbar_locally' b) l -> is_lim (fun x => RInt f a x) b l.
Proof.
  intros H P HP.
  specialize (H _ HP).
  destruct H as [Q R Qa Rb H].
  simpl in H.
  destruct b.
  - destruct Rb as [M Rb].
    exists M.
    intros x xlt xne.
    destruct (H a x Qa (Rb _ xlt xne))
      as [y [yis iP]].
    now rewrite (is_RInt_unique _ _ _ _ yis).
  - destruct Rb as [M Rb].
    exists M.
    intros x xlt.
    destruct (H a x Qa (Rb _ xlt))
      as [y [yis iP]].
    now rewrite (is_RInt_unique _ _ _ _ yis).
  - destruct Rb as [M Rb].
    exists M.
    intros x xlt.
    destruct (H a x Qa (Rb _ xlt))
      as [y [yis iP]].
    now rewrite (is_RInt_unique _ _ _ _ yis).
Qed.

Lemma is_RInt_gen_comp_lin0
  (f : R -> R) (u v : R) (a:R) (b : Rbar) (l : R) :
  u<>0 -> (forall x y, ex_RInt f x y) ->
  is_RInt_gen f (at_point (u * a + v)) (Rbar_locally'  (Rbar_plus (Rbar_mult u b) v)) l
    -> is_RInt_gen (fun y => scal u (f (u * y + v))) (at_point a) (Rbar_locally' b) l.
Proof.
  intros.
  apply lim_rint_gen_Rbar.
  intros.
  now apply (@ex_RInt_comp_lin).
  apply (is_lim_ext (fun x : R => RInt f (u*a+v) (u*x+v))).
  intros.
  now rewrite RInt_comp_lin.
  apply is_lim_comp_lin.
  now apply rint_gen_lim_Rbar.
  trivial.
Qed.

Lemma is_RInt_gen_comp_lin_point_0
  (f : R -> R) (u : R) (a:R) (b : Rbar) (l : R) :
  u<>0 -> (forall x y, ex_RInt f x y) ->
  is_RInt_gen f (at_point (u * a)) (Rbar_locally' (Rbar_mult u b)) l
    -> is_RInt_gen (fun y => scal u (f (u * y))) (at_point a) (Rbar_locally' b) l.
Proof.
  intros.
  apply (is_RInt_gen_ext (fun y => scal u (f (u*y + 0)))).
  apply filter_forall.
  intros.
  now replace (u * x0 + 0) with (u * x0) by lra.
  apply is_RInt_gen_comp_lin0.
  trivial.
  trivial.
  replace (u*a+0) with (u*a) by lra.
  replace (Rbar_plus (Rbar_mult u b) 0) with (Rbar_mult u b).
  trivial.
  now rewrite Rbar_plus_0_r.
Qed.

Lemma RInt_gen_Chasles {Fa Fc : (R -> Prop) -> Prop}
  {FFa : ProperFilter' Fa} {FFc : ProperFilter' Fc}
  (f : R -> R) (b : R):
  ex_RInt_gen f Fa (at_point b) -> ex_RInt_gen f (at_point b) Fc ->
  plus (RInt_gen f Fa (at_point b)) (RInt_gen f (at_point b) Fc) = RInt_gen f Fa Fc.
Proof.
  intros.
  apply sym_eq.
  apply (@is_RInt_gen_unique).
  trivial.
  trivial.
  apply (@is_RInt_gen_Chasles) with (b:=b).
  apply filter_filter'.
  apply filter_filter'.
  now apply RInt_gen_correct.
  now apply RInt_gen_correct.
Qed.

Lemma is_RInt_gen_comp_lin
  (f : R -> R) (u v : R) (a b : Rbar) (ll : R) :
  u<>0 -> ex_RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v)) (at_point (u*0+v)) ->
  ex_RInt_gen f (at_point (u*0+v)) (Rbar_locally' (Rbar_plus (Rbar_mult u b) v)) ->
  (forall (x y :R), ex_RInt f x y) ->
  is_RInt_gen f (Rbar_locally'  (Rbar_plus (Rbar_mult u a) v)) (Rbar_locally'  (Rbar_plus (Rbar_mult u b) v)) ll
  -> is_RInt_gen (fun y => scal u (f (u * y + v))) (Rbar_locally' a) (Rbar_locally' b) ll.
Proof.
  intros.
  replace (ll) with (plus (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v))  (at_point (u*0+v)))
                         (RInt_gen f (at_point (u*0+v)) (Rbar_locally' (Rbar_plus (Rbar_mult u b) v)))).
  apply (@is_RInt_gen_Chasles R_CompleteNormedModule) with (b := 0)
        (l1 := (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v))  (at_point (u*0+v))))
        (l2 := (RInt_gen f (at_point (u*0+v)) (Rbar_locally' (Rbar_plus (Rbar_mult u b) v)))).
  apply Rbar_locally'_filter.
  apply Rbar_locally'_filter.
  replace (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v)) (at_point (u * 0 + v))) with
      (opp (opp (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v)) (at_point (u * 0 + v))))).
  apply (@is_RInt_gen_swap R_CompleteNormedModule) with
      (l := (opp (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v)) (at_point (u * 0 + v))))).
  apply Rbar_locally'_filter.
  apply at_point_filter.
  apply is_RInt_gen_comp_lin0; trivial.
  apply (@is_RInt_gen_swap R_CompleteNormedModule) with
      (l := (RInt_gen f (Rbar_locally' (Rbar_plus (Rbar_mult u a) v)) (at_point (u * 0 + v)))).
  apply at_point_filter.
  apply Rbar_locally'_filter.
  apply RInt_gen_correct.
  trivial.
  now rewrite opp_opp.
  apply is_RInt_gen_comp_lin0; trivial.
  apply (@RInt_gen_correct).
  apply Proper_StrongProper.
  apply at_point_filter.
  apply Proper_StrongProper.
  apply Rbar_locally'_filter.
  trivial.
  rewrite RInt_gen_Chasles.
  now apply is_RInt_gen_unique.
  trivial.
  trivial.
Qed.

Require Import Sets.Ensembles.

Lemma lub_not_contains (S1  S2 : Ensemble R) (L1 L2:R) :
  (is_lub S1 L1) /\ (is_upper_bound S2 L2) -> L1 > L2 -> ~ Included R S1 S2.
Proof.
  unfold is_lub, is_upper_bound, Included, In.
  intros.
  assert (~ (L1 <= L2)) by lra.
  intuition.
Qed.

(* this lemma needs Classical results, i.e. exluded middle *)
Lemma not_included (S1  S2 : Ensemble R) :
  ~ Included R S1 S2 -> exists x:R, In R S1 x /\ ~ In R S2 x.
Proof.
  unfold Included.
  intros.
  apply Classical_Pred_Type.not_all_ex_not in H.
  destruct H.
  exists x.
  now apply Classical_Prop.imply_to_and in H.
Qed.

Lemma lub_witness (S1 : Ensemble R) (L1 L2:R) :
  let S2 :Ensemble R := (fun x:R => In R S1 x /\ x <= L2) in
  (is_lub S1 L1) -> L1 > L2 -> exists x:R, In R S1 x /\ x > L2.
Proof.
  intros.
  assert (exists x:R, In R S1 x /\ ~In R S2 x).
  - apply not_included.
    apply lub_not_contains with (L1 := L1) (L2 := L2).
    + split; trivial.
      unfold is_upper_bound, S2.
      intros.
      now destruct H1.
    + trivial.
  - destruct H1.
    exists x.
    destruct H1.
    split; trivial.
    unfold S2, In in H2.
    intuition.
Qed.

Lemma increasing_bounded_limit (M:R) (f: R->R):
  Ranalysis1.increasing f ->
  (forall x:R, f x <= M) -> ex_finite_lim f p_infty.
Proof.
  unfold Ranalysis1.increasing.
  intros.
  unfold ex_finite_lim.
  assert { m:R | is_lub (fun y : R => (exists x:R, y = f x)) m }.
  - apply completeness.
    + unfold bound.
      exists M.
      unfold is_upper_bound.
      intros.
      destruct H1.
      now subst.
    + exists (f 0); now exists (0).
  - destruct H1 as [L HH].
    exists L.
    rewrite <- is_lim_spec.
    unfold is_lim'.
    intros.
    unfold Rbar_locally'.
    unfold is_lub in HH.
    destruct HH.
    (* since L-eps is not an upper bound, there exists (f x0) > L-eps *)
    assert (exists y0, (exists x0, y0 = f x0) /\ y0 > L-eps).
    + apply lub_witness with (L1 := L) (L2 := L-eps).
      * unfold is_lub.
        split; trivial.
      * apply Rminus_gt.
        replace (L - (L - (pos eps))) with (pos eps) by lra.
        apply eps.
    + destruct H3.
      destruct H3.
      destruct H3.
      exists x0.
      intros.
      replace (f x1 - L) with (- (L - f x1)) by lra.
      rewrite (Rabs_Ropp).
      rewrite Rabs_pos_eq.
      * assert (f x0 <= f x1).
        -- apply H.
           now left.
        -- lra.
      * unfold is_upper_bound in H1.
        apply Rge_le.
        apply Rge_minus.
        apply Rle_ge.
        apply H1.
        now exists x1.
Qed.

Lemma ex_lim_rint_gen_Rbar (f : R->R) (a:R) (b:Rbar):
  (forall y, ex_RInt f a y) ->
  ex_finite_lim (fun x => RInt f a x) b -> ex_RInt_gen f (at_point a) (Rbar_locally' b).
Proof.
  intros.
  unfold ex_RInt_gen.
  unfold ex_finite_lim in H0.
  destruct H0.
  exists (x).
  apply lim_rint_gen_Rbar; trivial.
Qed.

Lemma ex_RInt_gen_bounded (M:R) (f : R -> R) (a:R) :
  (forall (b:R), f b >= 0) ->
  (forall (b:R), ex_RInt f a b) ->
  (forall (b:R), RInt f a b <= M) -> ex_RInt_gen f (at_point a) (Rbar_locally' p_infty).
Proof.
  intros.
  assert ( Ranalysis1.increasing (fun z => RInt f a z)).
  - intros.
    unfold Ranalysis1.increasing.
    intros.
    replace (RInt f a x) with (plus (RInt f a x) 0).
    + rewrite <- RInt_Chasles with (b:=x) (c:=y).
      * apply Rplus_le_compat_l.
        apply RInt_ge_0; trivial.
        -- apply ex_RInt_Chasles with (b := a).
           ++ apply ex_RInt_swap.
              trivial.
           ++ trivial.
        -- intros.
           apply Rge_le.
           apply H.
      * trivial.
      * apply ex_RInt_Chasles with (b := a).
        -- apply ex_RInt_swap.
           trivial.
        -- trivial.
    + apply Rplus_0_r.
  - apply ex_lim_rint_gen_Rbar.
    trivial.
    apply increasing_bounded_limit with (M:=M).
    trivial.
    trivial.
Qed.

Hint Resolve sqrt2_neq0 sqrt_PI_neq0 sqrt_2PI_nzero : Rarith.

Lemma ball_zero_eq {K : AbsRing} (X : NormedModule K) :
  forall x y : X, ball x 0 y -> x=y.
Proof.
  intros x y Hxy.
  apply eq_close.
  intros eps.
  apply ball_le with (e1 := 0).
  + left. apply cond_pos.
  + assumption.
Qed.

Lemma minus_zero_iff_eq {G : AbelianGroup} : forall x y : G, (minus x y = zero) <-> x = y.
Proof.
  intros x y.
  split; intros; subst.
  + unfold minus in H.
    eapply plus_reg_r with (opp y).
    rewrite H.
    symmetry. apply plus_opp_r.
  + apply minus_eq_zero.
Qed.

Lemma is_Lipschitz_le_zero_const {K1 K2 : AbsRing} {X : NormedModule K1} {Y : NormedModule K2}
      (F : X -> Y):
  (forall x y : X, norm (minus (F y) (F x)) <= 0) -> (forall x y, F x = F y).
Proof.
  intros Hnorm x y.
  specialize (Hnorm x y).
  destruct Hnorm.
  + apply ball_zero_eq.
    now apply norm_compat1.
  + apply (norm_eq_zero) in H.
    symmetry.
    now rewrite <-minus_zero_iff_eq.
Qed.

Lemma Rlt_forall_le (a b : R) : (forall eps:posreal, a < b + eps) -> a <= b.
Proof.
  intros H.
  destruct (Rle_dec a b); intros; trivial.
  exfalso.
  generalize (Rnot_le_lt _ _ n); intros Hab.
  clear n.
  assert (Hpos : 0 < (a - b)/2) by lra.
  pose (abs := mkposreal ((a - b)/2) Hpos).
  specialize (H abs).
  simpl in H ; clear abs.
  lra.
Qed.

Lemma Rlt_forall_le' (a b : R) : (forall eps:posreal, a + eps < b) -> a <= b.
Proof.
  intros H.
  destruct (Rle_dec a b); intros; trivial.
  exfalso.
  generalize (Rnot_le_lt _ _ n); intros Hab.
  clear n.
  assert (Hpos : 0 < (a - b)/2) by lra.
  pose (abs := mkposreal ((a - b)/2) Hpos).
  specialize (H abs).
  simpl in H ; clear abs.
  lra.
Qed.

Lemma Rle_forall_le: forall a b : R, (forall eps : posreal, a <= b + eps) -> a <= b.
Proof.
  intros.
  apply Rlt_forall_le; intros.
  specialize (H (pos_div_2 eps)).
  simpl in H.
  eapply Rle_lt_trans; try eapply H.
  destruct eps; simpl.
  lra.
Qed.

Lemma Rbar_le_forall_Rbar_le: forall a b : Rbar, (forall eps : posreal, Rbar_le a (Rbar_plus b eps)) -> Rbar_le a b.
Proof.
  intros [] []; simpl; intros HH; trivial
  ; try (apply HH; exact (mkposreal 1 Rlt_0_1)).
  now apply Rle_forall_le.
Qed.

Lemma is_Lipschitz_cond {K : AbsRing} {X : NormedModule K}{Y : NormedModule R_AbsRing}
      (F : X -> Y) (γ : R):
  (0 <= γ <= 1) ->
  (forall (x y : X) (r : R), norm(minus y x) < r -> norm(minus (F y) (F x)) < γ*r) ->
  (forall (x y : X), norm (minus (F y) (F x)) <= γ*norm( minus y x)).
Proof.
  intros Hγ H x y.
  apply Rlt_forall_le; intros eps.
  destruct eps as [eps Heps].
  destruct Hγ as [H1 H2].
  simpl.
  generalize Rle_mult_Rlt; intros.
  assert (Hxy : norm (minus y x) < norm (minus y x) + eps) by lra.
  specialize (H x y (norm (minus y x) + eps) Hxy).
  destruct H2; subst ; try lra.
  replace (eps) with (1*eps) by lra.
  eapply Rlt_trans; eauto.
  rewrite Rmult_plus_distr_l.
  apply Rplus_lt_compat_l.
  apply Rmult_lt_compat_r; trivial.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals ssreflect.

Require Import Rcomplements Rbar Continuity Derive Hierarchy.

(** This file defines complex numbers [C] as [R * R]. Operations are
given, and [C] is proved to be a field, a normed module, and a
complete space. *)

(** * The set of complex numbers *)

Definition C := (R * R)%type.

Definition RtoC (x : R) : C := (x,0).
Coercion RtoC : R >-> C.

Lemma RtoC_inj : forall (x y : R),
  RtoC x = RtoC y -> x = y.
Proof.
  intros x y H.
  now apply (f_equal (@fst R R)) in H.
Qed.

Lemma Ceq_dec (z1 z2 : C) : { z1 = z2 } + { z1 <> z2 }.
Proof.
  destruct z1 as [x1 y1].
  destruct z2 as [x2 y2].
  case: (Req_EM_T x1 x2) => [ -> | Hx ].
  case: (Req_EM_T y1 y2) => [ -> | Hy ].
  by left.
  right ; contradict Hy.
  now apply (f_equal (@snd R R)) in Hy ; simpl in Hy.
  right ; contradict Hx.
  now apply (f_equal (@fst R R)) in Hx ; simpl in Hx.
Qed.

(** ** Constants and usual functions *)

(** 0 and 1 for complex are defined as [RtoC 0] and [RtoC 1] *)
Definition Ci : C := (0,1).

(** *** Arithmetic operations *)

Definition Cplus (x y : C) : C := (fst x + fst y, snd x + snd y).
Definition Copp (x : C) : C := (-fst x, -snd x).
Definition Cminus (x y : C) : C := Cplus x (Copp y).
Definition Cmult (x y : C) : C := (fst x * fst y - snd x * snd y, fst x * snd y + snd x * fst y).
Definition Cinv (x : C) : C := (fst x / (fst x ^ 2 + snd x ^ 2), - snd x / (fst x ^ 2 + snd x ^ 2)).
Definition Cdiv (x y : C) : C := Cmult x (Cinv y).

Delimit Scope C_scope with C.
Local Open Scope C_scope.

Infix "+" := Cplus : C_scope.
Notation "- x" := (Copp x) : C_scope.
Infix "-" := Cminus : C_scope.
Infix "*" := Cmult : C_scope.
Notation "/ x" := (Cinv x) : C_scope.
Infix "/" := Cdiv : C_scope.

(** *** Other usual functions *)

Definition Re (z : C) : R := fst z.

Definition Im (z : C) : R := snd z.

Definition Cmod (x : C) : R := sqrt (fst x ^ 2 + snd x ^ 2).

Definition Cconj (x : C) : C := (fst x, (- snd x)%R).

Lemma Cmod_0 : Cmod 0 = 0.
Proof.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_l.
apply sqrt_0.
Qed.
Lemma Cmod_1 : Cmod 1 = 1.
Proof.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_r 2!Rmult_1_l.
apply sqrt_1.
Qed.

Lemma Cmod_opp : forall x, Cmod (-x) = Cmod x.
Proof.
unfold Cmod.
simpl.
intros x.
apply f_equal.
ring.
Qed.

Lemma Cmod_triangle : forall x y, Cmod (x + y) <= Cmod x + Cmod y.
Proof.
  intros x y ; rewrite /Cmod.
  apply Rsqr_incr_0_var.
  apply Rminus_le_0.
  unfold Rsqr ; simpl ; ring_simplify.
  rewrite /pow ?Rmult_1_r.
  rewrite ?sqrt_sqrt ; ring_simplify.
  replace (-2 * fst x * fst y - 2 * snd x * snd y)%R with (- (2 * (fst x * fst y + snd x * snd y)))%R by ring.
  rewrite Rmult_assoc -sqrt_mult.
  rewrite Rplus_comm.
  apply -> Rminus_le_0.
  apply Rmult_le_compat_l.
  apply Rlt_le, Rlt_0_2.
  apply Rsqr_incr_0_var.
  apply Rminus_le_0.
  rewrite /Rsqr ?sqrt_sqrt ; ring_simplify.
  replace (fst x ^ 2 * snd y ^ 2 - 2 * fst x * snd x * fst y * snd y +
    snd x ^ 2 * fst y ^ 2)%R with ( (fst x * snd y - snd x * fst y)^2)%R
    by ring.
  apply pow2_ge_0.
  repeat apply Rplus_le_le_0_compat ; apply Rmult_le_pos ; apply pow2_ge_0.
  apply sqrt_pos.
  apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
  apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
  replace (fst x ^ 2 + 2 * fst x * fst y + fst y ^ 2 + snd x ^ 2 + 2 * snd x * snd y + snd y ^ 2)%R
    with ((fst x + fst y)^2 + (snd x + snd y)^2)%R by ring.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply sqrt_pos.
Qed.

Lemma Cmod_mult : forall x y, Cmod (x * y) = (Cmod x * Cmod y)%R.
Proof.
  intros x y.
  unfold Cmod.
  rewrite -sqrt_mult.
  apply f_equal ; simpl ; ring.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
Qed.

Lemma Rmax_Cmod : forall x,
  Rmax (Rabs (fst x)) (Rabs (snd x)) <= Cmod x.
Proof.
  case => x y /=.
  rewrite -!sqrt_Rsqr_abs.
  apply Rmax_case ; apply sqrt_le_1_alt, Rminus_le_0 ;
  rewrite /Rsqr /= ; ring_simplify ; by apply pow2_ge_0.
Qed.
Lemma Cmod_2Rmax : forall x,
  Cmod x <= sqrt 2 * Rmax (Rabs (fst x)) (Rabs (snd x)).
Proof.
  case => x y /= ; apply Rmax_case_strong => H0 ;
  rewrite -!sqrt_Rsqr_abs ;
  rewrite -?sqrt_mult ;
  try (by apply Rle_0_sqr) ;
  try (by apply Rlt_le, Rlt_0_2) ;
  apply sqrt_le_1_alt ; simpl ; [ rewrite Rplus_comm | ] ;
  rewrite /Rsqr ; apply Rle_minus_r ; ring_simplify ;
  apply Rsqr_le_abs_1 in H0 ; by rewrite /pow !Rmult_1_r.
Qed.

(** ** C is a field *)

Lemma RtoC_plus (x y : R) :
  RtoC (x + y) = RtoC x + RtoC y.
Proof.
  unfold RtoC, Cplus ; simpl.
  by rewrite Rplus_0_r.
Qed.
Lemma RtoC_opp (x : R) :
  RtoC (- x) = - RtoC x.
Proof.
  unfold RtoC, Copp ; simpl.
  by rewrite Ropp_0.
Qed.
Lemma RtoC_minus (x y : R) :
  RtoC (x - y) = RtoC x - RtoC y.
Proof.
  by rewrite /Cminus -RtoC_opp -RtoC_plus.
Qed.
Lemma RtoC_mult (x y : R) :
  RtoC (x * y) = RtoC x * RtoC y.
Proof.
  unfold RtoC, Cmult ; simpl.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma RtoC_inv (x : R) : (x <> 0)%R -> RtoC (/ x) = / RtoC x.
Proof.
  intros Hx.
  by apply injective_projections ; simpl ; field.
Qed.
Lemma RtoC_div (x y : R) : (y <> 0)%R -> RtoC (x / y) = RtoC x / RtoC y.
Proof.
  intros Hy.
  by apply injective_projections ; simpl ; field.
Qed.

Lemma Cplus_comm (x y : C) : x + y = y + x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_comm.
Qed.
Lemma Cplus_assoc (x y z : C) : x + (y + z) = (x + y) + z.
Proof.
  apply injective_projections ; simpl ; apply sym_eq, Rplus_assoc.
Qed.
Lemma Cplus_0_r (x : C) : x + 0 = x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_0_r.
Qed.
Lemma Cplus_0_l (x : C) : 0 + x = x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_0_l.
Qed.
Lemma Cplus_opp_r (x : C) : x + -x = 0.
Proof.
  apply injective_projections ; simpl ; apply Rplus_opp_r.
Qed.

Lemma Copp_plus_distr (z1 z2 : C) : - (z1 + z2) = (- z1 + - z2).
Proof.
  apply injective_projections ; by apply Ropp_plus_distr.
Qed.
Lemma Copp_minus_distr (z1 z2 : C) : - (z1 - z2) = z2 - z1.
Proof.
  apply injective_projections ; by apply Ropp_minus_distr.
Qed.

Lemma Cmult_comm (x y : C) : x * y = y * x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_assoc (x y z : C) : x * (y * z) = (x * y) * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_0_r (x : C) : x * 0 = 0.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_0_l (x : C) : 0 * x = 0.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_1_r (x : C) : x * 1 = x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_1_l (x : C) : 1 * x = x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Lemma Cinv_r (r : C) : r <> 0 -> r * /r = 1.
Proof.
  move => H.
  apply injective_projections ; simpl ; field.
  contradict H.
  apply Rplus_sqr_eq_0 in H.
  apply injective_projections ; simpl ; by apply H.
  contradict H.
  apply Rplus_sqr_eq_0 in H.
  apply injective_projections ; simpl ; by apply H.
Qed.

Lemma Cinv_l (r : C) : r <> 0 -> /r * r = 1.
Proof.
intros Zr.
rewrite Cmult_comm.
now apply Cinv_r.
Qed.

Lemma Cmult_plus_distr_l (x y z : C) : x * (y + z) = x * y + x * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Lemma Cmult_plus_distr_r (x y z : C) : (x + y) * z = x * z + y * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Definition C_AbelianGroup_mixin :=
  AbelianGroup.Mixin _ _ _ _ Cplus_comm Cplus_assoc Cplus_0_r Cplus_opp_r.

Canonical C_AbelianGroup :=
  AbelianGroup.Pack C C_AbelianGroup_mixin C.

Lemma Copp_0 : Copp 0 = 0.
Proof.
  apply: opp_zero.
Qed.

Definition C_Ring_mixin :=
  Ring.Mixin _ _ _ Cmult_assoc Cmult_1_r Cmult_1_l Cmult_plus_distr_r Cmult_plus_distr_l.

Canonical C_Ring :=
  Ring.Pack C (Ring.Class _ _ C_Ring_mixin) C.

Lemma Cmod_m1 :
  Cmod (Copp 1) = 1.
Proof.
rewrite Cmod_opp.
apply Cmod_1.
Qed.

Lemma Cmod_eq_0 :
  forall x, Cmod x = 0 -> x = 0.
Proof.
intros x H.
unfold Cmod, pow in H.
rewrite 2!Rmult_1_r -sqrt_0 in H.
apply sqrt_inj in H.
apply Rplus_sqr_eq_0 in H.
now apply injective_projections.
apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
apply Rle_refl.
Qed.

Definition C_AbsRing_mixin :=
  AbsRing.Mixin _ _ Cmod_0 Cmod_m1 Cmod_triangle (fun x y => Req_le _ _ (Cmod_mult x y)) Cmod_eq_0.

Canonical C_AbsRing :=
  AbsRing.Pack C (AbsRing.Class _ _ C_AbsRing_mixin) C.

Lemma Cmod_ge_0 :
  forall x, 0 <= Cmod x.
Proof.
intros x.
apply sqrt_pos.
Qed.
Lemma Cmod_gt_0 :
  forall (x : C), x <> 0 <-> 0 < Cmod x.
Proof.
intros x ; split => Hx.
destruct (Cmod_ge_0 x) => //.
by apply sym_eq, Cmod_eq_0 in H.
contradict Hx.
apply Rle_not_lt, Req_le.
by rewrite Hx Cmod_0.
Qed.

Lemma Cmod_norm :
  forall x : C, Cmod x = (@norm R_AbsRing _ x).
Proof.
intros [u v].
unfold Cmod.
simpl.
apply (f_equal2 (fun x y => sqrt (x + y))) ;
  rewrite /norm /= !Rmult_1_r ;
  apply Rsqr_abs.
Qed.

Lemma Cmod_R :
  forall x : R, Cmod x = Rabs x.
Proof.
intros x.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_r Rmult_1_r.
apply sqrt_Rsqr_abs.
Qed.

Lemma Cmod_inv :
  forall x : C, x <> 0 -> Cmod (/ x) = Rinv (Cmod x).
Proof.
intros x Zx.
apply Rmult_eq_reg_l with (Cmod x).
rewrite -Cmod_mult.
rewrite Rinv_r.
rewrite Cinv_r.
rewrite Cmod_R.
apply Rabs_R1.
exact Zx.
contradict Zx.
now apply Cmod_eq_0.
contradict Zx.
now apply Cmod_eq_0.
Qed.

Lemma Cmod_div (x y : C) : y <> 0 ->
  Cmod (x / y) = Rdiv (Cmod x) (Cmod y).
Proof.
  move => Hy.
  rewrite /Cdiv.
  rewrite Cmod_mult.
  by rewrite Cmod_inv.
Qed.

Lemma Cmult_neq_0 (z1 z2 : C) : z1 <> 0 -> z2 <> 0 -> z1 * z2 <> 0.
Proof.
  intros Hz1 Hz2 => Hz.
  assert (Cmod (z1 * z2) = 0).
  by rewrite Hz Cmod_0.
  rewrite Cmod_mult in H.
  apply Rmult_integral in H ; destruct H.
  now apply Hz1, Cmod_eq_0.
  now apply Hz2, Cmod_eq_0.
Qed.

Lemma Cminus_eq_contra : forall r1 r2 : C, r1 <> r2 -> r1 - r2 <> 0.
Proof.
  intros ; contradict H ; apply injective_projections ;
  apply Rminus_diag_uniq.
  now apply (f_equal (@fst R R)) in H.
  now apply (f_equal (@snd R R)) in H.
Qed.

Lemma C_ring_theory : ring_theory (RtoC 0) (RtoC 1) Cplus Cmult Cminus Copp eq.
Proof.
constructor.
exact Cplus_0_l.
exact Cplus_comm.
exact Cplus_assoc.
exact Cmult_1_l.
exact Cmult_comm.
exact Cmult_assoc.
exact Cmult_plus_distr_r.
easy.
exact Cplus_opp_r.
Qed.

Add Ring C_ring_ring : C_ring_theory.

Lemma C_field_theory : field_theory (RtoC 0) (RtoC 1) Cplus Cmult Cminus Copp Cdiv Cinv eq.
Proof.
constructor.
constructor.
exact Cplus_0_l.
exact Cplus_comm.
exact Cplus_assoc.
exact Cmult_1_l.
exact Cmult_comm.
exact Cmult_assoc.
exact Cmult_plus_distr_r.
easy.
exact Cplus_opp_r.
intros H.
injection H.
exact R1_neq_R0.
easy.
apply Cinv_l.
Qed.

Add Field C_field_field : C_field_theory.

(** * C is a NormedModule *)

Canonical C_UniformSpace :=
  UniformSpace.Pack C (UniformSpace.class (prod_UniformSpace _ _)) C.

(** on C (with the balls of R^2) *)

Canonical C_ModuleSpace :=
  ModuleSpace.Pack C_Ring C (ModuleSpace.class _ (Ring_ModuleSpace C_Ring)) C.

Canonical C_NormedModuleAux :=
  NormedModuleAux.Pack C_AbsRing C (NormedModuleAux.Class C_AbsRing _ (ModuleSpace.class _ C_ModuleSpace) (UniformSpace.class C_UniformSpace)) C.

Lemma C_NormedModule_mixin_compat1 :
  forall (x y : C) (eps : R),
  Cmod (minus y x) < eps -> ball x eps y.
Proof.
  intros x y eps.
  rewrite Cmod_norm.
  apply: prod_norm_compat1.
Qed.

Lemma C_NormedModule_mixin_compat2 :
  forall (x y : C_NormedModuleAux) (eps : posreal),
  ball x eps y -> Cmod (minus y x) < sqrt 2 * eps.
Proof.
  intros x y eps H.
  rewrite Cmod_norm.
  replace (sqrt 2) with (sqrt 2 * Rmax 1 1)%R.
  apply: prod_norm_compat2 H.
  rewrite -> Rmax_left by apply Rle_refl.
  apply Rmult_1_r.
Qed.

Definition C_NormedModule_mixin :=
  NormedModule.Mixin _ C_NormedModuleAux _ _ Cmod_triangle (fun x y => Req_le _ _ (Cmod_mult x y))
    C_NormedModule_mixin_compat1 C_NormedModule_mixin_compat2 Cmod_eq_0.

Canonical C_NormedModule :=
  NormedModule.Pack C_AbsRing C (NormedModule.Class _ _ _ C_NormedModule_mixin) C.

(** on R *)

Canonical C_R_ModuleSpace :=
  ModuleSpace.Pack R_Ring C (ModuleSpace.class _ (prod_ModuleSpace R_Ring R_ModuleSpace R_ModuleSpace)) C.

Canonical C_R_NormedModuleAux :=
  NormedModuleAux.Pack R_AbsRing C (NormedModuleAux.Class R_AbsRing _ (ModuleSpace.class _ C_R_ModuleSpace) (UniformSpace.class _)) C.

Canonical C_R_NormedModule :=
  NormedModule.Pack R_AbsRing C (NormedModule.class _ (prod_NormedModule _ _ _)) C.

Lemma scal_R_Cmult :
  forall (x : R) (y : C),
  scal (V := C_R_ModuleSpace) x y = Cmult x y.
Proof.
intros x y.
apply injective_projections ;
  rewrite /scal /= /scal /= /mult /= ; ring.
Qed.

(** * C is a CompleteSpace *)

Definition C_complete_lim (F : (C -> Prop) -> Prop) :=
  (R_complete_lim (fun P => F (fun z => P (Re z))), R_complete_lim (fun P => F (fun z => P (Im z)))).

Lemma C_complete_ax1 :
  forall F : (C -> Prop) -> Prop,
  ProperFilter F ->
  (forall eps : posreal, exists x : C, F (ball x eps)) ->
  forall eps : posreal, F (ball (C_complete_lim F) eps).
Proof.
  intros.
  apply filter_and ; simpl ; revert eps.
  apply (R_complete (fun P => F (fun z => P (Re z)))).
  split ; intros.
  destruct (filter_ex _ H1).
  by exists (Re x).
  split.
  by apply filter_true.
  intros ; by apply filter_and.
  intros ; eapply filter_imp, H2.
  intros ; by apply H1.
  intros ; destruct (H0 eps).
  exists (Re x).
  move: H1 ; apply filter_imp.
  intros ; by apply H1.
  apply (R_complete (fun P => F (fun z => P (Im z)))).
  split ; intros.
  destruct (filter_ex _ H1).
  by exists (Im x).
  split.
  by apply filter_true.
  intros ; by apply filter_and.
  intros ; eapply filter_imp, H2.
  intros ; by apply H1.
  intros ; destruct (H0 eps).
  exists (Im x).
  move: H1 ; apply filter_imp.
  intros ; by apply H1.
Qed.

Lemma C_complete_ax2 :
  forall F1 F2 : (C -> Prop) -> Prop,
  filter_le F1 F2 ->
  filter_le F2 F1 ->
  close (C_complete_lim F1) (C_complete_lim F2).
Proof.
intros F1 F2 H12 H21 eps.
split ; apply R_complete_close ; intros P.
apply H12.
apply H21.
apply H12.
apply H21.
Qed.

Definition C_CompleteSpace_mixin :=
  CompleteSpace.Mixin _ C_complete_lim C_complete_ax1 C_complete_ax2.

(* on C *)

Canonical C_CompleteNormedModule :=
  CompleteNormedModule.Pack _ C (CompleteNormedModule.Class C_AbsRing _ (NormedModule.class _ C_NormedModule) C_CompleteSpace_mixin) C.

(* on R *)

Canonical C_R_CompleteNormedModule :=
  CompleteNormedModule.Pack _ C (CompleteNormedModule.Class R_AbsRing _ (NormedModule.class _ C_R_NormedModule) C_CompleteSpace_mixin) C.

(** * Locally compat *)

Lemma locally_C x P :
  locally (T := C_UniformSpace) x P <-> locally (T := AbsRing_UniformSpace C_AbsRing) x P.
Proof.
  split => [[e He] | [e He]].
  - exists e => /= y Hy.
    apply He.
    split.
    eapply Rle_lt_trans, Hy.
    eapply Rle_trans, Rmax_Cmod.
    apply Rmax_l.
    eapply Rle_lt_trans, Hy.
    eapply Rle_trans, Rmax_Cmod.
    apply Rmax_r.
  - assert (Hd : 0 < e / sqrt 2).
    apply Rdiv_lt_0_compat.
    by apply e.
    apply Rlt_sqrt2_0.
    exists (mkposreal _ Hd) => /= y [Hy1 Hy2].
    apply He.
    eapply Rle_lt_trans.
    apply Cmod_2Rmax.
    rewrite Rmult_comm ; apply Rlt_div_r.
    apply Rlt_sqrt2_0.
    apply Rmax_case.
    by apply Hy1.
    by apply Hy2.
Qed.

(** * Limits *)

Definition C_lim (f : C -> C) (z : C) : C :=
  (real (Lim (fun x => fst (f (x, snd z))) (fst z)),
  real (Lim (fun x => snd (f (x, snd z))) (fst z))).

Lemma is_C_lim_unique (f : C -> C) (z l : C) :
  filterlim f (locally' z) (locally l) -> C_lim f z = l.
Proof.
  case: l => lx ly H.
  apply injective_projections ; simpl.

  apply (f_equal real (y := Finite lx)).
  apply is_lim_unique => /= P [eps Hp].
  destruct (H (fun z => P (fst z))) as [delta Hd] ; clear H.
  exists eps => y Hy.
  apply Hp, Hy.
  exists delta.
  intros y By Hy.
  apply Hd.
  split ; simpl.
  apply By.
  apply ball_center.
  contradict Hy.
  clear -Hy.
  destruct z as [z1 z2].
  now injection Hy.

  apply (f_equal real (y := Finite ly)).
  apply is_lim_unique => /= P [eps Hp].
  destruct (H (fun z => P (snd z))) as [delta Hd] ; clear H.
  exists eps => y Hy.
  apply Hp.
  apply Hy.
  exists delta.
  intros y By Hy.
  apply Hd.
  split ; simpl.
  apply By.
  apply ball_center.
  contradict Hy.
  clear -Hy.
  destruct z as [z1 z2].
  now injection Hy.
Qed.

(** * Derivatives *)

Definition C_derive (f : C -> C) (z : C) := C_lim (fun x => (f x - f z) / (x - z)) z.

Lemma is_C_derive_unique (f : C -> C) (z l : C) :
  is_derive f z l -> C_derive f z = l.
Proof.
  intros [_ Df].
  specialize (Df _ (fun P H => H)).
  apply is_C_lim_unique.
  intros P HP.
  destruct HP as [eps HP].
  destruct (Df (pos_div_2 eps)) as [eps' Df'].
  unfold filtermap, locally', within.

  apply locally_C.
  exists eps'.
  intros y Hy Hyz.
  apply HP.
  assert (y - z <> 0).
  contradict Hyz.
  replace y with (y - z + z) by ring.
  rewrite Hyz.
  apply Cplus_0_l.
  apply: norm_compat1.
  rewrite /minus /plus /opp /=.
  replace ((f y - f z) / (y - z) + - l) with
    ((f y + - f z + - ((y + - z) * l)) / (y + - z)).
  2: by field.
  rewrite /norm /= Cmod_div => //.
  apply Rlt_div_l.
  by apply Cmod_gt_0.
  eapply Rle_lt_trans.
  apply (Df' y Hy).
  simpl.
  rewrite /Rdiv Rmult_assoc.
  apply Rmult_lt_compat_l.
  by apply eps.
  rewrite Rmult_comm Rlt_div_l.
  rewrite /norm /minus /plus /opp /= /abs /=.
  apply Rminus_lt_0 ; ring_simplify.
  by apply Cmod_gt_0.
  by apply Rlt_0_2.
Qed.
Lemma C_derive_correct (f : C -> C) (z l : C) :
  ex_derive f z -> is_derive f z (C_derive f z).
Proof.
  case => df Hf.
  replace (C_derive f z) with df => //.
  by apply sym_eq, is_C_derive_unique.
Qed.


(** * Typechecking: A Typechecker for STLC *)

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, tell us how to _check_ whether or not a term is well
    typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- they exactly follow the shape of the term.  This makes it
    straightforward to translate the typing rules into clauses of a
    typechecking _function_ that takes a term and a context and either
    returns the term's type or else signals that the term is not
    typable.  This short chapter constructs such a function and proves
    it correct. *)

Require Import Coq.Bool.Bool.
Require Import SfLib.
Require Import Maps.
Require Import Stlc.

Module STLCChecker.
Import STLC.

(* ###################################################################### *)
(** ** Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=TBool *)
    reflexivity.
  - (* T1=TArrow T1_1 T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.

(* ###################################################################### *)
(** ** The Typechecker *)

(** The typechecker works by walking over the structure of the given
    term, returning either [Some T] or [None].  Each time we make a
    recursive call to find out the types of the subterms, we need to
    pattern-match on the results to make sure that they are not
    [None].  Also, in the [tapp] case, we use pattern matching to
    extract the left- and right-hand sides of the function's arrow
    type (and fail if the type of the function is not [TArrow T11 T12]
    for some [T1] and [T2]). *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (update Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  | ttrue => Some TBool
  | tfalse => Some TBool
  | tif x t f => match type_check Gamma x with
                     | Some TBool =>
                       match type_check Gamma t, type_check Gamma f with
                         | Some T1, Some T2 =>
                           if beq_ty T1 T2 then Some T1 else None
                         | _,_ => None
                       end
                     | _ => None
                   end
  end.

(* ###################################################################### *)
(** ** Properties *)

(** To verify that this typechecking algorithm is correct, we show
    that it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* tvar *) eauto.
  - (* tapp *)
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T11 T2) eqn: Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
  - (* tabs *)
    rename i into y. rename t into T1.
    remember (update Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve by inversion.
    inversion H0; subst...
  - (* ttrue *) eauto.
  - (* tfalse *) eauto.
  - (* tif *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve by inversion.
    destruct Tc; try solve by inversion.
    destruct TO1 as [T1|]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) eauto.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.

(** $Date: 2016-05-26 12:03:56 -0400 (Thu, 26 May 2016) $ *)


From iris.algebra Require Import excl auth agree frac list cmra csum.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris_examples.logatom.conditional_increment Require Import spec.
Import uPred bi List Decidable.
Set Default Proof Using "Type".

(** Using prophecy variables with helping: implementing conditional counter from
    "Logical Relations for Fine-Grained Concurrency" by Turon et al. (POPL 2013) *)

(** * Implementation of the functions. *)

(*
  new_counter() :=
    let c = ref (injL 0) in
    ref c
 *)
Definition new_counter : val :=
  λ: <>,
    ref (ref (InjL #0)).

(*
  complete(c, f, x, n, p) :=
    Resolve CmpXchg(c, x, ref (injL (if !f then n+1 else n))) p (ref ()) ;; ()
 *)
Definition complete : val :=
  λ: "c" "f" "x" "n" "p",
    let: "l_ghost" := ref #() in
    (* Compare with #true to make this a total operation that never
       gets stuck, no matter the value stored in [f]. *)
    let: "new_n" := if: !"f" = #true then "n" + #1 else "n" in
    Resolve (CmpXchg "c" "x" (ref (InjL "new_n"))) "p" "l_ghost" ;; #().

(*
  get c :=
    let x = !c in
    match !x with
    | injL n      => n
    | injR (f, n, p) => complete c f x n p; get(c, f)
 *)
Definition get : val :=
  rec: "get" "c" :=
    let: "x" := !"c" in
    match: !"x" with
      InjL "n"    => "n"
    | InjR "args" =>
        let: "f" := Fst (Fst "args") in
        let: "n" := Snd (Fst "args") in
        let: "p" := Snd "args" in
        complete "c" "f" "x" "n" "p" ;;
        "get" "c"
    end.

(*
  cinc c f :=
    let x = !c in
    match !x with
    | injL n =>
        let p := new proph in
        let y := ref (injR (n, f, p)) in
        if CAS(c, x, y) then complete(c, f, y, n, p)
        else cinc c f
    | injR (f', n', p') =>
        complete(c, f', x, n', p');
        cinc c f
 *)
Definition cinc : val :=
  rec: "cinc" "c" "f" :=
    let: "x" := !"c" in
    match: !"x" with
      InjL "n" =>
        let: "p" := NewProph in
        let: "y" := ref (InjR ("f", "n", "p")) in
        if: CAS "c" "x" "y" then complete "c" "f" "y" "n" "p" ;; Skip
        else "cinc" "c" "f"
    | InjR "args'" =>
        let: "f'" := Fst (Fst "args'") in
        let: "n'" := Snd (Fst "args'") in
        let: "p'" := Snd "args'" in
        complete "c" "f'" "x" "n'" "p'" ;;
        "cinc" "c" "f"
    end.

(** ** Proof setup *)

Definition numUR      := authR $ optionUR $ exclR ZO.
Definition tokenUR    := exclR unitO.
Definition one_shotUR := csumR (exclR unitO) (agreeR unitO).

Class cincG Σ := ConditionalIncrementG {
                     cinc_numG      :> inG Σ numUR;
                     cinc_tokenG    :> inG Σ tokenUR;
                     cinc_one_shotG :> inG Σ one_shotUR;
                   }.

Definition cincΣ : gFunctors :=
  #[GFunctor numUR; GFunctor tokenUR; GFunctor one_shotUR].

Instance subG_cincΣ {Σ} : subG cincΣ Σ → cincG Σ.
Proof. solve_inG. Qed.

Section conditional_counter.
  Context {Σ} `{!heapG Σ, !gcG Σ, !cincG Σ}.
  Context (N : namespace).

  Local Definition stateN   := N .@ "state".
  Local Definition counterN := N .@ "counter".

  (** Updating and synchronizing the counter and flag RAs *)

  Lemma sync_counter_values γ_n (n m : Z) :
    own γ_n (● Excl' n) -∗ own γ_n (◯ Excl' m) -∗ ⌜n = m⌝.
  Proof.
    iIntros "H● H◯". iCombine "H●" "H◯" as "H". iDestruct (own_valid with "H") as "H".
      by iDestruct "H" as %[H%Excl_included%leibniz_equiv _]%auth_both_valid.
  Qed.

  Lemma update_counter_value γ_n (n1 n2 m : Z) :
    own γ_n (● Excl' n1) -∗ own γ_n (◯ Excl' n2) ==∗ own γ_n (● Excl' m) ∗ own γ_n (◯ Excl' m).
  Proof.
    iIntros "H● H◯". iCombine "H●" "H◯" as "H". rewrite -own_op. iApply (own_update with "H").
    by apply auth_update, option_local_update, exclusive_local_update.
  Qed.

  Definition counter_content (γs : gname) (n : Z) :=
    (own γs (◯ Excl' n))%I.

  (** Definition of the invariant *)

  Fixpoint val_to_some_loc (vs : list (val * val)) : option loc :=
    match vs with
    | ((_, #true)%V, LitV (LitLoc l)) :: _  => Some l
    | _                         :: vs => val_to_some_loc vs
    | _                               => None
    end.

  Inductive abstract_state : Set :=
  | Quiescent : Z → abstract_state
  | Updating : loc → Z → proph_id → abstract_state.

  Definition state_to_val (s : abstract_state) : val :=
    match s with
    | Quiescent n => InjLV #n
    | Updating f n p => InjRV (#f,#n,#p)
    end.

  Global Instance state_to_val_inj : Inj (=) (=) state_to_val.
  Proof.
    intros [|] [|]; simpl; intros Hv; inversion_clear Hv; done.
  Qed.

  Definition own_token γ := (own γ (Excl ()))%I.

  Definition pending_state P (n : Z) (proph_winner : option loc) l_ghost_winner (γ_n : gname) :=
    (P ∗ ⌜match proph_winner with None => True | Some l => l = l_ghost_winner end⌝ ∗ own γ_n (● Excl' n))%I.

  (* After the prophecy said we are going to win the race, we commit and run the AU,
     switching from [pending] to [accepted]. *)
  Definition accepted_state Q (proph_winner : option loc) (l_ghost_winner : loc) :=
    (l_ghost_winner ↦{1/2} - ∗ match proph_winner with None => True | Some l => ⌜l = l_ghost_winner⌝ ∗ Q end)%I.

  (* The same thread then wins the CmpXchg and moves from [accepted] to [done].
     Then, the [γ_t] token guards the transition to take out [Q].
     Remember that the thread winning the CmpXchg might be just helping.  The token
     is owned by the thread whose request this is.
     In this state, [l_ghost_winner] serves as a token to make sure that
     only the CmpXchg winner can transition to here, and owning half of[l] serves as a
     "location" token to ensure there is no ABA going on. Notice how [counter_inv]
     owns *more than* half of its [l], which means we know that the [l] there
     and here cannot be the same. *)
  Definition done_state Q (l l_ghost_winner : loc) (γ_t : gname) :=
    ((Q ∨ own_token γ_t) ∗ l_ghost_winner ↦ - ∗ l ↦{1/2} -)%I.

  (* We always need the [proph] in here so that failing threads coming late can
     always resolve their stuff.
     Moreover, we need a way for anyone who has observed the [done] state to
     prove that we will always remain [done]; that's what the one-shot token [γ_s] is for. *)
  Definition state_inv P Q (p : proph_id) n (c_l l l_ghost_winner : loc) γ_n γ_t γ_s : iProp Σ :=
    (∃ vs, proph p vs ∗
      (own γ_s (Cinl $ Excl ()) ∗
       (c_l ↦{1/2} #l ∗ ( pending_state P n (val_to_some_loc vs) l_ghost_winner γ_n
        ∨ accepted_state Q (val_to_some_loc vs) l_ghost_winner ))
       ∨ own γ_s (Cinr $ to_agree ()) ∗ done_state Q l l_ghost_winner γ_t))%I.

  Definition pau P Q γs f :=
    (▷ P -∗ ◇ AU << ∀ (b : bool) (n : Z), counter_content γs n ∗ gc_mapsto f #b >> @ ⊤∖↑N∖↑gcN, ∅
                 << counter_content γs (if b then n + 1 else n) ∗ gc_mapsto f #b, COMM Q >>)%I.

  Definition counter_inv γ_n c :=
    (∃ (l : loc) (q : Qp) (s : abstract_state),
       (* We own *more than* half of [l], which shows that this cannot
          be the [l] of any [state] protocol in the [done] state. *)
       c ↦{1/2} #l ∗ l ↦{1/2 + q} (state_to_val s) ∗
       match s with
        | Quiescent n => c ↦{1/2} #l ∗ own γ_n (● Excl' n)
        | Updating f n p =>
           ∃ P Q l_ghost_winner γ_t γ_s,
             (* There are two pieces of per-[state]-protocol ghost state:
             - [γ_t] is a token owned by whoever created this protocol and used
               to get out the [Q] in the end.
             - [γ_s] reflects whether the protocol is [done] yet or not. *)
             inv stateN (state_inv P Q p n c l l_ghost_winner γ_n γ_t γ_s) ∗
             □ pau P Q γ_n f ∗ is_gc_loc f
       end)%I.

  Local Hint Extern 0 (environments.envs_entails _ (counter_inv _ _)) => unfold counter_inv.

  Definition is_counter (γ_n : gname) (ctr : val) :=
    (∃ (c : loc), ⌜ctr = #c ∧ N ## gcN⌝ ∗ gc_inv ∗ inv counterN (counter_inv γ_n c))%I.

  Global Instance is_counter_persistent γs ctr : Persistent (is_counter γs ctr) := _.

  Global Instance counter_content_timeless γs n : Timeless (counter_content γs n) := _.

  Global Instance abstract_state_inhabited: Inhabited abstract_state := populate (Quiescent 0).

  Lemma counter_content_exclusive γs c1 c2 :
    counter_content γs c1 -∗ counter_content γs c2 -∗ False.
  Proof.
    iIntros "Hb1 Hb2". iDestruct (own_valid_2 with "Hb1 Hb2") as %?.
    done.
  Qed.

  (** A few more helper lemmas that will come up later *)

  Lemma mapsto_valid_3 l v1 v2 q :
    l ↦ v1 -∗ l ↦{q} v2 -∗ ⌜False⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (mapsto_valid_2 with "Hl1 Hl2") as %Hv.
    apply (iffLR (frac_valid' _)) in Hv. by apply Qp_not_plus_q_ge_1 in Hv.
  Qed.

  (** Once a [state] protocol is [done] (as reflected by the [γ_s] token here),
      we can at any later point in time extract the [Q]. *)
  Lemma state_done_extract_Q P Q p m c_l l l_ghost γ_n γ_t γ_s :
    inv stateN (state_inv P Q p m c_l l l_ghost γ_n γ_t γ_s) -∗
    own γ_s (Cinr (to_agree ())) -∗
    □(own_token γ_t ={⊤}=∗ ▷ Q).
  Proof.
    iIntros "#Hinv #Hs !# Ht".
    iInv stateN as (vs) "(Hp & [NotDone | Done])".
    * (* Moved back to NotDone: contradiction. *)
      iDestruct "NotDone" as "(>Hs' & _ & _)".
      iDestruct (own_valid_2 with "Hs Hs'") as %?. contradiction.
    * iDestruct "Done" as "(_ & QT & Hghost)".
      iDestruct "QT" as "[Q | >T]"; last first.
      { iDestruct (own_valid_2 with "Ht T") as %Contra.
          by inversion Contra. }
      iSplitR "Q"; last done. iIntros "!> !>". unfold state_inv.
      iExists _. iFrame "Hp". iRight.
      unfold done_state. iFrame "#∗".
  Qed.

  (** ** Proof of [complete] *)

  (** The part of [complete] for the succeeding thread that moves from [accepted] to [done] state *)
  Lemma complete_succeeding_thread_pending (γ_n γ_t γ_s : gname) c_l P Q p
        (m n : Z) (l l_ghost l_new : loc) Φ :
    inv counterN (counter_inv γ_n c_l) -∗
    inv stateN (state_inv P Q p m c_l l l_ghost γ_n γ_t γ_s) -∗
    l_ghost ↦{1 / 2} #() -∗
    (□(own_token γ_t ={⊤}=∗ ▷ Q) -∗ Φ #()) -∗
    own γ_n (● Excl' n) -∗
    l_new ↦ InjLV #n -∗
    WP Resolve (CmpXchg #c_l #l #l_new) #p #l_ghost ;; #() {{ v, Φ v }}.
  Proof.
    iIntros "#InvC #InvS Hl_ghost HQ Hn● [Hl_new Hl_new']". wp_bind (Resolve _ _ _)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl Hl'] & Hrest)".
    iInv stateN as (vs) "(>Hp & [NotDone | Done])"; last first.
    { (* We cannot be [done] yet, as we own the "ghost location" that serves
         as token for that transition. *)
      iDestruct "Done" as "(_ & _ & Hlghost & _)".
      iDestruct "Hlghost" as (v') ">Hlghost".
        by iDestruct (mapsto_valid_2 with "Hl_ghost Hlghost") as %?.
    }
    iDestruct "NotDone" as "(>Hs & >Hc' & [Pending | Accepted])".
    { (* We also cannot be [Pending] any more we have [own γ_n] showing that this
       transition has happened   *)
       iDestruct "Pending" as "[_ >[_ Hn●']]".
       iCombine "Hn●" "Hn●'" as "Contra".
       iDestruct (own_valid with "Contra") as %Contra. by inversion Contra.
    }
    (* So, we are [Accepted]. Now we can show that l = l', because
       while a [state] protocol is not [done], it owns enough of
       the [counter] protocol to ensure that does not move anywhere else. *)
    iDestruct (mapsto_agree with "Hc Hc'") as %[= ->].
    (* We perform the CmpXchg. *)
    iCombine "Hc Hc'" as "Hc".
    wp_apply (wp_resolve with "Hp"); first done; wp_cmpxchg_suc.
    iIntros (vs' ->) "Hp'". simpl.
    (* Update to Done. *)
    iDestruct "Accepted" as "[Hl_ghost_inv [HEq Q]]".
    iMod (own_update with "Hs") as "Hs".
    { apply (cmra_update_exclusive (Cinr (to_agree ()))). done. }
    iDestruct "Hs" as "#Hs'". iModIntro.
    iSplitL "Hl_ghost_inv Hl_ghost Q Hp' Hl".
    (* Update state to Done. *)
    { iNext. iExists _. iFrame "Hp'". iRight. unfold done_state.
      iFrame "#∗". iSplitR "Hl"; iExists _; done. }
    iModIntro. iSplitR "HQ".
    { iNext. iDestruct "Hc" as "[Hc1 Hc2]".
      iExists l_new, _, (Quiescent n). iFrame. }
    iApply wp_fupd. wp_seq. iApply "HQ".
    iApply state_done_extract_Q; done.
  Qed.

  (** The part of [complete] for the failing thread *)
  Lemma complete_failing_thread γ_n γ_t γ_s c_l l P Q p m n l_ghost_inv l_ghost l_new Φ :
    l_ghost_inv ≠ l_ghost →
    inv counterN (counter_inv γ_n c_l) -∗
    inv stateN (state_inv P Q p m c_l l l_ghost_inv γ_n γ_t γ_s) -∗
    (□(own_token γ_t ={⊤}=∗ ▷ Q) -∗ Φ #()) -∗
    l_new ↦ InjLV #n -∗
    WP Resolve (CmpXchg #c_l #l #l_new) #p #l_ghost ;; #() {{ v, Φ v }}.
  Proof.
    iIntros (Hnl) "#InvC #InvS HQ Hl_new". wp_bind (Resolve _ _ _)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl Hl'] & Hrest)".
    iInv stateN as (vs) "(>Hp & [NotDone | [#Hs Done]])".
    { (* If the [state] protocol is not done yet, we can show that it
         is the active protocol still (l = l').  But then the CmpXchg would
         succeed, and our prophecy would have told us that.
         So here we can prove that the prophecy was wrong. *)
        iDestruct "NotDone" as "(_ & >Hc' & State)".
        iDestruct (mapsto_agree with "Hc Hc'") as %[=->].
        iCombine "Hc Hc'" as "Hc".
        wp_apply (wp_resolve with "Hp"); first done; wp_cmpxchg_suc.
        iIntros (vs' ->). iDestruct "State" as "[Pending | Accepted]".
        + iDestruct "Pending" as "[_ [Hvs _]]". iDestruct "Hvs" as %Hvs. by inversion Hvs.
        + iDestruct "Accepted" as "[_ [Hvs _]]". iDestruct "Hvs" as %Hvs. by inversion Hvs. }
    (* So, we know our protocol is [Done]. *)
    (* It must be that l' ≠ l because we are in the failing thread. *)
    destruct (decide (l' = l)) as [->|Hn]. {
      (* The [state] protocol is [done] while still being the active protocol
         of the [counter]?  Impossible, now we will own more than the whole location! *)
      iDestruct "Done" as "(_ & _ & >Hl'')".
      iDestruct "Hl''" as (v') "Hl''".
      iDestruct (mapsto_combine with "Hl Hl''") as "[Hl _]".
      rewrite Qp_half_half. iDestruct (mapsto_valid_3 with "Hl Hl'") as "[]".
    }
    (* The CmpXchg fails. *)
    wp_apply (wp_resolve with "Hp"); first done. wp_cmpxchg_fail.
    iIntros (vs' ->) "Hp". iModIntro.
    iSplitL "Done Hp". { iNext. iExists _. iFrame "#∗". } iModIntro.
    iSplitL "Hc Hrest Hl Hl'". { eauto 10 with iFrame. }
    wp_seq. iApply "HQ".
    iApply state_done_extract_Q; done.
  Qed.

  (** ** Proof of [complete] *)
  (* The postcondition basically says that *if* you were the thread to own
     this request, then you get [Q].  But we also try to complete other
     thread's requests, which is why we cannot ask for the token
     as a precondition. *)
  Lemma complete_spec (c f l : loc) (n : Z) (p : proph_id) γ_n γ_t γ_s l_ghost_inv P Q :
    N ## gcN →
    gc_inv -∗
    inv counterN (counter_inv γ_n c) -∗
    inv stateN (state_inv P Q p n c l l_ghost_inv γ_n γ_t γ_s) -∗
    □ pau P Q γ_n f -∗
    is_gc_loc f -∗
    {{{ True }}}
       complete #c #f #l #n #p
    {{{ RET #(); □ (own_token γ_t ={⊤}=∗ ▷Q) }}}.
  Proof.
    iIntros (?) "#GC #InvC #InvS #PAU #isGC".
    iModIntro. iIntros (Φ) "_ HQ". wp_lam. wp_pures.
    wp_alloc l_ghost as "[Hl_ghost' Hl_ghost'2]". wp_pures.
    wp_bind (! _)%E. simpl.
    (* open outer invariant *)
    iInv counterN as (l' q s) "(>Hc & >Hl' & Hrest)".
    (* two different proofs depending on whether we are succeeding thread *)
    destruct (decide (l_ghost_inv = l_ghost)) as [-> | Hnl].
    - (* we are the succeeding thread *)
      (* we need to move from [pending] to [accepted]. *)
      iInv stateN as (vs) "(>Hp & [(>Hs & >Hc' & [Pending | Accepted]) | [#Hs Done]])".
      + (* Pending: update to accepted *)
        iDestruct "Pending" as "[P >[Hvs Hn●]]".
        iDestruct ("PAU" with "P") as ">AU".
        iMod (gc_access with "GC") as "Hgc"; first solve_ndisj.
        (* open and *COMMIT* AU, sync flag and counter *)
        iMod "AU" as (b n2) "[[Hn◯ Hf] [_ Hclose]]".
        iDestruct ("Hgc" with "Hf") as "[Hf Hfclose]".
        wp_load.
        iMod ("Hfclose" with "Hf") as "[Hf Hfclose]".
        iDestruct (sync_counter_values with "Hn● Hn◯") as %->.
        iMod (update_counter_value _ _ _ (if b then n2 + 1 else n2) with "Hn● Hn◯")
          as "[Hn● Hn◯]".
        iMod ("Hclose" with "[Hn◯ Hf]") as "Q"; first by iFrame.
        iModIntro. iMod "Hfclose" as "_".
        (* close state inv *)
        iIntros "!> !>". iSplitL "Q Hl_ghost' Hp Hvs Hs Hc'".
        { iNext. iExists _. iFrame "Hp". iLeft. iFrame.
          iRight. iSplitL "Hl_ghost'"; first by iExists _.
          destruct (val_to_some_loc vs) eqn:Hvts; iFrame. }
        (* close outer inv *)
        iModIntro. iSplitR "Hl_ghost'2 HQ Hn●".
        { eauto 12 with iFrame. }
        destruct b;
        wp_alloc l_new as "Hl_new"; wp_pures;
          iApply (complete_succeeding_thread_pending
                    with "InvC InvS Hl_ghost'2 HQ Hn● Hl_new").
      + (* Accepted: contradiction *)
        iDestruct "Accepted" as "[>Hl_ghost_inv _]".
        iDestruct "Hl_ghost_inv" as (v) "Hlghost".
        iCombine "Hl_ghost'" "Hl_ghost'2" as "Hl_ghost'".
        by iDestruct (mapsto_valid_2 with "Hlghost Hl_ghost'") as %?.
      + (* Done: contradiction *)
        iDestruct "Done" as "[QT >[Hlghost _]]".
        iDestruct "Hlghost" as (v) "Hlghost".
        iCombine "Hl_ghost'" "Hl_ghost'2" as "Hl_ghost'".
        by iDestruct (mapsto_valid_2 with "Hlghost Hl_ghost'") as %?.
    - (* we are the failing thread. exploit that [f] is a GC location. *)
      iMod (is_gc_access with "GC isGC") as (b) "[H↦ Hclose]"; first solve_ndisj.
      wp_load.
      iMod ("Hclose" with "H↦") as "_". iModIntro.
      (* close invariant *)
      iModIntro. iSplitL "Hc Hrest Hl'". { eauto 10 with iFrame. }
      (* two equal proofs depending on value of b1 *)
      wp_pures.
      destruct (bool_decide (b = #true));
      wp_alloc Hl_new as "Hl_new"; wp_pures;
        iApply (complete_failing_thread
                  with "InvC InvS HQ Hl_new"); done.
  Qed.

  (** ** Proof of [cinc] *)

  Lemma cinc_spec γs v (f: loc) :
    is_counter γs v -∗
    <<< ∀ (b : bool) (n : Z), counter_content γs n ∗ gc_mapsto f #b >>>
        cinc v #f @⊤∖↑N∖↑gcN
    <<< counter_content γs (if b then n + 1 else n) ∗ gc_mapsto f #b, RET #() >>>.
  Proof.
    iIntros "#InvC". iDestruct "InvC" as (c_l [-> ?]) "[#GC #InvC]".
    iIntros (Φ) "AU". iLöb as "IH".
    wp_lam. wp_pures. wp_bind (!_)%E.
    iInv counterN as (l' q s) "(>Hc & >[Hl [Hl' Hl'']] & Hrest)".
    wp_load. destruct s as [n|f' n' p'].
    - iDestruct "Hrest" as "(Hc' & Hv)".
      iModIntro. iSplitR "AU Hl'".
      { iModIntro. iExists _, (q/2)%Qp, (Quiescent n). iFrame. }
      wp_let. wp_load. wp_match. wp_apply wp_new_proph; first done.
      iIntros (l_ghost p') "Hp'".
      wp_let. wp_alloc ly as "Hly".
      wp_let. wp_bind (CmpXchg _ _ _)%E.
      (* open outer invariant again to CAS c_l *)
      iInv counterN as (l'' q2 s) "(>Hc & >Hl & Hrest)".
      destruct (decide (l' = l'')) as [<- | Hn].
      + (* CAS succeeds *)
        iDestruct (mapsto_agree with "Hl' Hl") as %<-%state_to_val_inj.
        iDestruct "Hrest" as ">[Hc' Hn●]". iCombine "Hc Hc'" as "Hc".
        wp_cmpxchg_suc.
        (* Take a "peek" at [AU] and abort immediately to get [gc_is_gc f]. *)
        iMod "AU" as (b' n') "[[CC Hf] [Hclose _]]".
        iDestruct (gc_is_gc with "Hf") as "#Hgc".
        iMod ("Hclose" with "[CC Hf]") as "AU"; first by iFrame.
        (* Initialize new [state] protocol .*)
        iDestruct (laterable with "AU") as (AU_later) "[AU #AU_back]".
        iMod (own_alloc (Excl ())) as (γ_t) "Token"; first done.
        iMod (own_alloc (Cinl $ Excl ())) as (γ_s) "Hs"; first done.
        iDestruct "Hc" as "[Hc Hc']".
        set (winner := default ly (val_to_some_loc l_ghost)).
        iMod (inv_alloc stateN _ (state_inv AU_later _ _ _ _ _ winner _ _ _)
               with "[AU Hs Hp' Hc' Hn●]") as "#Hinv".
        { iNext. iExists _. iFrame "Hp'". iLeft. iFrame. iLeft.
          iFrame. destruct (val_to_some_loc l_ghost); simpl; done. }
        iModIntro. iDestruct "Hly" as "[Hly1 Hly2]". iSplitR "Hl' Token". {
          (* close invariant *)
          iNext. iExists _, _, (Updating f n p'). eauto 10 with iFrame.
        }
        wp_pures. wp_apply complete_spec; [done..|].
        iIntros "Ht". iMod ("Ht" with "Token") as "Φ". wp_seq. by wp_lam.
      + (* CAS fails: closing invariant and invoking IH *)
        wp_cmpxchg_fail.
        iModIntro. iSplitR "AU".
        { iModIntro. iExists _, _, s. iFrame. }
        wp_pures. by iApply "IH".
    - (* l' ↦ injR *)
      iModIntro.
      (* extract state invariant *)
      iDestruct "Hrest" as (P Q l_ghost γ_t γ_s) "(#InvS & #P_AU & #Hgc)".
      iSplitR "Hl' AU".
      (* close invariant *)
      { iModIntro. iExists _, _, (Updating f' n' p'). iFrame. eauto 10 with iFrame. }
      wp_let. wp_load. wp_match. wp_pures.
      wp_apply complete_spec; [done..|].
      iIntros "_". wp_seq. by iApply "IH".
  Qed.

  Lemma new_counter_spec :
    N ## gcN →
    gc_inv -∗
    {{{ True }}}
        new_counter #()
    {{{ ctr γs, RET ctr ; is_counter γs ctr ∗ counter_content γs 0 }}}.
  Proof.
    iIntros (?) "#GC". iIntros (Φ) "!# _ HΦ". wp_lam. wp_apply wp_fupd.
    wp_alloc l_n as "Hl_n".
    wp_alloc l_c as "Hl_c".
    iMod (own_alloc (● Excl' 0  ⋅ ◯ Excl' 0)) as (γ_n) "[Hn● Hn◯]".
    { by apply auth_both_valid. }
    iMod (inv_alloc counterN _ (counter_inv γ_n l_c)
      with "[Hl_c Hl_n Hn●]") as "#InvC".
    { iNext. iDestruct "Hl_c" as "[Hl_c1 Hl_c2]".
      iDestruct "Hl_n" as "[??]".
      iExists l_n, (1/2)%Qp, (Quiescent 0). iFrame. }
    iModIntro.
    iApply ("HΦ" $! #l_c γ_n).
    iSplitR; last by iFrame. iExists _. eauto with iFrame.
  Qed.

  Lemma get_spec γs v :
    is_counter γs v -∗
    <<< ∀ (n : Z), counter_content γs n >>>
        get v @⊤∖↑N∖↑gcN
    <<< counter_content γs n, RET #n >>>.
  Proof.
    iIntros "#InvC" (Φ) "AU". iDestruct "InvC" as (c_l [-> ?]) "[GC InvC]".
    iLöb as "IH". wp_lam. wp_bind (! _)%E.
    iInv counterN as (c q s) "(>Hc & >[Hl [Hl' Hl'']] & Hrest)".
    wp_load.
    destruct s as [n|f n p].
    - iMod "AU" as (au_n) "[Hn◯ [_ Hclose]]"; simpl.
      iDestruct "Hrest" as "[Hc' Hn●]".
      iDestruct (sync_counter_values with "Hn● Hn◯") as %->.
      iMod ("Hclose" with "Hn◯") as "HΦ".
      iModIntro. iSplitR "HΦ Hl'". {
        iNext. iExists c, (q/2)%Qp, (Quiescent au_n). iFrame.
      }
      wp_let. wp_load. wp_match. iApply "HΦ".
    - iDestruct "Hrest" as (P Q l_ghost γ_t γ_s) "(#InvS & #PAU & #Hgc)".
      iModIntro. iSplitR "AU Hl'". {
        iNext. iExists c, (q/2)%Qp, (Updating _ _ p). eauto 10 with iFrame.
      }
      wp_let. wp_load. wp_pures. wp_bind (complete _ _ _ _ _)%E.
      wp_apply complete_spec; [done..|].
      iIntros "Ht". wp_seq. iApply "IH". iApply "AU".
  Qed.

End conditional_counter.

Definition atomic_cinc `{!heapG Σ, !cincG Σ, !gcG Σ} :
  spec.atomic_cinc Σ :=
  {| spec.new_counter_spec := new_counter_spec;
     spec.cinc_spec := cinc_spec;
     spec.get_spec := get_spec;
     spec.counter_content_exclusive := counter_content_exclusive |}.

Typeclasses Opaque counter_content is_counter.


Require Import
  HoTT.Basics
  HoTT.TruncType
  HoTT.HProp
  HoTT.Types
  HoTT.UnivalenceImpliesFunext
  HoTT.Algebra.UniversalAlgebra.Infinitary.ua_homomorphism.

Import algebra_notations.

Section closed_under_op.
  Context `{Funext} {σ} (A : Algebra σ) (P : ∀ s, A s → Type).

  (** Let [α : A s1 → A s2 → ... → A sn → A t] be an algebra
      operation. Then [P] satisfies [ClosedUnderOp α] iff
      for [x1 : A s1], [x2 : A s2], ..., [xn : A sn],

    <<
      P s1 x1 ∧ P s2 x2 ∧ ... ∧ P sn xn
    >>

    implies

    <<
      P t (α x1 x2 ... xn)
    >>
  *)

  Definition ClosedUnderOp {w : SymbolType σ} (α : Operation A w) : Type :=
    ∀ (a : DomOperation A w),
    (∀ X, P (sorts_dom w X) (a X)) → P (sort_cod w) (α a).

  Definition IsClosedUnderOps : Type
    := ∀ (u : Symbol σ), ClosedUnderOp (u^^A).
End closed_under_op.

(** [P : ∀ s, A s → Type] is a subalgebra predicate if it is closed
    under operations [IsClosedUnderOps A P] and [P s x] is an h-prop. *)

Section subalgebra_predicate.
  Context {σ} (A : Algebra σ) (P : ∀ s, A s → Type).

  Class IsSubalgebraPredicate
    := Build_IsSubalgebraPredicate
    { hprop_subalgebra_predicate : ∀ s x, IsHProp (P s x);
      is_closed_under_ops_subalgebra_predicate : IsClosedUnderOps A P }.

  Global Instance hprop_is_subalgebra_predicate `{Funext}
    : IsHProp IsSubalgebraPredicate.
  Proof.
    apply hprop_allpath.
    intros [x1 x2] [y1 y2].
    by destruct (path_ishprop x1 y1), (path_ishprop x2 y2).
  Defined.
End subalgebra_predicate.

Global Arguments Build_IsSubalgebraPredicate {σ A P hprop_subalgebra_predicate}.

Global Existing Instance hprop_subalgebra_predicate.

(** The next section defines subalgebra. *)

Section subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}.

(** The subalgebra carriers is the family of subtypes defined by [P]. *)

  Definition carriers_subalgebra : Carriers σ
    := λ (s : Sort σ), {x | P s x}.

(** Let [α : A s1 → ... → A sn → A t] be an operation and let [C :
    ClosedUnderOp A P α]. The corresponding subalgebra operation
    [op_subalgebra α C : (A&P) s1 → ... → (A&P) sn → (A&P) t] is
    given by

    <<
      op_subalgebra α C (x1; p1) ... (xn; pn) =
        (α x1 ... xn; C x1 p1 x2 p2 ... xn pn).
    >>
*)

  Definition op_subalgebra {w : SymbolType σ} (α : Operation A w)
    (c : ClosedUnderOp A P α) : Operation carriers_subalgebra w :=
    fun a => (α (fun X => (a X).1); c (fun X => (a X).1) (fun X => (a X).2)).

(** The subalgebra operations [ops_subalgebra] are defined in terms of
    [op_subalgebra]. *)

  Definition ops_subalgebra (u : Symbol σ)
    : Operation carriers_subalgebra (σ u)
    := op_subalgebra (u^^A) (is_closed_under_ops_subalgebra_predicate A P u).

  Definition Subalgebra : Algebra σ
    := Build_Algebra carriers_subalgebra ops_subalgebra.
End subalgebra.

Module subalgebra_notations.
  Notation "A & P" := (Subalgebra A P)
                      (at level 50, left associativity)
                      : Algebra_scope.
End subalgebra_notations.

Import subalgebra_notations.

(** The following section defines the inclusion homomorphism
    [Homomorphism (A&P) A], and some related results. *)

Section hom_inc_subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}.

  Definition def_inc_subalgebra (s : Sort σ) : (A&P) s → A s
    := pr1.

  Global Instance is_homomorphism_inc_subalgebra
    : IsHomomorphism def_inc_subalgebra.
  Proof.
    intros u a. reflexivity.
  Defined.

  Definition hom_inc_subalgebra : Homomorphism (A&P) A
    := Build_Homomorphism def_inc_subalgebra.

  Lemma is_isomorphism_inc_improper_subalgebra
    (improper : ∀ s (x : A s), P s x)
    : IsIsomorphism hom_inc_subalgebra.
  Proof.
    intro s.
    refine (isequiv_adjointify _ (λ x, (x; improper s x)) _ _).
    - intro x. reflexivity.
    - intro x. by apply path_sigma_hprop.
  Qed.
End hom_inc_subalgebra.

(** The next section provides paths between subalgebras. These paths
    are convenient to have because the implicit type-class argument
    [IsClosedUnderOps] of [Subalgebra] is complicating things. *)

Section path_subalgebra.
  Context
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) {CP : IsSubalgebraPredicate A P}
    (Q : ∀ s, A s → Type) {CQ : IsSubalgebraPredicate A Q}.

  Lemma path_subalgebra `{Funext} (p : P = Q) : A&P = A&Q.
  Proof.
    by destruct p, (path_ishprop CP CQ).
  Defined.

  Lemma path_subalgebra_iff `{Univalence} (R : ∀ s x, P s x <-> Q s x)
    : A&P = A&Q.
  Proof.
    apply path_subalgebra.
    funext s x.
    apply (@path_universe _ _ _ (fst (R s x))).
    apply (equiv_equiv_iff_hprop _ _ (R s x)).
  Defined.
End path_subalgebra.