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 ZArith.
From Bremen.theories.harmony Require Import Letter PitchClass Pitch Chord Key Note.
From Bremen.theories.rhythm Require Import Duration Division Meter.
From Bremen.theories.physics Require Import Dynamics.
From Bremen.theories.structure Require Import MelodicPart.
Require Import List.
Import ListNotations.

Definition melody1 := [
( note_of (C # 1 ' 4) (dur (Quarter)) (emphasized) )
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( rest_of (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (emphasized))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (emphasized))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( rest_of (dur (Quarter)) (mf))
; ( note_of (E # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (emphasized))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (emphasized))
; ( note_of (F # 1 ' 3) (dur (Quarter)) (mf))
; ( rest_of (dur (Quarter)) (emphasized))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (emphasized))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (C # 1 ' 4) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (B # 0 ' 3) (dur (Quarter)) (mf))
; ( note_of (A # 0 ' 3) (dur (Quarter)) (emphasized))
].

Definition constant_meter := constant_meter_in_the_middle melody1.
Eval compute in constant_meter.


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.