Require Import Coq.PArith.BinPos.
Require Import Coq.Lists.List. Import ListNotations.

Set Universe Polymorphism.

Inductive option{A : Type}: Type :=
| Some(a: A)
| None.

Arguments option: clear implicits.

Section NATMAP.
  Context {V: Type}.

  (* TODO if there are trailing None's map extensionality doesn't hold, can we fix that? *)
  Definition natmap := list (option V).

  Definition head(m: natmap): option V :=
    match m with
    | nil => None
    | o :: _ => o
    end.

  Fixpoint skip(n: nat)(m: natmap): natmap :=
    match n with
    | O => m
    | S n' => tail (skip n' m)
    end.

  Definition get(m: natmap)(n: nat): option V := head (skip n m).

  (* m2 overrides m1. Simplifies best if m2 is concrete *)
  Fixpoint merge(m1 m2: natmap): natmap :=
    match m2 with
    | nil => m1
    | cons h t => cons (match h with
                        | Some v => Some v
                        | None => head m1
                        end)
                       (merge (tail m1) t)
    end.

  Fixpoint singleton(k: nat)(v: V): natmap :=
    match k with
    | O => Some v :: nil
    | S n => None :: singleton n v
    end.

  Definition put(m: natmap)(k: nat)(v: V): natmap := merge m (singleton k v).

  Definition putmany: natmap -> list (nat * V) -> natmap :=
    List.fold_right (fun '(k, v) res => put res k v).

End NATMAP.

Arguments natmap: clear implicits.

Section NATMAP_TESTS.
  Context (unknown: natmap nat).

  Goal get (Some 10 :: Some 11 :: None :: Some 13 :: unknown) 3 =
  Some 13.
  Proof. reflexivity. Qed.

  Goal merge (Some 10 :: Some 11 :: None :: Some 13 :: unknown)
       (Some 100 :: None :: Some 120 :: nil) =
  (Some 100 :: Some 11 :: Some 120 :: Some 13 :: unknown).
  Proof. reflexivity. Qed.

  Goal merge (Some 10 :: Some 11 :: unknown)
       (Some 100 :: None :: Some 120 :: None :: Some 140 :: nil) =
  (Some 100 :: Some 11 :: Some 120 :: get unknown 1 :: Some 140 :: skip 3 unknown).
  Proof. reflexivity. Qed.

  Goal put (put unknown 2 20) 5 50 = put (put unknown 5 50) 2 20.
  Proof. reflexivity. Qed.

  Goal putmany unknown [(3, 33); (1, 11); (4, 44)] = putmany unknown [(1, 11); (3, 33); (4, 44)].
  Proof. reflexivity. Qed.

End NATMAP_TESTS.

Definition forcetype(o: option Type): Type :=
  match o with
  | Some T => T
  | None => unit
  end.

Inductive hnatmap: natmap Type -> Type :=
| HNil: hnatmap nil
| HCons{OV: option Type}{T: natmap Type}(v: forcetype OV)(t: hnatmap T): hnatmap (cons OV T).

Definition hhead{T: natmap Type}(m: hnatmap T): forcetype (head T) :=
  match m with
  | HNil => tt
  | HCons v _ => v
  end.

Definition htail{T: natmap Type}(m: hnatmap T): hnatmap (tail T) :=
  match m with
  | HNil => HNil
  | HCons _ t => t
  end.

Fixpoint hskip(n: nat){T: natmap Type}(m: hnatmap T): hnatmap (skip n T) :=
  match n with
  | 0 => m
  | S n' => htail (hskip n' m)
  end.

Definition hget{T: natmap Type}(m: hnatmap T)(n: nat): forcetype (get T n) := hhead (hskip n m).

(* m2 overrides m1 *)
Fixpoint hmerge{T1 T2: natmap Type}(m1: hnatmap T1)(m2: hnatmap T2): hnatmap (merge T1 T2).
  refine (match m2 with
          | HNil => m1
          | @HCons OV T2Tail v t => @HCons (match OV with
                                            | Some V => Some V
                                            | None => head T1
                                            end)
                                           (merge (tail T1) T2Tail)
                                           _
                                           (hmerge _ _ (htail m1) t)
          end).
  destruct OV as [V|].
  - exact v.
  - exact (hhead m1).
Defined.

Fixpoint hsingleton{V: Type}(k: nat)(v: V){struct k}: hnatmap (singleton k V) :=
  match k with
  | 0 => @HCons (Some V) [] v HNil
  | S n => @HCons None (singleton n V) tt (hsingleton n v)
  end.

Definition hset(k: nat){V: Type}(v: V){T: natmap Type}(m: hnatmap T): hnatmap (put T k V) :=
  hmerge m (hsingleton k v).

Section HNATMAP_TESTS.
  Context (UnknownFields: natmap Type).
  Context (unknown: hnatmap UnknownFields).

  Goal hget (hset 2 true (hset 4 44 (hset 3 false (hset 4 (@nil nat) unknown)))) 4 = 44.
  Proof. reflexivity. Qed.

  Goal (hset 2 true (hset 4 44 unknown)) = (hset 4 44 (hset 2 true unknown)).
  Proof. reflexivity. Qed.

  Goal (hset 2 true (hset 4 44 (hset 3 false (hset 4 (@nil nat) unknown)))) =
       (hset 4 44 (hset 3 false (hset 2 true unknown))).
  Proof. reflexivity. Qed.
End HNATMAP_TESTS.

Definition commonVal := 4.

Module File1. Section __.
  Definition flag1 := 3.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type := putmany UnknownFields [(flag1, bool: Type); (commonVal, nat: Type)].
  Definition State: Type := hnatmap Fields.

  Definition op(s: State): State := hset commonVal (hget s commonVal + 2) (hset flag1 false s).
End __. End File1.

Module File2. Section __.
  Definition flag2 := 0.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type := putmany UnknownFields [(flag2, bool: Type); (commonVal, nat: Type)].
  Definition State: Type := hnatmap Fields.

  Definition op(s: State): State := hset flag2 true (hset commonVal (hget s commonVal + 3) (hset flag2 false s)).
End __. End File2.

Module File3. Section __.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type :=
    putmany UnknownFields [
              (File1.flag1, bool: Type);
              (File2.flag2, bool: Type);
              (commonVal, nat: Type)
            ].
  Definition State: Type := hnatmap Fields.

  Goal File1.State (putmany UnknownFields [(File2.flag2, bool: Type)]) = State.
  Proof. reflexivity. Qed.

  Definition op1: State -> State :=
    File1.op (putmany UnknownFields [(File2.flag2, bool: Type)]).

  Definition op2: State -> State :=
    File2.op (putmany UnknownFields [(File1.flag1, bool: Type)]).

  Goal forall s: State,
      hget (op1 (op2 s)) commonVal = hget s commonVal + 5.
  Proof.
    intros.
    unfold op1, op2, File1.op, File2.op, hget, hset.
    simpl.
    rewrite <- PeanoNat.Nat.add_assoc.
    reflexivity.
  Qed.
End __. End File3.


(*
Copyright © 2006 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.reals.fast.CRAlternatingSum.
Require Import CoRN.reals.fast.CRAlternatingSum_alg.
Require Import CoRN.reals.fast.CRstreams.
Require Import CoRN.reals.fast.CRexp.
Require Import CoRN.reals.fast.CRpi.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import Coq.QArith.Qpower Coq.QArith.Qabs.
Require Import CoRN.model.ordfields.Qordfield.
Require Import Coq.QArith.Qround.
Require Import CoRN.transc.Pi.
Require Import CoRN.reals.fast.ModulusDerivative.
Require Import CoRN.reals.fast.ContinuousCorrect.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.transc.PowerSeries.
Require Import CoRN.transc.SinCos.
Require Import Coq.NArith.Ndigits.
Require Import CoRN.reals.fast.Compress.
Require Import CoRN.reals.fast.PowerBound.
Require Import CoRN.tactics.CornTac.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import CoRN.util.Qdlog.
From Coq Require Import Lia.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Opaque inj_Q CR Qmin Qmax.

Lemma Qmult_pos_neg : forall (a b : Q),
    0 <= a -> b <= 0 -> a*b <= 0.
Proof.
  intros. rewrite Qmult_comm.
  rewrite <- (Qmult_0_l a).
  apply Qmult_le_compat_r; assumption.
Qed.

Lemma Qmult_opp_1 : forall q : Q,
    eq (-q) (-1 * q).
Proof.
  reflexivity.
Qed.

Lemma fact_inc : forall n:nat, (fact n <= fact (S n))%nat.
Proof.
  intro n.
  rewrite <- (Nat.mul_1_l (fact n)).
  change (fact (S n)) with ((1+n)*fact n)%nat.
  apply Nat.mul_le_mono_nonneg_r.
  apply (Nat.le_trans _ 1).
  auto. exact (lt_O_fact n).
  apply le_n_S, le_0_n.
Qed.

Lemma fact_inc_recurse : forall p n:nat, (n <= p)%nat -> (fact n <= fact p)%nat.
Proof.
  induction p.
  - intros. inversion H. apply le_refl.
  - intros. apply Nat.le_succ_r in H. destruct H.
    apply (Nat.le_trans (fact n) (fact p)).
    apply IHp, H. apply fact_inc.
    subst n. apply le_refl.
Qed.

(**
** Sine
Sine is defined in terms of its alternating Taylor's series.
*)
Section SinSeries.
Variable a:Q.

(* (1,a) -> (3, -a^3/3!) -> ... *)
Definition sinStream (px : positive*Q) : positive*Q
  := let d := Pos.succ (fst px) in
     (Pos.add 2 (fst px), - snd px * a * a * (1#(d*Pos.succ d))).

Lemma sinStream_fst : forall p,
    fst (iterate _ sinStream p (1%positive, a)) ≡ Pos.succ (2*p).
Proof.
  apply Pos.peano_ind.
  - reflexivity.
  - intros p H. rewrite iterate_succ.
    destruct (iterate (positive and Q) sinStream p (1%positive, a)).
    simpl in H. subst p0.
    transitivity (Pos.add 2 (p~1)). reflexivity.
    clear q a. rewrite Pos.mul_succ_r.
    rewrite <- Pos.add_1_l, (Pos.add_comm 1).
    rewrite <- Pos.add_assoc. apply f_equal. reflexivity.
Qed.

(* The closed formula for the sine stream. *)
Lemma Str_pth_sinStream : forall (p:positive),
    Str_pth _ sinStream p (xH,a)
    == (1#Pos.of_nat (fact (1+2*Pos.to_nat p))) * ((-1)^p*a^(1+2*p))%Q.
Proof.
  apply Pos.peano_ind.
  - unfold sinStream, Str_pth; simpl.
    rewrite Qmult_comm. apply Qmult_comp. reflexivity.
    rewrite Qmult_assoc, Qmult_assoc.
    reflexivity.
  - intros p pInd. unfold Str_pth.
    rewrite iterate_succ. unfold Str_pth in pInd.
    pose proof (sinStream_fst p) as H0.
    destruct (iterate (positive and Q) sinStream p (1%positive, a)) as [p0 q].
    simpl in H0. subst p0. unfold snd in pInd.
    unfold sinStream, snd, fst.
    rewrite pInd. clear pInd q.
    (* Get rid of (-1)^p *)
    rewrite <- (Qmult_comm ((-1) ^ Pos.succ p * a ^ (1 + 2 * Pos.succ p))).
    rewrite <- (Pos.add_1_l p).
    rewrite Pos2Z.inj_add, (Qpower_plus (-1)%Q).
    simpl ((-1)^1).
    rewrite Qmult_opp_1.
    do 5 rewrite <- (Qmult_assoc (-1)).
    apply (Qmult_comp (-1)). reflexivity.
    rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))).
    do 5 rewrite <- (Qmult_assoc ((-1)^p)).
    apply Qmult_comp. reflexivity.
    (* Get rid of a *)
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    do 4 rewrite <- (Qmult_assoc (a ^ (1 + 2 * p))).
    apply Qmult_comp. reflexivity.
    rewrite <- (Qmult_assoc _ a a).
    rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))).
    rewrite <- (Qmult_assoc (a*a)).
    apply Qmult_comp. reflexivity.
    (* Get rid of fact *)
    unfold Qeq, Qmult, Qnum, Qden.
    rewrite Z.mul_1_l, Z.mul_1_l.
    rewrite <- (Pos2Nat.id (Pos.succ p~1 * Pos.succ (Pos.succ p~1))).
    rewrite <- Nat2Pos.inj_mul.
    2: apply fact_neq_0.
    replace (fact (1 + 2 * Pos.to_nat (1 + p)))%nat
      with (fact (1 + 2 * Pos.to_nat p) *
            Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat.
    reflexivity.
    rewrite Nat.mul_comm.
    replace (1 + 2 * Pos.to_nat (1 + p))%nat with (3 + 2 * Pos.to_nat p)%nat.
    change (fact (3 + 2 * Pos.to_nat p))%nat
      with ((3 + 2 * Pos.to_nat p)
            * ((2 + 2 * Pos.to_nat p) * fact (1 + 2 * Pos.to_nat p)))%nat.
    replace (Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat
      with ((3 + 2 * Pos.to_nat p) * ((2 + 2 * Pos.to_nat p)))%nat.
    rewrite Nat.mul_assoc.
    reflexivity.
    (* Finish equalities *)
    rewrite Pos2Nat.inj_mul.
    rewrite Nat.mul_comm. apply f_equal2.
    rewrite Pos2Nat.inj_succ.
    apply (f_equal S).
    rewrite Pos2Nat.inj_xI. reflexivity.
    rewrite Pos2Nat.inj_succ. apply (f_equal S).
    rewrite Pos2Nat.inj_succ. apply (f_equal S).
    rewrite Pos2Nat.inj_xI. reflexivity.
    rewrite Pos2Nat.inj_add. simpl.
    rewrite Nat.add_0_r, Nat.add_succ_r. reflexivity.
    intro abs.
    pose proof (Pos2Nat.is_pos (Pos.succ p~1 * Pos.succ (Pos.succ p~1))).
    rewrite abs in H. inversion H.
    rewrite <- (Qpower_plus_positive a 1 1).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    apply Qpower_positive_comp. reflexivity.
    rewrite <- Pos.add_assoc.
    apply f_equal. rewrite (Pos.add_comm 1 p).
    reflexivity.
    intro abs. discriminate.
Qed.

(** Sine is first defined on [[-1,1]] by an alternating series. *)
Lemma sinStream_alt : -1 <= a <= 1 -> Str_alt_decr _ sinStream (1%positive,a).
Proof.
  intro Ha. split.
  - (* Replace a by Qabs a *)
    rewrite Str_pth_sinStream, Str_pth_sinStream.
    rewrite Qabs_Qmult, Qabs_Qmult, Qabs_Qmult, Qabs_Qmult.
    rewrite Qabs_Qpower, Qabs_Qpower.
    change (Qabs (-1)) with 1.
    rewrite Qpower_1, Qpower_1, Qmult_1_l, Qmult_1_l.
    rewrite (Qabs_Qpower a (1+2*Pos.succ p)), (Qabs_Qpower a (1+2*p)).
    (* Finish inequality *)
    setoid_replace (Qabs a ^ (1 + 2 * Pos.succ p)%positive)
      with (Qabs a * Qabs a * Qabs a ^ (1 + 2 * p)%positive).
    rewrite Qmult_assoc.
    apply Qmult_le_compat_r.
    2: rewrite <- Qabs_Qpower; apply Qabs_nonneg.
    + rewrite Qmult_comm.
      apply (Qabs_Qle_condition a 1) in Ha.
      apply (Qle_trans _ (1* (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat (Pos.succ p)))))).
      apply Qmult_le_compat_r. 2: discriminate.
      apply (Qle_trans _ (1*Qabs a)).
      apply Qmult_le_compat_r. exact Ha.
      apply Qabs_nonneg. rewrite Qmult_1_l. exact Ha.
      rewrite Qmult_1_l. unfold Qabs, Z.abs.
      unfold Qle, Qnum, Qden.
      rewrite Z.mul_1_l, Z.mul_1_l.
      apply Pos2Nat.inj_le.
      rewrite Nat2Pos.id, Nat2Pos.id.
      2: apply fact_neq_0. 2: apply fact_neq_0.
      replace (1 + 2 * Pos.to_nat (Pos.succ p))%nat
        with (2 + (1 + 2 * Pos.to_nat p))%nat
        by (rewrite Pos2Nat.inj_succ; ring).
      apply (Nat.le_trans _ _ _ (fact_inc _)).
      apply fact_inc.
    + replace (1 + 2 * Pos.succ p)%positive with (2 + (1 + 2 * p))%positive.
      generalize (1 + 2 * p)%positive. clear p. intro p.
      unfold Qpower.
      rewrite Qpower_plus_positive. reflexivity.
      rewrite Pos.add_comm, <- Pos.add_assoc. apply f_equal.
      rewrite <- Pos.add_1_l.
      rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
      apply Pos.add_comm.
  - rewrite Str_pth_sinStream, Str_pth_sinStream.
    rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg.
    discriminate. rewrite Qmult_comm, <- Qmult_assoc.
    apply Qmult_pos_neg. discriminate.
    rewrite <- Pos.add_1_l.
    change ((-1) ^ (1 + p)%positive) with (Qpower_positive (-1) (1 + p)).
    rewrite Qpower_plus_positive. simpl (Qpower_positive (-1) 1).
    rewrite <- Qmult_assoc, <- Qmult_assoc.
    apply (Qopp_le_compat 0).
    rewrite (Qmult_comm (a ^ (1 + 2 * (1 + p)%positive))).
    rewrite Qmult_assoc, Qmult_assoc.
    rewrite <- Qmult_assoc.
    apply Qmult_le_0_compat.
    simpl.
    destruct (Qpower_positive (-1) p), Qnum; discriminate.
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    rewrite Qmult_assoc.
    apply Qmult_le_0_compat.
    destruct (a ^ (1 + 2 * p)), Qnum; discriminate.
    destruct a, Qnum; discriminate.
    change (a*a) with (Qpower_positive a 2).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    change (a ^ (1 + 2 * (1 + p))) with (Qpower_positive a (1 + 2 * (1 + p))).
    replace (1 + 2 * (1 + p))%positive with (1 + 2 * p + 2)%positive.
    reflexivity.
    rewrite <- Pos.add_assoc. apply f_equal.
    rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
    apply Pos.add_comm.
Qed.

Lemma sinStream_zl
  : -1 <= a <= 1
    -> Limit_zero _ sinStream (xH,a)
                 (fun e:Qpos => Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ (proj1_sig e)))))).
Proof.
  intro Ha.
  intros [e epos]. rewrite Str_pth_sinStream, Qabs_Qmult, Qabs_Qmult.
  rewrite Qabs_Qpower. change (Qabs (-1)) with 1.
  rewrite Qpower_1, Qmult_1_l.
  rewrite Qmult_comm.
  apply (Qle_trans
           _ (1 * Qabs (1 # Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))))).
  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
  - rewrite (Qabs_Qpower
               a (1 + 2 * Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ ` (e ↾ epos))))))).
    apply Qpower_le_1. split.
    apply Qabs_nonneg.
    apply Qabs_Qle_condition, Ha.
  - clear Ha a.
    rewrite Qmult_1_l. unfold Qabs, Z.abs, proj1_sig.
    rewrite <- (Qinv_involutive e) at 2.
    assert (0 < /e) as H.
    { apply Qinv_lt_0_compat, epos. }
    apply (@Qinv_le_compat
             (/e) ((Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))) # 1)).
    exact H.
    apply (Qle_trans _ _ _ (Qceiling_fact_le H)).
    generalize (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))).
    clear H epos e. intro p.
    unfold Qle, Qnum, Qden.
    rewrite Z.mul_1_r, Z.mul_1_r.
    apply Pos2Nat.inj_le.
    rewrite Nat2Pos.id, Nat2Pos.id.
    2: apply fact_neq_0. 2: apply fact_neq_0.
    apply fact_inc_recurse.
    apply (Nat.le_trans (Pos.to_nat p) (1 + Pos.to_nat p)).
    apply le_S, le_refl.
    apply le_n_S.
    rewrite <- (Nat.mul_1_l (Pos.to_nat p)) at 1.
    apply Nat.mul_le_mono_nonneg_r.
    apply le_0_n. apply le_S, le_refl.
Qed.

End SinSeries.

Definition rational_sin_small (a:Q) (p: -1 <= a <= 1) : CR :=
  (inject_Q_CR a + AltSeries _ (sinStream a) (xH,a) _
                             (sinStream_alt p) (sinStream_zl p))%CR.

Lemma rational_sin_small_correct : forall (a:Q) (Ha : -1 <= a <= 1),
    (@rational_sin_small a Ha == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
  intros a Ha.
  unfold rational_sin_small.
  simpl.
  generalize (fun_series_conv_imp_conv (inj_Q IR a) (inj_Q IR a)
   (leEq_reflexive IR (inj_Q IR a)) sin_ps
     (sin_conv (inj_Q IR a) (inj_Q IR a) (leEq_reflexive IR (inj_Q IR a))
       (compact_single_iprop realline (inj_Q IR a) I)) (inj_Q IR a)
         (compact_single_prop (inj_Q IR a))
           (fun_series_inc_IR realline sin_ps sin_conv (inj_Q IR a) I)).
  intros H.
  (* Replace AltSeries by IRasCR (series_sum ...) *)
  rewrite <- (IR_inj_Q_as_CR a).
  rewrite
       (AltSeries_correct
          _ _ _ _ (sinStream_alt Ha) (sinStream_zl Ha)
          _ (AltSeries_convergent_0 _ _ _ _ (inj_Q IR a)
                                    (sinStream_alt Ha) (sinStream_zl Ha))).
  apply IRasCR_wd.
 - (* Prove the 2 series are equal in IR.
    We need to sum twice as many terms in sin_seq, to get rid of
    the zeros at even indexes. *)
   unfold series_sum.
   apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
  (* Prove that the partial sums until n are equal. *)
 intros n.
 induction n.
  apply eq_reflexive.
 replace (2*(S n))%nat with (S (S (2*n)))%nat by lia.
 set (n':=(2*n)%nat) in *.
 simpl in *.
 rstepr (seq_part_sum (fun n0 : nat =>
   (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (inj_Q IR a[-][0])) n'[+](
       (sin_seq n'[/]nring (R:=IR) (fact n')[//]nring_fac_ap_zero IR n')[*]
         nexp IR n' (inj_Q IR a[-][0])[+] (sin_seq (S n')[/]nring (R:=IR) (fact n' + n' * fact n')[//]
           nring_fac_ap_zero IR (S n'))[*] (nexp IR n' (inj_Q IR a[-][0])[*](inj_Q IR a[-][0])))).
 apply bin_op_wd_unfolded.
 assumption.
 rewrite <- cm_lft_unit.
 unfold sin_seq.
 apply bin_op_wd_unfolded.
   + destruct (even_or_odd_plus n') as [m [Hm|Hm]]; simpl.
     rational.
     elim (not_even_and_odd n').
     apply (even_mult_l 2 n).
     repeat constructor.
     rewrite Hm.
     constructor.
     replace (m + m)%nat with (2*m)%nat by lia.
     apply (even_mult_l 2 m).
     repeat constructor.
   + destruct (even_or_odd_plus (S n')) as [m [Hm|Hm]]; simpl.
  elim (not_even_and_odd (S n')).
   rewrite Hm.
   replace (m + m)%nat with (2*m)%nat by lia.
   apply (even_mult_l 2 m).
   repeat constructor.
  constructor.
  apply (even_mult_l 2 n).
  repeat constructor.
 inversion Hm.
 unfold n' in H1.
 replace m with n by lia.
 clear Hm H1.
 (* Unfold sinStream *)
 transitivity (inj_Q IR ((1#Pos.of_nat (fact (1+2*n))) * ((-1)^n*a^(1+2*n))%Q)).
 clear IHn H. destruct n. simpl.
 apply inj_Q_wd. rewrite Qmult_1_l, Qmult_1_l. reflexivity.
 apply inj_Q_wd. rewrite Str_pth_sinStream.
 rewrite Nat2Pos.id. 2: discriminate.
 replace (Z.pos (Pos.of_nat (S n))) with (Z.of_nat (S n)).
 reflexivity.
 simpl. destruct n. reflexivity.
 rewrite <- Pos.succ_of_nat. reflexivity. discriminate.
 (* Get rid of (-1)^n *)
 transitivity (inj_Q IR ((-(1))^n) [*] (inj_Q IR (a ^ (1 + 2 * n)) [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n))))).
 rewrite <- inj_Q_mult, <- inj_Q_mult.
 apply inj_Q_wd. rewrite Qmult_comm. rewrite Qmult_assoc. reflexivity.
 change (inj_Q IR ((- (1)) ^ n) [*] (inj_Q IR (a ^ (1 + 2 * n))
  [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n))))
               [=]
   (nexp IR n [--][1][/]nring (R:=IR) (fact (S n'))[//]nring_fac_ap_zero IR (S n'))[*]
     (nexp IR (S n') (inj_Q IR a[-][0]))).
 rstepr ((nexp IR n [--][1][*](nexp IR (S n') (inj_Q IR a[-][0])[/]nring (R:=IR) (fact (S n'))[//]
   nring_fac_ap_zero IR (S n')))).
 apply mult_wd.
  stepr ((inj_Q IR (-(1)))[^]n).
   apply inj_Q_power.
  apply nexp_wd.
  stepr ([--](inj_Q IR 1)).
   apply inj_Q_inv.
  apply un_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 stepr (inj_Q IR ((1/P_of_succ_nat (pred (fact (1+2*n))))*a^(1+2*n)%nat)).
 rewrite <- inj_Q_mult.
  apply inj_Q_wd.
  rewrite Qmult_comm.
  apply Qmult_comp.
  replace (1 + 2 * Z.of_nat n)%Z with (Z.of_nat (1 + 2 * n)).
  reflexivity. rewrite <- (Nat2Z.inj_mul 2), <- (Nat2Z.inj_add 1).
  reflexivity. pose proof (fact_neq_0 (1+2*n)).
  destruct (fact (1+2*n)). exfalso; apply H0; reflexivity.
  simpl. destruct n0. reflexivity.
  rewrite <- Pos2SuccNat.id_succ, Nat2Pos.id.
  reflexivity. discriminate.
  (* Finish equality *)
 rstepr ((nring 1[/]nring (R:=IR) (fact (S n'))[//]
   nring_fac_ap_zero IR (S n'))[*](nexp IR (S n') (inj_Q IR a[-][0]))).
 change (1+2*n)%nat with (S n').
 stepr ((inj_Q IR (1 / Zpos (P_of_succ_nat (pred (fact (S n')))))[*](inj_Q IR (a^S n')))).
  apply inj_Q_mult.
 apply mult_wd.
  rewrite <- POS_anti_convert.
  assert (X:inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n'))))))[#][0]).
   stepr (inj_Q IR [0]).
    assert (@cs_ap Q_as_CSetoid (inject_Z (Z_of_nat (S (pred (fact (S n')))))) 0).
     discriminate.
    destruct (ap_imp_less _ _ _ X).
     apply less_imp_ap.
     apply inj_Q_less.
     assumption.
    apply Greater_imp_ap.
    apply inj_Q_less.
    assumption.
   apply (inj_Q_nring IR 0).
  stepr ((inj_Q IR 1)[/](inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n')))))))[//]X).
   apply inj_Q_div.
  apply div_wd.
   apply (inj_Q_nring IR 1).
  stepl (inj_Q IR (nring (fact (S n')))).
   apply inj_Q_nring.
  assert (Y:=lt_O_fact (S n')).
  apply inj_Q_wd.
  stepr ((fact (S n')):Q).
   clear - n'.
   induction (fact (S n')).
    simpl; reflexivity.
   rewrite inj_S.
   unfold Z.succ.
   simpl in *.
   rewrite -> IHn0.
   rewrite -> injz_plus.
   reflexivity.
  destruct (fact (S n')).
   exfalso; auto with *.
  simpl; reflexivity.
 stepr ((inj_Q IR a)[^](S n')).
  apply inj_Q_power.
 change (inj_Q IR a[^]S n'[=](inj_Q IR a[-][0])[^]S n').
 apply nexp_wd.
 rational.
- intro p.
  pose proof (Pos2Nat.is_pos p). destruct (Pos.to_nat p) eqn:des.
  exfalso; inversion H0.
  rewrite <- des. rewrite Pos2Nat.id. reflexivity.
Qed.

(** Sine's range can then be extended to [[-3^n,3^n]] by [n] applications
of the identity [sin(x) = 3*sin(x/3) - 4*(sin(x/3))^3]. *)
Section Sin_Poly.

Definition sin_poly_fun (x:Q) :Q := x*(3 - 4*x*x).

Global Instance: Proper ((=) ==> (=)) sin_poly_fun.
Proof. unfold sin_poly_fun. solve_proper. Qed.

Lemma sin_poly_fun_correct : forall (q:Q),
 inj_Q IR (sin_poly_fun q)[=]Three[*]inj_Q IR q[-]Four[*](inj_Q IR q[^]3).
Proof.
 intros q.
 unfold sin_poly_fun.
 stepr (inj_Q IR (3*q-4*q^3)).
  apply inj_Q_wd.
  simpl; ring.
  rewrite inj_Q_minus.
 apply cg_minus_wd.
  stepr (inj_Q IR Three[*]inj_Q IR q).
   apply inj_Q_mult.
  apply mult_wdl.
  apply (inj_Q_nring IR 3).
 stepr (inj_Q IR Four[*]inj_Q IR (q^3)).
  apply inj_Q_mult.
 apply mult_wd.
  apply (inj_Q_nring IR 4).
 apply (inj_Q_power IR q 3).
Qed.

Definition sin_poly_modulus (e:Qpos) := Qpos2QposInf ((1#9)*e).

Lemma DthreeXMinusFourX3 : Derivative (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q)))
                   (inj_Q_less _ (-1) 1 eq_refl)
                   ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3)
 ((Three:IR){**}[-C-]([1]:IR){-}(Four:IR){**}((nring 3){**}([-C-][1]{*}FId{^}2))).
Proof.
 apply Derivative_minus.
  apply Derivative_scal.
  apply Derivative_id.
 apply Derivative_scal.
 apply Derivative_nth.
 apply Derivative_id.
Qed.

Lemma sin_poly_prf : is_UniformlyContinuousFunction (fun x => sin_poly_fun (QboundAbs (1#1) x)) sin_poly_modulus.
Proof.
  apply (fun a => is_UniformlyContinuousD_Q
                 (Some (-(1))%Q) (Some (1:Q)) eq_refl _ _ DthreeXMinusFourX3 sin_poly_fun a (9#1)).
  simpl; intros q _ _.
  apply sin_poly_fun_correct.
 simpl; intros x' _ [Hx0 Hx1].
 set (x:=(inj_Q IR x')) in *.
 stepr (Nine:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 9))].
 stepl (ABSIR (Three[-]Twelve[*]x[*]x)); [| now (apply AbsIR_wd; rational)].
 apply AbsSmall_imp_AbsIR.
 split.
  apply shift_zero_leEq_minus'.
  rstepr (Twelve[*]((nring 1)[-]x)[*](x[-][--](nring 1))).
  repeat apply mult_resp_nonneg.
    apply (nring_nonneg IR 12).
   apply shift_zero_leEq_minus.
   stepr (inj_Q IR (nring 1)); [| now apply inj_Q_nring].
   assumption.
  apply shift_zero_leEq_minus.
  stepl (inj_Q IR (-(1))).
   assumption.
  stepr ([--](inj_Q IR 1)).
   apply inj_Q_inv.
  apply un_op_wd_unfolded.
  apply (inj_Q_nring IR 1).
 rstepr (Nine[-][0]:IR).
 apply minus_resp_leEq_both.
  apply nring_leEq.
  lia.
 rstepr (Twelve[*]x[^]2).
 apply mult_resp_nonneg.
  apply (nring_leEq  IR 0 12).
  lia.
 apply sqr_nonneg.
Qed.

Definition sin_poly_uc : Q_as_MetricSpace --> Q_as_MetricSpace :=
Build_UniformlyContinuousFunction sin_poly_prf.

Definition sin_poly : CR --> CR
  := uc_compose compress (Cmap QPrelengthSpace sin_poly_uc).

Lemma sin_poly_correct : forall x,
    AbsSmall (inj_Q IR (1)) x
    -> (IRasCR (Three[*]x[-]Four[*]x[^]3)==sin_poly (IRasCR x))%CR.
Proof.
 intros x Hx.
 assert (Y:Continuous (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3)).
  eapply Derivative_imp_Continuous.
  apply DthreeXMinusFourX3.
  apply: (ContinuousCorrect
            (I:=(clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))))
            (inj_Q_less _ (-1) 1 eq_refl) Y);
   [|repeat constructor|].
  intros q Hq Hq0.
  transitivity (IRasCR (inj_Q IR (sin_poly_fun q)));[|apply IRasCR_wd; apply sin_poly_fun_correct].
  simpl.
  change (' q)%CR with (Cunit_fun _ q).
  rewrite -> compress_fun_correct.
  rewrite -> Cmap_fun_correct.
  rewrite -> MonadLaw3.
  rewrite -> IR_inj_Q_as_CR.
  rewrite -> CReq_Qeq.
  simpl.
  unfold sin_poly_fun.
  setoid_replace (Qmax (- (1)) (Qmin 1 q)) with q.
   reflexivity.
  setoid_replace (Qmin 1 q) with q.
   rewrite <- Qle_max_r.
   apply leEq_inj_Q with IR.
   destruct Hq0; assumption.
  rewrite <- Qle_min_r.
  apply leEq_inj_Q with IR.
  destruct Hq0; assumption.
 destruct Hx; split;[stepl [--](inj_Q IR (1:Q)); [| now apply eq_symmetric; apply inj_Q_inv] |];assumption.
Qed.

Lemma Sin_triple_angle : forall x, (Sin(Three[*]x)[=]Three[*]Sin x[-]Four[*]Sin x[^]3).
Proof.
 intros x.
 assert (H:Three[*]x[=]x[+]x[+]x) by rational.
 csetoid_rewrite H.
 csetoid_rewrite (Sin_plus (x[+]x) x).
 csetoid_rewrite (Sin_plus x x).
 csetoid_rewrite (Cos_plus x x).
 set (sx:=Sin x).
 set (cx:=Cos x).
 rstepl ((cx[^]2)[*](Three[*]sx)[-]sx[^]3).
 unfold cg_minus.
 csetoid_replace (cx[^]2) ([1][-]sx[^]2).
  rational.
 apply cg_inv_unique_2.
 rstepl ((cx[^]2[+]sx[^]2)[-][1]).
 apply x_minus_x.
 apply FFT.
Qed.

Lemma shrink_by_three : forall n a,
    -(3^(S n))%Z <= a <= (3^(S n))%Z -> -(3^n)%Z <= a/3 <= (3^n)%Z.
Proof.
  intros n a H0.
  apply AbsSmall_Qabs. apply AbsSmall_Qabs in H0.
  apply Qmult_lt_0_le_reg_r with (Qabs 3).
  reflexivity. rewrite <- Qabs_Qmult.
  unfold Qdiv. rewrite <- Qmult_assoc.
  setoid_replace (/ 3 * 3) with 1 by reflexivity.
  rewrite Qmult_1_r.
  apply (Qle_trans _ _ _ H0). clear H0.
  change (Qabs 3) with (inject_Z 3).
  rewrite <- (inject_Z_mult (3^n) 3).
  rewrite <- Zle_Qle.
  change (S n) with (1+n)%nat.
  rewrite (Nat2Z.inj_add 1 n).
  rewrite ZBinary.Z.pow_add_r, Z.mul_comm.
  apply Z.le_refl.
  discriminate.
  apply (Nat2Z.inj_le 0), le_0_n.
Qed.

Fixpoint rational_sin_bounded (n:nat) (a:Q) : -(3^n)%Z <= a <= (3^n)%Z -> CR :=
match n return -(3^n)%Z <= a <= (3^n)%Z -> CR with
| O => @rational_sin_small a
| S n' => fun H => sin_poly (rational_sin_bounded n' (shrink_by_three n' H))
end.

Lemma rational_sin_bounded_correct_aux a :
  (sin_poly (IRasCR (Sin (inj_Q IR (a / 3)))) == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 rewrite <- sin_poly_correct; [|apply AbsIR_imp_AbsSmall;
   (stepr (nring 1:IR); [| now apply eq_symmetric; apply (inj_Q_nring IR 1)]); rstepr ([1]:IR);
     apply AbsIR_Sin_leEq_One].
 apply IRasCR_wd.
 stepl (Sin (inj_Q IR (a/3*3))).
  apply Sin_wd.
  apply inj_Q_wd.
  simpl; field; discriminate.
 generalize (a/3).
 intros b; clear -b.
 stepr (Sin (Three[*](inj_Q IR b))).
  apply Sin_wd.
  stepr ((inj_Q IR b)[*](inj_Q IR (3:Q))).
   apply inj_Q_mult.
  csetoid_replace (inj_Q IR (3:Q)) (Three:IR).
   rational.
  apply (inj_Q_nring IR 3).
 apply Sin_triple_angle.
Qed.

Lemma rational_sin_bounded_correct :
  forall (n:nat) (a:Q) (Ha : -(3^n #1) <= a <= (3^n #1)),
    (@rational_sin_bounded n a Ha == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 induction n.
  apply rational_sin_small_correct.
 intros a Ha.
 unfold rational_sin_bounded; fold rational_sin_bounded.
 rewrite -> IHn.
 apply rational_sin_bounded_correct_aux.
Qed.
End Sin_Poly.

Definition sin_bound (q:Q) : nat := Z.abs_nat (1 + Qdlog 3 (Qabs q)).

Lemma sin_bound_correct : forall q, -(3 ^ sin_bound q #1) ≤ q ≤ (3 ^ sin_bound q #1).
Proof.
  intro q.
  apply AbsSmall_Qabs.
  unfold sin_bound.
  destruct (Qlt_le_dec (Qabs q) 1).
  - apply (Qle_trans _ 1).
    apply Qlt_le_weak, q0.
    rewrite Qdlog2_le1; simpl; try easy.
    apply Qlt_le_weak, q0.
  - assert (2 ≤ 3%Z) as H by discriminate.
    pose proof (Qdlog_spec 3 (Qabs q) H q0) as [_ H0]. clear H.
    unfold additional_operations.pow, stdlib_rationals.Q_pow in H0.
    assert (0 <= 1 + Qdlog 3 (Qabs q))%Z.
    { apply semirings.nonneg_plus_compat; [easy | now apply Qdlog_bounded_nonneg]. }
    rewrite inj_Zabs_nat, Z.abs_eq.
    apply Qlt_le_weak.
    rewrite <- Zpower_Qpower in H0. apply H0.
    exact H. exact H.
Qed.

(** Therefore sin works on all real numbers. *)
Definition rational_sin (a:Q) : CR :=
  rational_sin_bounded (sin_bound a) (sin_bound_correct a).

Lemma rational_sin_correct : forall (a:Q),
    (rational_sin a == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 intros; apply rational_sin_bounded_correct.
Qed.

#[global]
Instance: Proper ((=) ==> (=)) rational_sin.
Proof.
 intros ? ? E.
 rewrite ?rational_sin_correct.
 now apply IRasCR_wd, Sin_wd, inj_Q_wd.
Qed.

Lemma rational_sin_poly (a : Q) :
  sin_poly (rational_sin (a / 3)) = rational_sin a.
Proof.
 rewrite ?rational_sin_correct.
 apply rational_sin_bounded_correct_aux.
Qed.

Lemma rational_sin_correct_aux (a : Q) :
  (- IRasCR (Sin (inj_Q IR (- a)%Q)) == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 rewrite <- IR_opp_as_CR.
 apply IRasCR_wd.
 csetoid_rewrite_rev (Sin_inv (inj_Q IR (-a))).
 apply Sin_wd.
 csetoid_rewrite_rev (inj_Q_inv IR (-a)).
 apply inj_Q_wd.
 simpl.
 ring.
Qed.

Lemma rational_sin_opp (a : Q) :
  (-rational_sin (-a) = rational_sin a)%CR.
Proof.
  rewrite ?rational_sin_correct.
  now apply rational_sin_correct_aux.
Qed.

(** Sine is uniformly continuous everywhere. *)
Definition sin_uc_prf : is_UniformlyContinuousFunction rational_sin Qpos2QposInf.
Proof.
 apply (is_UniformlyContinuousFunction_wd) with (fun x => rational_sin x) (Qscale_modulus (1#1)).
   reflexivity.
  intros x.
  simpl.
  autorewrite with QposElim.
  change (/1) with 1.
  replace RHS with (proj1_sig x) by simpl; ring.
  apply Qle_refl.
 apply (is_UniformlyContinuousD None None I Sine Cosine (Derivative_Sin I) rational_sin).
  intros q [] _.
  apply rational_sin_correct.
 intros x [] _.
 stepr ([1]:IR).
  apply: AbsIR_Cos_leEq_One.
 rstepl (nring 1:IR).
 apply eq_symmetric.
 apply (inj_Q_nring IR 1).
Qed.

Definition sin_uc : Q_as_MetricSpace --> CR :=
Build_UniformlyContinuousFunction sin_uc_prf.

Definition sin_slow : CR --> CR := Cbind QPrelengthSpace sin_uc.

Lemma sin_slow_correct : forall x,
 (IRasCR (Sin x) == sin_slow (IRasCR x))%CR.
Proof.
 intros x.
 apply: (ContinuousCorrect (I:proper realline)); [apply Continuous_Sin | | constructor].
 intros q [] _.
 transitivity (rational_sin q);[|apply rational_sin_correct].
 unfold sin_slow.
 rewrite -> (Cbind_fun_correct QPrelengthSpace sin_uc).
 apply: BindLaw1.
Qed.

Definition sin (x:CR) := sin_slow (x - (compress (scale (2*Qceiling (approximate (x*(CRinv_pos (6#1) (scale 2 CRpi))) (Qpos2QposInf (1#2)) -(1#2))) CRpi)))%CR.

Lemma sin_correct : forall x,
  (IRasCR (Sin x) == sin (IRasCR x))%CR.
Proof.
 intros x.
 unfold sin.
 generalize (Qceiling (approximate (IRasCR x * CRinv_pos (6 # 1) (scale 2 CRpi))
   (Qpos2QposInf (1 # 2)) - (1 # 2)))%CR.
 intros z.
 rewrite -> compress_correct.
 rewrite <- CRpi_correct, <- CRmult_scale, <- IR_inj_Q_as_CR, <- IR_mult_as_CR,
   <- IR_minus_as_CR, <- sin_slow_correct.
 apply IRasCR_wd.
 rewrite -> inj_Q_mult.
 change (2:Q) with (@nring Q_as_CRing 2).
 rewrite -> inj_Q_nring.
 rstepr (Sin (x[+]([--](inj_Q IR z))[*](Two[*]Pi))).
 setoid_replace (inj_Q IR z) with (zring z:IR).
  rewrite <- zring_inv.
  symmetry; apply Sin_periodic_Z.
 rewrite <- inj_Q_zring.
 apply inj_Q_wd.
 symmetry; apply zring_Q.
Qed.

(* begin hide *)
#[global]
Hint Rewrite sin_correct : IRtoCR.
(* end hide *)


(* Cases with let-in in constructors types *)

Inductive t : Set :=
    k : let x := t in x -> x.

Print t_rect.

(* Do not contract nested patterns with dependent return type *)
(* see bug #1699 *)

Require Import Arith.

Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y :=
  match eq_nat_dec x y return P y with
  | left eqprf =>
    match eqprf in (_ = z) return (P z) with
    | refl_equal => def
    end
  | _ => prf
 end.

Print proj.

(* Use notations even below aliases *)

Require Import List.

Fixpoint foo (A:Type) (l:list A) : option A :=
  match l with
  | nil => None
  | x0 :: nil => Some x0
  | x0 :: (x1 :: xs) as l0 => foo A l0
  end.

Print foo.

(* Do not duplicate the matched term *)

Axiom A : nat -> bool.

Definition foo' :=
  match A 0 with
    | true => true
    | x => x
  end.

Print foo'.


(** * Coinductive nats (conats) algebraic CPO. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
  Basics
  Equivalence
  Lia
  Morphisms
  Equality
  List
  Nat
.
Local Open Scope program_scope.
Local Open Scope equiv_scope.
Import ListNotations.

From Coq Require Import
  Reals
  Raxioms
  Rpower
  FunctionalExtensionality
  ClassicalChoice
  IndefiniteDescription
.

From algco Require Import aCPO axioms cpo misc order tactics.

Local Open Scope order_scope.

Create HintDb conat.

CoInductive conat : Type :=
| cozero : conat
| cosucc : conat -> conat.

CoFixpoint omega : conat := cosucc omega.

Definition unf (n : conat) :=
  match n with
  | cozero => cozero
  | cosucc m => cosucc m
  end.

Lemma unf_eq (n : conat) : n = unf n.
Proof. destruct n; auto. Qed.

CoInductive conat_le : conat -> conat -> Prop :=
| conat_le_zero : forall n, conat_le cozero n
| conat_le_succ : forall n m,
    conat_le n m ->
    conat_le (cosucc n) (cosucc m).
#[global] Hint Constructors conat_le : conat.

#[global]
  Instance Reflexive_conat_le : Reflexive conat_le.
Proof. cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Transitive_conat_le : Transitive conat_le.
Proof.
  cofix CH; intros x y z Hxy Hyz; inv Hxy.
  - constructor.
  - inv Hyz; constructor; eauto.
Qed.

#[global]
  Instance PreOrder_conat_le : PreOrder conat_le.
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_conat : OType conat :=
  { leq := conat_le }.

#[global]
  Program
  Instance PType_conat : PType conat :=
  { bot := cozero }.
Next Obligation. constructor. Qed.

Lemma cozero_le (n : conat) :
  cozero ⊑ n.
Proof. constructor. Qed.
#[global] Hint Resolve cozero_le : conat.

Lemma le_omega (n : conat) :
  n ⊑ omega.
Proof.
  revert n; cofix CH; intro n.
  destruct n.
  { constructor. }
  rewrite (@unf_eq omega); constructor; apply CH.
Qed.
#[global] Hint Resolve le_omega : conat.

Fixpoint nat_inj (n : nat) : conat :=
  match n with
  | O => cozero
  | S n' => cosucc (nat_inj n')
  end.

Definition conat' : Type := nat + unit.

Inductive finite : nat -> conat -> Prop :=
| finite_zero : finite O cozero
| finite_succ : forall n m,
    finite n m ->
    finite (S n) (cosucc m).

Definition conat_to_conat' (n : conat) : conat' :=
  match classicT (exists i, finite i n) with
  | left pf => inl (proj1_sig (constructive_indefinite_description _ pf))
  | right _ => inr tt
  end.

Definition conat'_to_conat (n : conat') : conat :=
  match n with
  | inl n' => nat_inj n'
  | inr _ => omega
  end.

CoInductive conat_eq : conat -> conat -> Prop :=
| conat_eq_zero : conat_eq cozero cozero
| conat_eq_succ : forall n m,
    conat_eq n m ->
    conat_eq (cosucc n) (cosucc m).

Lemma finite_nat_inv i j n :
  finite i n ->
  finite j n ->
  i = j.
Proof.
  revert j n; induction i; intros j n Hi Hj.
  - inv Hi; inv Hj; auto.
  - inv Hi; inv Hj; erewrite IHi; eauto.
Qed.

Lemma conat_eq_finite i n m :
  conat_eq n m ->
  finite i n ->
  finite i m.
Proof.
  revert n m; induction i;
    intros n m Hnm Hn; inv Hn; inv Hnm; constructor; eauto.
Qed.

#[global]
 Instance Symmetric_conat_eq : Symmetric conat_eq.
Proof. cofix CH; intros n m []; constructor; auto. Qed.

Lemma conat_eq_leq n m :
  conat_eq n m ->
  n ⊑ m.
Proof.
  revert n m; cofix CH; intros n m Hnm.
  inv Hnm; constructor.
  apply CH; auto.
Qed.

Lemma conat_eq_equiv n m :
  conat_eq n m <-> n === m.
Proof.
  split.
  - intro Hnm; split.
    + apply conat_eq_leq; auto.
    + apply conat_eq_leq; symmetry; auto.
  - revert n m; cofix CH; intros n m [Hnm Hmn].
    inv Hnm; inv Hmn; constructor.
    apply CH; split; auto.
Qed.

Lemma conat_eq_conat_to_conat' n m :
  conat_eq n m ->
  conat_to_conat' n = conat_to_conat' m.
Proof.
  intros Hnm.
  unfold conat_to_conat'.
  destr.
  - destr.
    + f_equal.
      compute.
      destr.
      destr.
      destruct e as [i Hi].
      destruct e0 as [j Hj].
      eapply conat_eq_finite in Hnm; eauto.
      eapply finite_nat_inv; eauto.
    + exfalso; apply n0.
      destruct e as [i Hi].
      exists i; eapply conat_eq_finite; eauto.
  - destr; auto.
    exfalso; apply n0.
    destruct e as [i Hi].
    exists i; eapply conat_eq_finite; eauto.
    symmetry; auto.
Qed.

(* Extensionality axiom for conats. *)
(* Axiom conat_ext : forall (n m : conat), conat_eq n m -> n = m. *)

Axiom conat_eq_axiom : forall n, conat'_to_conat (conat_to_conat' n) = n.

(** The axiom implies conat extensionality... *)
Lemma conat_ext :
  forall n m, conat_eq n m -> n = m.
Proof.
  intros n m Hnm.
  rewrite <- conat_eq_axiom.
  rewrite <- (@conat_eq_axiom m).
  erewrite conat_eq_conat_to_conat'; auto.
Qed.

Lemma conat_eq_refl (n : conat) :
  conat_eq n n.
Proof. revert n; cofix CH; intros []; constructor; eauto. Qed.

#[global]
  Instance Reflexive_conat_eq : Reflexive conat_eq.
Proof. intro; apply conat_eq_refl. Qed.

Lemma conat_eq_equ (a b : conat) :
  conat_eq a b -> a === b.
Proof.
  intro Hab; split; revert Hab; revert a b; cofix CH;
    intros a b Hab; inv Hab; constructor; apply CH; auto.
Qed.

Lemma equ_conat_eq (a b : conat) :
  a === b -> conat_eq a b.
Proof.
  revert a b; cofix CH; intros a b [Hab Hba].
  inv Hab; inv Hba; constructor; apply CH; split; auto.
Qed.

#[global]
  Instance ExtType_conat : ExtType conat.
Proof. constructor; intros a b Hab; apply conat_ext, equ_conat_eq; auto. Qed.

Fixpoint conat_prefix (i : nat) (n : conat) : nat :=
  match i with
  | O => O
  | S i' => match n with
           | cozero => O
           | cosucc n' => S (conat_prefix i' n')
           end
  end.

Fixpoint coconat_prefix (i : nat) (n : conat) : conat :=
  match i with
  | O => cozero
  | S i' => match n with
           | cozero => cozero
           | cosucc n' => cosucc (coconat_prefix i' n')
           end
  end.

#[global]
  Instance Proper_conat_le : Proper (equ ==> equ ==> flip impl) conat_le.
Proof.
  intros a b [Hab Hba] c d [Hcd Hdc] Hle.
  etransitivity; eauto; etransitivity; eauto.
Qed.

#[global]
  Instance Proper_conat_le'
  : Proper (conat_eq ==> conat_eq ==> flip impl) conat_le.
Proof.
  intros a b Hab c d Hcd Hle.
  apply conat_eq_equ in Hab; destruct Hab.
  apply conat_eq_equ in Hcd; destruct Hcd.
  etransitivity; eauto; etransitivity; eauto.
Qed.

Lemma continuous_cosucc : continuous cosucc.
Proof.
  intros ch Hch s Hs; split.
  - intro i; constructor; apply Hs.
  - intros x Hx.
    destruct x; try solve [specialize (Hx (S O)); inv Hx].
    pose proof Hx as Hx'.
    specialize (Hx' (S O)).
    inv Hx'.
    constructor; apply Hs.
    intro i; specialize (Hx i); inv Hx; auto.
Qed.
#[global] Hint Resolve continuous_cosucc : conat.

Lemma O_le (n : nat) :
  O ⊑ n.
Proof. simpl; lia. Qed.
#[global] Hint Resolve O_le : conat.

Lemma le_succ (n m : nat) :
  n ⊑ m -> S n ⊑ S m.
Proof. simpl; lia. Qed.

Lemma conat_prefix_monotone (i : nat) :
  monotone (conat_prefix i).
Proof.
  induction i; intros a b Hab; simpl; try constructor.
  destruct a; inv Hab; try lia.
  apply le_succ; auto.
Qed.

Lemma conat_prefix_monotone' (n : conat) :
  monotone (fun i => conat_prefix i n).
Proof.
  intro i; revert n; induction i; intros n j Hij; simpl.
  - lia.
  - destruct n.
    + lia.
    + destruct j; simpl.
      * inv Hij.
      * apply le_succ; apply IHi; inv Hij.
        { reflexivity. }
        simpl; lia.
Qed.

Lemma chain_conat_prefix (n : conat) :
  chain (fun i : nat => conat_prefix i n).
Proof.
  apply monotone_chain.
  - apply conat_prefix_monotone'.
  - intro i; simpl; lia.
Qed.

Lemma supremum_cozero (ch : nat -> conat) :
  supremum cozero ch ->
  ch = const cozero.
Proof.
  intros [Hub Hlub]; ext i; unfold const.
  specialize (Hub i); inv Hub; reflexivity.
Qed.

Definition not_cozero (n : conat) : Prop :=
  match n with
  | cozero => False
  | _ => True
  end.

Definition not_O (n : nat) : Prop :=
  match n with
  | O => False
  | _ => True
  end.

Lemma not_cozero_dec (n : conat) : { not_cozero n } + { ~ not_cozero n }.
Proof.
  destruct n.
  - right; intro HC; inv HC.
  - left; constructor.
Qed.

Lemma not_O_dec (n : nat) : { not_O n } + { ~ not_O n }.
Proof.
  destruct n.
  - right; intro HC; inv HC.
  - left; constructor.
Qed.

Definition copred (n : conat) : conat :=
  match n with
  | cozero => cozero
  | cosucc n' => n'
  end.

(** The supremum of a chain of conats. Uses strong LPO. *)
CoFixpoint conat_sup (ch : nat -> conat) : conat :=
  match LPO_option (fun i => not_cozero_dec (ch i)) with
  | Some i => match ch i with
             | cozero => cozero
             | cosucc n => cosucc (conat_sup (copred ∘ ch))
             end
  | None => cozero
  end.

Lemma chain_copred (ch : nat -> conat) :
  chain ch ->
  chain (copred ∘ ch).
Proof.
  intros Hch i; unfold compose; simpl.
  destruct (ch i) eqn:Hchi; simpl; try constructor.
  - specialize (Hch i); rewrite Hchi in Hch; inv Hch; simpl; auto.
Qed.

#[global]
  Instance monotone_copred : Proper (leq ==> leq) copred.
Proof.
  intro a; revert a; cofix CH; intros x b Hab; inv Hab; auto; constructor.
Qed.

#[global]
  Instance monotone_pred : Proper (leq ==> leq) pred.
Proof.
  intro a; induction a; intros b Hab; inv Hab; simpl; auto; lia.
Qed.

Lemma directed_copred (ch : nat -> conat) :
  directed ch ->
  directed (copred ∘ ch).
Proof.
  intros Hch i j; unfold compose; simpl.
  specialize (Hch i j); destruct Hch as [k [H0 H1]].
  exists k; split; apply monotone_copred; auto.
Qed.

Lemma directed_pred (ch : nat -> nat) :
  directed ch ->
  directed (pred ∘ ch).
Proof.
  intros Hch i j; unfold compose; simpl.
  specialize (Hch i j); destruct Hch as [k [H0 H1]].
  exists k; split; apply monotone_pred; auto.
Qed.

Lemma chain_pred (ch : nat -> nat) :
  chain ch ->
  chain (pred ∘ ch).
Proof.
  intros Hch i; unfold compose; simpl.
  destruct (ch i) eqn:Hchi; simpl; try lia.
  - specialize (Hch i); rewrite Hchi in Hch; inv Hch; simpl; lia.
Qed.

Lemma conat_sup_ub (ch : nat -> conat) :
  directed ch ->
  upper_bound (conat_sup ch) ch.
Proof.
  revert ch.
  cofix CH; intros ch Hch i.
  simpl.
  replace (conat_sup ch) with (unf (conat_sup ch)).
  2: { rewrite <- unf_eq; reflexivity. }
  simpl.
  destruct (LPO_option (fun n : nat => not_cozero_dec (ch n))) eqn:Ho.
  - apply LPO_option_some in Ho.
    destruct (ch n) eqn:Hchn.
    + inv Ho.
    + clear Ho.
      destruct (ch i) eqn:Hchi.
      * constructor.
      * constructor.
        replace c0 with ((copred ∘ ch) i).
        2: { unfold compose; rewrite Hchi; reflexivity. }
        apply CH, directed_copred; auto.
  - apply LPO_option_none with (n:=i) in Ho.
    destruct (ch i); try constructor; exfalso; apply Ho; constructor.
Qed.

Lemma upper_bound_copred_succ (n : conat) (ch : nat -> conat) :
  upper_bound (cosucc n) ch ->
  upper_bound n (copred ∘ ch).
Proof.
  intros Hub i; specialize (Hub i); unfold compose.
  destruct (ch i) eqn:Hchi.
  - constructor.
  - inv Hub; auto.
Qed.

Lemma conat_sup_const (l : conat) :
  conat_eq (conat_sup (fun _ : nat => l)) l.
Proof.
  revert l; cofix CH; intro l.
  rewrite unf_eq; simpl.
  destruct (LPO_option (fun _ : nat => not_cozero_dec l)) eqn:H.
  - apply LPO_option_some in H.
    destruct l; constructor; unfold compose; apply CH.
  - apply LPO_option_none with (n:=O) in H.
    destruct l; try constructor; exfalso; apply H; constructor.
Qed.

Lemma conat_sup_lub (ch : nat -> conat) (ub : conat) :
  directed ch ->
  upper_bound ub ch ->
  conat_sup ch ⊑ ub.
Proof.
  revert ch ub.
  cofix CH; intros ch ub Hch Hub.
  destruct ub.
  - replace ch with (fun _ : nat => cozero).
    + rewrite conat_sup_const; reflexivity.
    + ext i; specialize (Hub i); destruct (ch i); auto; inv Hub.
  - rewrite unf_eq; simpl.
    destruct (LPO_option (fun n : nat => not_cozero_dec (ch n))) eqn:Ho.
    2: { constructor. }
    destruct (ch n) eqn:Hchn.
    + constructor.
    + pose proof Hub as Hub'.
      specialize (Hub n); rewrite Hchn in Hub; inv Hub.
      constructor; apply CH; auto.
      * apply directed_copred; auto.
      * eapply upper_bound_copred_succ; eauto.
Qed.

Lemma conat_sup_supremum (ch : nat -> conat) :
  directed ch ->
  supremum (conat_sup ch) ch.
Proof.
  intro Hch; split.
  - apply conat_sup_ub; auto.
  - intros; apply conat_sup_lub; auto.
Qed.

#[global]
  Instance CPO_conat : CPO conat.
Proof.
  constructor; intros ch Hch.
  exists (conat_sup ch); apply conat_sup_supremum; auto.
Qed.
#[global] Hint Resolve CPO_conat : conat.

Lemma nat_inj_conat_prefix_coconat_prefix (n : conat) (i : nat) :
  nat_inj (conat_prefix i n) = coconat_prefix i n.
Proof.
  revert n; induction i; intro n; simpl; auto.
  destruct n; simpl; auto; rewrite IHi; auto.
Qed.

Lemma equ_nat (a b : nat) :
  a === b -> a = b.
Proof. unfold equiv, equ; simpl; lia. Qed.

Lemma supremum_pred_S (n : nat) (ch : nat -> nat) :
  supremum (S n) ch ->
  supremum n (pred ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; lia.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (S y) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor; lia.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub.
        apply le_succ; auto; lia. }
    apply Hlub in H; inv H; auto; simpl; lia.
Qed.

Lemma supremum_S' (n : nat) (ch : nat -> nat) :
  supremum (S n) ch ->
  exists i n', ch i = S n' /\ n' ⊑ n.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_O_dec (ch n))).
  - destruct e as [m H].
    specialize (Hub m).
    destruct (ch m) eqn:Hchm.
    + inv H.
    + exists m, n0; split; auto; simpl in *; lia.
  - assert (H: upper_bound O ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n0; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma supremum_cosucc' (n : conat) (ch : nat -> conat) :
  supremum (cosucc n) ch ->
  exists i n', ch i = cosucc n' /\ n' ⊑ n.
Proof.
  intros [Hub Hlub].
  destruct (strong_LPO (fun n => not_cozero_dec (ch n))).
  - destruct e as [m H].
    specialize (Hub m).
    inv Hub.
    + rewrite <- H1 in H; inv H.
    + exists m, n0; auto.
  - assert (H: upper_bound cozero ch).
    { intro i; specialize (Hub i); destruct (ch i) eqn:Hchi.
      + constructor.
      + exfalso; apply n0; exists i; rewrite Hchi; constructor. }
    apply Hlub in H; inv H.
Qed.

Lemma nat_compact (n : nat) (ch : nat -> nat) :
  directed ch ->
  supremum n ch ->
  exists i, ch i = n.
Proof.
  revert ch; induction n; intros ch Hch Hn.
  - exists O; apply equ_nat; split.
    + apply Hn.
    + simpl; lia.
  - pose proof Hn as Hn'.
    apply supremum_pred_S in Hn.
    apply IHn in Hn; clear IHn.
    2: { apply directed_pred; auto. }
    destruct Hn as [j Hj].
    unfold compose in Hj.
    unfold pred in Hj.
    destruct (ch j) eqn:Hchj; subst.
    + apply supremum_S' in Hn'.
      destruct Hn' as [i [n' [Hi Hn']]]; inv Hn'; exists i; auto.
    + destruct Hn' as [H0 H1]; specialize (H0 j).
      rewrite Hchj in H0; inv H0; exists j; auto.
Qed.

Lemma nat_eq_conat_eq (a b : conat) :
  (forall i, conat_prefix i a = conat_prefix i b) ->
  a = b.
Proof.
  intro H; apply conat_ext.
  revert a b H; cofix CH; intros a b H.
  destruct a.
  - destruct b.
    + constructor.
    + specialize (H (S O)); inv H.
  - destruct b.
    + specialize (H (S O)); inv H.
    + pose proof H as H'.
      specialize (H' (S O)); inv H'.
      constructor; apply CH; intro i; specialize (H (S i)); inv H; auto.
Qed.

Lemma nat_le_conat_le (a b : nat) :
  a ⊑ b ->
  nat_inj a ⊑ nat_inj b.
Proof.
  revert b; induction a; simpl; intros b Hab.
  - constructor.
  - destruct b; inv Hab; constructor; apply IHa; auto; simpl; lia.
Qed.

#[global]
  Instance monotone_nat_inj : Proper (leq ==> leq) nat_inj.
Proof. intros a b Hab; apply nat_le_conat_le; auto. Qed.

Lemma conat_le_nat_le (a b : nat) :
  nat_inj a ⊑ nat_inj b ->
  a ⊑ b.
Proof.
  revert b; induction a; simpl; intros b Hab.
  - lia.
  - destruct b; inv Hab; apply IHa in H1; simpl in *; lia.
Qed.

Lemma supremum_copred_succ (n : conat) (ch : nat -> conat) :
  supremum (cosucc n) ch ->
  supremum n (copred ∘ ch).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); unfold compose.
    inv Hub; simpl; auto; constructor.
  - unfold compose; intros y Hy.
    unfold upper_bound in Hy.
    simpl in Hy.
    assert (H: upper_bound (cosucc y) ch).
    { intro i.
      specialize (Hy i); simpl in Hy.
      destruct (ch i) eqn:Hchi.
      - constructor.
      - specialize (Hub i); simpl in Hub; rewrite Hchi in Hub; inv Hub.
        constructor; auto. }
    apply Hlub in H; inv H; auto.
Qed.

Lemma conat_prefix_continuous (n : nat) :
  continuous (conat_prefix n).
Proof.
  induction n; intros ch Hch x Hx; unfold compose; simpl.
  { apply supremum_const. }
  destruct x.
  - apply supremum_cozero in Hx.
    apply supremum_const'.
    apply equ_arrow; intro i; rewrite Hx; reflexivity.
  - assert (Hc: supremum x (copred ∘ ch)).
    { eapply supremum_copred_succ; eauto. }
    split.
    + intro i; destruct (ch i) eqn:Hchi; simpl.
      * lia.
      * destruct Hx as [Hub Hlub].
        specialize (Hub i).
        rewrite Hchi in Hub.
        inv Hub.
        apply le_succ.
        apply conat_prefix_monotone; auto.
    + intros ub Hub; destruct ub.
      * assert (H: forall i, ch i = cozero).
        { intro i; specialize (Hub i); simpl in Hub.
          destruct (ch i); auto; inv Hub. }
        assert (supremum cozero ch).
        { apply supremum_const'; apply equ_arrow; intro i.
          unfold const; rewrite H; reflexivity. }
        eapply supremum_unique in Hx; eauto.
        apply equ_conat_eq in Hx; inv Hx.
      * pose proof Hx as Hx'.
        apply supremum_cosucc' in Hx'.
        destruct Hx' as [i [l' [Hx' Hx'']]].
        pose proof Hub as Hub'.
        specialize (Hub' i).
        simpl in Hub'.
        rewrite Hx' in Hub'.
        clear Hx' i.
        apply le_succ.
        eapply IHn.
        2: { eauto. }
        { apply directed_copred; auto. }
        intro i; specialize (Hub i); simpl in Hub.
        unfold compose.
        destruct (ch i) eqn:Hchi; simpl.
        { destruct n; simpl; lia. }
        { lia. }
Qed.

Lemma coconat_prefix_le (n : conat) (i : nat) :
  coconat_prefix i n ⊑ n.
Proof.
  revert n; induction i; intro n; simpl; try constructor.
  destruct n; constructor; apply IHi.
Qed.

Lemma coconat_prefix_supremum (n : conat) :
  supremum n (fun i => coconat_prefix i n).
Proof.
  split.
  - intro i. apply coconat_prefix_le.
  - revert n; cofix CH; intros n ub Hub.
    destruct ub.
    + specialize (Hub (S O)).
      destruct n; inv Hub; constructor.
    + destruct n.
      * constructor.
      * pose proof Hub as Hub'.
        specialize (Hub' (S O)).
        inv Hub'.
        constructor; apply CH.
        intro i.
        specialize (Hub (S i)); simpl in Hub.
        inv Hub; auto.
Qed.

#[global]
  Instance Compact_nat : Compact nat.
Proof.
  constructor; intros a f Hf Ha.
  apply nat_compact in Ha; auto.
  destruct Ha as [i Ha]; subst; exists i; reflexivity.
Qed.

#[global]
  Instance Dense_conat : Dense conat nat :=
  { incl := nat_inj
  ; ideal := flip conat_prefix }.

#[global]
  Instance aCPO_conat : aCPO conat nat.
Proof.
  constructor.
  - intros a b; split.
    + apply nat_le_conat_le.
    + apply conat_le_nat_le.
  - apply chain_conat_prefix.
  - intros a b Hab i; apply conat_prefix_monotone; auto.
  - apply conat_prefix_continuous.
  - intro a; simpl; unfold compose, flip.
    replace (fun i => nat_inj (conat_prefix i a)) with (fun i => coconat_prefix i a).
    + apply coconat_prefix_supremum.
    + ext i; rewrite nat_inj_conat_prefix_coconat_prefix; reflexivity.
Qed.

Lemma neq_nat_inj_omega (n : conat) :
  (forall m, n <> nat_inj m) ->
  n = omega.
Proof.
  intro H.
  apply ext; split.
  { apply le_omega. }
  revert n H; cofix CH; intros n H.
  destruct n.
  { exfalso; specialize (H O); apply H; reflexivity. }
  rewrite unf_eq; simpl.
  constructor.
  apply CH.
  intros m HC.
  specialize (H (S m)).
  apply H; simpl.
  rewrite HC; reflexivity.
Qed.

Lemma conat_finite_or_omega (n : conat) :
  (exists m, n = nat_inj m) \/ n = omega.
Proof.
  destruct (classic (exists m : nat, n = nat_inj m)); auto.
  right; apply neq_nat_inj_omega.
  intros m HC; subst; apply H; exists m; reflexivity.
Qed.

Fixpoint nat_iter {A} (z : A) (f : A -> A) (n : nat) : A :=
  match n with
  | O => z
  | S n' => f (nat_iter z f n')
  end.

#[global]
  Instance monotone_nat_iter {A} `{OType A} (z : A) (f : A -> A)
  {Hz : forall n, z ⊑ nat_iter z f n}
  {Hf: Proper (leq ==> leq) f}
  : Proper (leq ==> leq) (nat_iter z f).
Proof.
  intro n; revert Hz Hf; revert z f; induction n;
    intros z f Hz Hf m Hnm; simpl; auto.
  - destruct m; simpl in *; try lia.
    apply Hf.
    apply IHn; auto; lia.
Qed.
#[global] Hint Resolve monotone_nat_iter : conat.

#[global]
 Instance antimonotone_nat_iter {A} `{OType A} (z : A) (f : A -> A)
 {Hz : forall n, nat_iter z f n ⊑ z}
 {Hf: Proper (leq ==> leq) f}
  : Proper (leq ==> flip leq) (nat_iter z f).
Proof.
  unfold flip.
  intro n; revert Hz Hf; revert z f; induction n;
    intros z f Hz Hf m Hnm; simpl; auto.
  - destruct m; simpl in *; try lia.
    apply Hf, IHn; auto; lia.
Qed.
#[global] Hint Resolve antimonotone_nat_iter : conat.

Definition coiter {A} `{PType A} (f : A -> A) : conat -> A :=
  co (nat_iter ⊥ f).

Definition coopiter {A} `{TType A} (z : A) (f : A -> A) : conat -> A :=
  coop (nat_iter ⊤ f).

(** Computation lemmas for coiters. *)

Lemma co_iter_zero {A} `{CPO A} (z : A) (f : A -> A) :
  co (nat_iter z f) cozero === z.
Proof.
  apply supremum_sup, supremum_const', equ_arrow; intros []; reflexivity.
Qed.

Lemma co_iter_succ {A} `{CPO A} (z : A) (f : A -> A) (n : conat) :
  z ⊑ f z ->
  ( forall n, z ⊑ nat_iter z f n) ->
  continuous f ->
  co (nat_iter z f) (cosucc n) === f (co (nat_iter z f) n).
Proof.
  intros Hz Hfz Hf.
  apply supremum_sup.
  apply shift_supremum'' with (f := fun i => f (nat_iter z f (ideal n i))); auto.
  { apply Hf.
    { apply monotone_directed; auto with conat order.
      apply chain_directed, chain_ideal. }
    { apply sup_spec.
      { apply monotone_directed; auto with conat order.
        apply chain_directed, chain_ideal. } } }
  apply equ_arrow; intro i; reflexivity.
Qed.

Lemma co_iter_zero' {A} {o : OType A} `{@ExtType A o} `{@CPO A o}
  (z : A) (f : A -> A) :
  co (nat_iter z f) cozero = z.
Proof. apply ext, co_iter_zero. Qed.

Lemma co_iter_succ' {A} {o : OType A} `{@ExtType A o} `{@CPO A o}
  (z : A) (f : A -> A) (n : conat) :
  z ⊑ f z ->
  ( forall n, z ⊑ nat_iter z f n) ->
  continuous f ->
  co (nat_iter z f) (cosucc n) = f (co (nat_iter z f) n).
Proof. intros Hz Hfz Hf; apply ext, co_iter_succ; auto. Qed.

Lemma coiter_zero {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA}
  (f : A -> A) :
  coiter f cozero === ⊥.
Proof. apply co_iter_zero. Qed.

Lemma coiter_succ {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA}
  (f : A -> A) (n : conat) :
  continuous f ->
  coiter f (cosucc n) === f (coiter f n).
Proof.
  intro Hf; apply co_iter_succ; auto.
  - apply bot_le.
  - intro; apply bot_le.
Qed.

Lemma coiter_succ' {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA} `{@ExtType _ oA}
  (f : A -> A) (n : conat) :
  continuous f ->
  coiter f (cosucc n) = f (coiter f n).
Proof. intro Hf; apply ext, coiter_succ; auto. Qed.

Lemma coiter_zero' {A} `{oA: OType A} `{@PType _ oA} `{@CPO _ oA} `{@ExtType _ oA}
  (f : A -> A) :
  coiter f cozero = ⊥.
Proof. apply ext, coiter_zero. Qed.

CoInductive infinite : conat -> Prop :=
| infinite_succ : forall n, infinite n -> infinite (cosucc n).

Lemma infinite_iff_omega (n : conat) :
  infinite n <-> n = omega.
Proof.
  split.
  - intro Hn.
    destruct (@conat_finite_or_omega n); auto.
    exfalso; destruct H as [m Hm]; subst.
    revert Hn; induction m; intro HC; inv HC; auto.
  - intros ->; cofix CH; rewrite unf_eq; constructor; auto.
Qed.

Extract Constant coiter => "
  \ o p f n ->
    case n of
      Cozero -> bot o p
      Cosucc n' -> f (coiter o p f n')
".

Lemma conat_prefix_omega (i : nat) :
  conat_prefix i omega = i.
Proof. induction i; simpl; auto. Qed.

Lemma not_finite_omega n :
  ~ finite n omega.
Proof.
  induction n; intro HC.
  - inv HC.
    rewrite (@unf_eq omega) in H.
    inv H.
  - rewrite unf_eq in HC.
    inv HC.
    congruence.
Qed.

Lemma finite_inj_inv n m :
  finite n (nat_inj m) ->
  n = m.
Proof. revert n; induction m; intros n Hnm; inv Hnm; auto. Qed.

Lemma finite_inj n :
  finite n (nat_inj n).
Proof. induction n; constructor; auto. Qed.

Lemma conat_to_conat'_to_conat (n : conat') :
  conat_to_conat' (conat'_to_conat n) = n.
Proof.
  destruct n; simpl.
  - unfold conat_to_conat'.
    destr.
    + destruct e as [i Hi].
      f_equal.
      compute.
      destr.
      apply finite_inj_inv in f; auto.
    + exfalso; apply n0; exists n.
      apply finite_inj.
  - unfold conat_to_conat'.
    destr.
    + destruct e as [i HC].
      exfalso; eapply not_finite_omega; eauto.
    + destruct u; auto.
Qed.

#[global]
 Instance Proper_conat_eq : Proper (conat_eq ==> conat_eq ==> flip impl) conat_eq.
Proof.
  cofix CH; intros a b Hab c d Hcd Hbd.
  destruct Hab.
  - inv Hbd; symmetry; auto.
  - inv Hbd; inv Hcd.
    constructor; eapply CH; eauto.
Qed.

#[global]
 Instance Proper_cosucc : Proper (conat_eq ==> conat_eq) cosucc.
Proof. intros n m Hnm; constructor; auto. Qed.

Definition nat_conat_le : nat -> conat -> Prop :=
  nat_iter (const True) (fun f m => match m with
                              | cozero => False
                              | cosucc m' => f m'
                              end).

#[global]
 Instance antimonotone_nat_conat_le : Proper (leq ==> flip leq) nat_conat_le.
Proof.
  apply antimonotone_nat_iter.
  - intros i n H; apply I.
  - intros f g Hfg [] Hn; auto; apply Hfg; auto.
Qed.
#[global] Hint Resolve antimonotone_nat_conat_le : conat.

Definition conat_le' : conat -> conat -> Prop :=
  coop nat_conat_le.

Lemma conat_le_conat_le' (n m : conat) :
  n ⊑ m <-> conat_le' n m.
Proof with auto with conat order.
  split.
  - intro Hnm.
    apply coop_intro2...
    intro i; simpl; unfold flip.
    revert Hnm; revert n m.
    induction i; intros n m Hnm; simpl.
    + constructor.
    + destruct n.
      * constructor.
      * inv Hnm; apply IHi; auto.
  - revert n m; cofix CH; intros n m Hnm.
    destruct n.
    + constructor.
    + destruct m.
      * apply coop_elim2 with (i := S O) in Hnm...
        inv Hnm.
      * constructor; apply CH.
        apply coop_intro2...
        intro i; apply coop_elim2 with (i := S i) in Hnm...
Qed.

(* Definition coplus (n : conat) : conat -> conat := *)
(*   (* coiter (compose cosucc) n. *) *)
(*   co (nat_iter id (compose cosucc)) n. *)

(* Lemma coplus_zero_l (n : conat) : *)
(*   coplus cozero n = n. *)
(* Proof. *)
(*   unfold coplus; simpl. *)
(*   rewrite co_iter_zero'; auto. *)
(* Qed. *)

(* (* Lemma coplus_zero_r (n : conat) : *) *)
(* (*   coplus n cozero = n. *) *)
(* (* Proof. *) *)

(* (*   unfold coplus; simpl. *) *)
(* (*   rewrite co_iter_zero'; auto. *) *)
(* (* Qed. *) *)

Lemma succ_conat_le (n : conat) :
  n ⊑ cosucc n.
Proof.
  revert n; cofix CH; intros [].
  { constructor. }
  constructor; apply CH.
Qed.

(* Lemma ikdfg (n : nat) (m : conat) : *)
(*   m ⊑ nat_iter (fun x0 : conat => x0) (compose cosucc) n m. *)
(* Proof. *)
(*   revert m; induction n; intro m; simpl. *)
(*   { reflexivity. } *)
(*   (* unfold compose in *. *) *)
(*   destruct m; constructor. *)
(*   etransitivity. *)
(*   { apply IHn. } *)
(*   admit. *)
(* Admitted. *)

(* Lemma coplus_succ (n m : conat) : *)
(*   coplus (cosucc n) m = cosucc (coplus n m). *)
(* Proof. *)
(*   unfold coplus; simpl. *)
(*   rewrite co_iter_succ'; auto. *)
(*   { intro x; unfold id, compose. *)
(*     apply succ_conat_le. } *)
(*   { intros x y; unfold id. simpl. *)
(*     apply ikdfg. } *)
(*   intros ch Hch f Hf. *)
(*   apply supremum_apply. *)
(*   intro x; unfold compose. *)
(*   apply continuous_cosucc. *)
(*   { intros i j. *)
(*     specialize (Hch i j). *)
(*     destruct Hch as [k [Hik Hjk]]. *)
(*     exists k; split; auto. } *)
(*   apply apply_supremum; auto. *)
(* Qed. *)

(* Lemma coplus_comm_leq (n m : conat) : *)
(*   coplus n m ⊑ coplus m n. *)
(* Proof with auto with conat order. *)
(*   apply conat_le_conat_le'. *)
(*   apply coop_intro2... *)
(*   intro i; simpl; unfold flip. *)
(*   revert n m; induction i; intros n m; simpl. *)
(*   { constructor. } *)
(*   destruct n. *)
(*   { rewrite coplus_zero_l. *)

(* Lemma coplus_comm (n m : conat) : *)
(*   coplus n m = coplus m n. *)
(* Proof. *)
(*   apply ext. *)
(*   split. *)

CoFixpoint coplus (n m : conat) : conat :=
  match n with
  | cozero => m
  | cosucc n' => cosucc (coplus n' m)
  end.

(* Lemma plus_0_r (n : nat) : *)
(*   n = n + 0. *)
(* Proof. induction n; simpl; auto. Qed. *)

(* Lemma S_plus (n m : nat) : *)
(*   S (n + m) = n + S m. *)
(* Proof. revert m; induction n; intro m; simpl; auto. Qed. *)

(* Lemma plus_comm (n m : nat) : *)
(*   n + m = m + n. *)
(* Proof. *)
(*   revert m; induction n; intros m; simpl. *)
(*   - apply plus_0_r. *)
(*   - rewrite IHn. *)
(*     apply S_plus. *)
(* Qed. *)

Lemma coplus_zero_l (n : conat) :
  coplus cozero n = n.
Proof.
  rewrite (@unf_eq (coplus _ _)); simpl.
  destruct n; reflexivity.
Qed.

Lemma coplus_zero_r (n : conat) :
  coplus n cozero = n.
Proof.
  apply conat_ext.
  revert n; cofix CH; intros [].
  - rewrite unf_eq; reflexivity.
  - rewrite (@unf_eq (coplus _ _)); constructor; apply CH.
Qed.

Lemma coplus_succ (n m : conat) :
  coplus (cosucc n) m = cosucc (coplus n m).
Proof. rewrite (@unf_eq (coplus _ _)); auto. Qed.

Lemma cosucc_coplus (n m : conat) :
  cosucc (coplus n m) = coplus n (cosucc m).
Proof.
  apply conat_ext.
  revert n m; cofix CH; intros [|n'] m.
  - rewrite (@unf_eq (coplus cozero _)); simpl.
    rewrite (@unf_eq (coplus cozero _)); simpl.
    destruct m; reflexivity.
  - rewrite (@unf_eq (coplus _ _)); simpl.
    rewrite (@unf_eq (coplus (cosucc _) _)); simpl.
    constructor.
    apply CH.
Qed.

Lemma coplus_comm (n m : conat) :
  coplus n m = coplus m n.
Proof.
  apply conat_ext.
  revert n m; cofix CH; intros n m.
  destruct n as [|n'].
  - rewrite unf_eq; simpl.
    rewrite <- coplus_zero_r.
    destruct m; reflexivity.
  - rewrite unf_eq; simpl.
    destruct m as [|m'].
    + rewrite coplus_zero_r.
      rewrite (@unf_eq (coplus _ _)); reflexivity.
    + rewrite (@unf_eq (coplus (cosucc _) _)); simpl.
      constructor.
      rewrite <- cosucc_coplus.
      rewrite <- cosucc_coplus.
      constructor.
      apply CH.
Qed.

(* Definition nmult : nat -> conat -> conat := *)
(*   nat_iter (const cozero) (fun f m => coplus m (f m)). *)

(* Definition nmult' (n : conat) : nat -> conat := *)
(*   nat_iter cozero (fun m => coplus n m). *)

(* Lemma nmult_nmult' n m : *)
(*   nmult n m = nmult' m n. *)
(* Proof. *)
(*   unfold nmult, nmult'. *)
(*   revert m; induction n; intro m; simpl; auto. *)
(*   rewrite IHn; auto. *)
(* Qed. *)

(* Lemma le_coplus (n m : conat) : *)
(*   n ⊑ coplus n m. *)
(* Proof. *)
(*   revert n m; cofix CH; intros [|n'] m. *)
(*   - constructor. *)
(*   - rewrite (@unf_eq (coplus _ _)); simpl. *)
(*     constructor. *)
(*     apply CH. *)
(* Qed. *)

(* #[global] *)
(*   Instance monotone_coplus (n : conat) : Proper (leq ==> leq) (coplus n). *)
(* Proof. *)
(*   revert n; cofix CH; intros n a b Hab. *)
(*   destruct b as [|b']. *)
(*   - inv Hab; rewrite <- coplus_zero_r; reflexivity. *)
(*   - destruct a as [|a']. *)
(*     + rewrite coplus_zero_r. *)
(*       apply le_coplus. *)
(*     + inv Hab. *)
(*       rewrite <- 2!cosucc_coplus. *)
(*       constructor. *)
(*       apply CH; auto. *)
(* Qed. *)

(* #[global] *)
(*  Instance monotone_nmult : Proper (leq ==> leq) nmult. *)
(* Proof. *)
(*   apply monotone_nat_iter. *)
(*   - intros; constructor. *)
(*   - intros f g Hfg n; apply monotone_coplus; auto. *)
(* Qed. *)

(* #[global] *)
(*  Instance monotone_nmult' (n : conat) : Proper (leq ==> leq) (nmult' n). *)
(* Proof. *)
(*   apply monotone_nat_iter. *)
(*   - intros; constructor. *)
(*   - intros a b Hab; apply monotone_coplus; auto. *)
(* Qed. *)

(* Definition comult : conat -> conat -> conat := *)
(*   co nmult. *)

(* Definition comult' (n : conat) : conat -> conat := *)
(*   co (nmult' n). *)

(* Lemma comult'_zero_l (n : conat) : *)
(*   comult' cozero n = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult'_zero_r (n : conat) : *)
(*   comult' n cozero = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult'_succ (n m : conat) : *)
(*   comult' n (cosucc m) = coplus n (comult' n m). *)
(* Proof. Admitted. *)

(* Lemma coplus_inj a b : *)
(*   coplus (nat_inj a) (nat_inj b) = nat_inj (a + b). *)
(* Proof. *)
(*   revert b; induction a; intro b; simpl. *)
(*   - rewrite coplus_zero_l; auto. *)
(*   - rewrite coplus_succ, IHa; auto. *)
(* Qed. *)

(* Lemma comult'_inj a b : *)
(*   comult' (nat_inj a) (nat_inj b) = nat_inj (a * b). *)
(* Proof. *)
(*   revert a; induction b; intro a; simpl. *)
(*   - rewrite comult'_zero_r, Nat.mul_0_r; auto. *)
(*   - rewrite <- mult_n_Sm. *)
(*     rewrite <- coplus_inj. *)
(*     rewrite comult'_succ. *)
(*     rewrite coplus_comm. *)
(*     rewrite IHb; auto. *)
(* Qed. *)

(* Lemma comult'_comm (n m : conat) : *)
(*   comult' n m = comult' m n. *)
(* Proof. *)
(*   destruct (@conat_finite_or_omega n); subst. *)
(*   - destruct H as [a ?]; subst. *)
(*     destruct (@conat_finite_or_omega m); subst. *)
(*     + destruct H as [b ?]; subst. *)
(*       rewrite 2!comult'_inj; f_equal; lia. *)
(*     + admit. *)
(*   - admit. *)
(* Admitted. *)

(* Lemma comult_comult' (n m : conat) : *)
(*   comult n m = comult' m n. *)
(* Proof. *)
(*   unfold comult, comult'. *)
(*   unfold co. *)
(*   unfold compose. *)
(*   apply ext. *)
(*   rewrite sup_apply. *)
(*   2: { admit. } *)
(*   apply eq_equ. *)
(*   f_equal; ext i. *)
(*   apply nmult_nmult'. *)
(* Admitted. *)

(* Lemma comult'_comm (n m : conat) : *)
(*   comult' n m = comult' m n. *)
(* Proof. *)
(*   unfold comult'. *)
(*   unfold co. *)
(*   f_equal. *)
(*   ext i. *)
(*   simpl; unfold compose, flip. *)
(*   revert n m; induction i; intros n m; simpl; auto. *)
(*   destruct m as [|m']. *)
(*   - unfold nmult'. simpl. *)
(*     destruct n as [|n']; simpl; auto. *)
(*     rewrite coplus_zero_l. *)
(*     admit. *)
(*   - unfold nmult'. simpl. *)

(* Lemma comult_zero_l (n : conat) : *)
(*   comult cozero n = cozero. *)
(* Proof. unfold comult; rewrite coiter_zero'; auto. Qed. *)

(* Lemma comult_zero_r (n : conat) : *)
(*   comult n cozero = cozero. *)
(* Proof. Admitted. *)

(* Lemma comult_succ (n m : conat) : *)
(*   comult (cosucc n) m = coplus m (comult n m). *)
(* Proof. *)
(*   unfold comult. *)
(*   rewrite coiter_succ'; auto. *)
(*   admit. *)
(* Admitted. *)

(* Lemma nat_conat_le_trans n m p : *)
(*   n ⊑ m -> *)
(*   nat_conat_le m p -> *)
(*   nat_conat_le n p. *)
(* Admitted. *)

(* Lemma nat_conat_le_prefix i n : *)
(*   nat_conat_le (conat_prefix i n) n. *)
(* Admitted. *)

(* Lemma comult_comm_leq (n m : conat) : *)
(*   comult n m ⊑ comult m n. *)
(* Proof with auto with conat order. *)
(*   apply conat_le_conat_le'. *)
(*   apply coop_intro2... *)
(*   intro i; simpl; unfold flip. *)
(*   revert n m; induction i; intros n m; simpl. *)
(*   { constructor. } *)
(*   destruct n as [|n']. *)
(*   - rewrite comult_zero_l; constructor. *)
(*   - rewrite comult_succ. *)
(*     destruct m as [|m']; simpl. *)
(*     + rewrite comult_zero_r; constructor. *)
(*     + rewrite comult_succ. *)
(*       rewrite (@unf_eq (coplus (cosucc _) _)); simpl. *)


Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FragmentFacts.
Require Import Undecidability.FOL.Deduction.FragmentND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Require Import Vector Lia.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section Soundness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Lemma soundness {ff : falsity_flag} A phi :
    A ⊢I phi -> valid_ctx A phi.
  Proof.
    remember intu as p.
    induction 1; intros D I rho HA; comp.
    - intros Hphi. apply IHprv; trivial. intros ? []; subst. assumption. now apply HA.
    - now apply IHprv1, IHprv2.
    - intros d. apply IHprv; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHprv Heqp D I rho HA (eval rho t)). now intros [].
    - apply (IHprv Heqp) in HA. firstorder.
    - firstorder.
    - discriminate.
  Qed.

  Lemma soundness' {ff : falsity_flag} phi :
    [] ⊢I phi -> valid phi.
  Proof.
    intros H % soundness. firstorder.
  Qed.

  Lemma intuitionistic_is_classical {ff:falsity_flag} A phi :
    A ⊢I phi -> A ⊢C phi.
  Proof.
  induction 1; comp.
  - now apply II, IHprv.
  - now eapply IE, IHprv2.
  - now eapply AllI, IHprv.
  - now eapply AllE, IHprv.
  - now eapply Exp, IHprv.
  - now eapply Ctx, H.
  - apply Pc.
  Qed.

  Lemma classical_soundness (LEM:forall P:Prop, P \/ ~P) {ff : falsity_flag} A phi :
    A ⊢C phi -> valid_ctx A phi.
  Proof.
    induction 1; intros D I rho HA; cbn.
    - intros Hphi. apply IHprv; trivial. intros ? []; subst. assumption. now apply HA.
    - now apply IHprv1, IHprv2.
    - intros d. apply IHprv; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHprv D I rho HA (eval rho t)). now intros [].
    - apply (IHprv) in HA. firstorder.
    - firstorder.
    - intros H.
      destruct (LEM (rho ⊨ phi)) as [Ht|Hf]. 1:easy.
      destruct (LEM (rho ⊨ psi)) as [Ht2|Hf2]; tauto.
  Qed.

  Lemma sound_for_classical_model {p:peirce} {ff : falsity_flag} A phi (D : Type) (I : interp D) (rho : env D) :
    classical I -> A ⊢ phi -> rho ⊫ A -> rho ⊨ phi.
  Proof.
    intros LEM HD. revert LEM rho. induction HD; cbn; intros LEM rho HA.
    - intros Hphi. apply IHHD. 1:easy. intros a [<-|Ha]; try easy. now apply HA.
    - now apply IHHD1, IHHD2.
    - intros d. apply IHHD; trivial. intros psi [psi'[<- H' % HA]] % in_map_iff.
      eapply sat_comp. now comp.
    - eapply sat_comp, sat_ext. 2: apply (IHHD LEM rho HA (eval rho t)). now intros [].
    - apply (IHHD) in HA; cbn in *; eauto.
    - apply HA, H.
    - intros H. unfold classical in LEM. cbn in LEM. eapply LEM. exact H.
  Qed.

End Soundness.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.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.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

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

Class SeparationTransparentModality1 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} (Gamma: Provable L) := {
  sepcon_boxp: forall x y, |-- boxp x * boxp y --> boxp (x * y)
}.

Class SeparationTransparentModality2 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} (Gamma: Provable L) := {
  boxp_sepcon: forall x y, |-- boxp (x * y) --> boxp x * boxp y
}.

Class SeparationTransparentModality3 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) := {
  wand_boxp: forall x y, |-- (boxp x -* boxp y) --> boxp (x -* y)
}.

Class SeparationTransparentModality4 (L: Language) {minL: MinimumLanguage L} {mL: ModalLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) := {
  boxp_wand: forall x y, |-- boxp (x -* y) --> (boxp x -* boxp y)
}.

Instance SeparationTransparentModality14 (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sepconAX: SepconAxiomatization L Gamma} {wandAX: WandAxiomatization L Gamma} {sm1Gamma: SeparationTransparentModality1 L Gamma}:
  SeparationTransparentModality4 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_boxp.
  rewrite provable_wand_sepcon_modus_ponens1.
  apply provable_impp_refl.
Qed.

Instance SeparationTransparentModality41 (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sepconL: SepconLanguage L} {wandL: WandLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sepconAX: SepconAxiomatization L Gamma} {wandAX: WandAxiomatization L Gamma} {sm4Gamma: SeparationTransparentModality4 L Gamma}:
  SeparationTransparentModality1 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite <- boxp_wand.
  eapply modus_ponens; [apply axiom_K |].
  apply rule_N.
  apply wand_sepcon_adjoint.
  apply provable_impp_refl.
Qed.


(**This document illustrate the space which we work in and the hypo we
     have already taken to construct this space**)
From CReal.MetricSpace Require Export M_pack.
From CReal.MetricSpace Require Export M_new.
Section BaseSpace.
Existing Instance EquR_trans.
Existing Instance leC_rewrite.
Variables X : Type.
Variables eqX : relation X.
Variables HE : Equivalence eqX.
Variables leX : relation X.
Variables pofX : Pre_Order_Field eqX leX.
Variables plusX : X -> X -> X.
Variables zeroX : X.
Variables pfX : Plus_Field eqX leX plusX zeroX.
Variables distX : X -> X -> X.
Variables MX : Metric eqX eqX _ _ _ pfX distX.

Definition ltX : X -> X -> Prop :=@lt X eqX leX pofX.

Variables Dp : Density eqX pfX.
Variables HPD : forall a b c : X, eqX (distX (plusX a b) (plusX a c)) (distX b c).

Variables A : Type.
Variables eqA : relation A.
Variables HEA : Equivalence eqA.
Variables dist : A -> A -> X.

Variables M : Metric eqX eqA leX plusX _ pfX dist.

Definition CX : Type := Cauchilize eqX eqX _ _ _ _.
Definition CA : Type := Cauchilize eqX eqA _ _ _ _.
Definition equCX : CX -> CX -> Prop :=@equC X X eqX eqX leX plusX zeroX distX pfX MX.
Definition leCX :=@leC X eqX leX plusX _ _ pfX MX HE.

Variables PB : PropBucket.
Definition pofCX :Pre_Order_Field equCX leCX :=@preOrder_trans X eqX leX plusX _ HE pfX _ MX Dp PB.

Definition plusCX :CX -> CX -> CX := M_new.plusCX X eqX HE leX plusX zeroX distX pfX MX Dp HPD .

Definition zeroCX :CX := M_new.zeroX X eqX HE leX plusX zeroX distX pfX MX.

Variables HIN : (forall a b : X, eqX (distX a b) (distX (inv a) (inv b))).
Definition pfCX : Plus_Field equCX leCX plusCX zeroCX  :=@pf_trans X eqX HE leX plusX zeroX distX pfX MX Dp HPD PB HIN.

Definition equCA : CA -> CA -> Prop := @equC A X eqX eqA leX plusX zeroX dist pfX M.

Variable HDD_pre : forall (x : X), eqX (distX zeroX x) x.
Theorem HDD_l : forall (a b c : A), leX (distX (dist a b) (dist a c)) (dist b c).
Proof.
  intros. Admitted. (**TODO**)

Variables HDD : forall (a b c : A), eqX (distX (dist a b) (dist a c)) (dist b c).
Variables HDDX : forall (a b c : X), eqX (distX (distX a b) (distX a c)) (distX b c).

Notation "a + b" := (plusX a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Theorem dist_eq : forall (a b : A), eqX (distX zeroX (dist a b)) (dist a b).
Proof.
    intros. assert(eqX zeroX (dist a a)). pose proof (mre a a) as [Hex1 ?]. symmetry.
    apply Hex1. reflexivity. rewrite H. rewrite HDD. reflexivity.
Qed.
Theorem distX_eq : forall (a b : X), eqX (distX zeroX (distX a b)) (distX a b).
Proof.
    intros. assert(eqX zeroX (distX a a)). pose proof (mre a a) as [Hex1 ?]. symmetry.
    apply Hex1. reflexivity. rewrite H. rewrite HDDX. reflexivity.
Qed.
Definition leseq (a b : CX) : Prop.
destruct a, b. apply(forall (x y : X) (n : nat), Cseq n x -> Cseq0 n y -> leX x y).
Defined.
Theorem le_leC : forall (a b : CX), leseq a b -> leCX a b.
Proof.
    intros. destruct(classic (equCX a b)).
    -rewrite H0. destruct b. simpl. left. intros. exists 0. intros. assert(eqX a1 a2).
     apply HCseq3 with (m := n);auto. rewrite H6. pose proof (mre a2 a2) as [Hex ?].
     rewrite Hex;auto. reflexivity.
   -destruct a. destruct b. simpl. simpl in H0. simpl in H. right.
    apply not_all_ex_not in H0. destruct H0 as [eps]. apply not_all_ex_not in H0.
    destruct H0 as [H3].
    destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
    destruct (division_of_eps _ _ _ _ _ _ eps1) as [epsex1 [epsex2[Hex1[Hex2 Hexeq]]]];auto.
    destruct H1. destruct H2. destruct HCA with (eps := epsex1) as [N1];auto.
    destruct HCA0 with (eps := epsex2) as [N2];auto. destruct (always_greater N1 N2) as [G].
    destruct H4. exists G. intros. apply not_ex_all_not with (n := n) in H0.
    apply not_all_ex_not in H0 as [N]. apply not_all_ex_not in H0 as [H9].
    apply not_all_ex_not in H0 as [a1pin]. apply not_all_ex_not in H0 as [a2pin].
    apply not_all_ex_not in H0 as [H10]. apply not_all_ex_not in H0 as [H11]. apply lt_not in H0.
    destruct H1 with (m := n) (n := N) (a := a1) (b := a1pin);split;auto.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto |apply (lt_trans _ n _);auto].
    apply H with (n := n);auto.
    destruct H2 with (m := n) (n := N) (a := a2) (b := a2pin). split.
    apply (lt_trans _ G _);auto. apply (lt_trans _ G _);[auto|apply (lt_trans _ n _); auto].
    split;auto. assert(epsex1 > distX a1 a1pin). apply lt_intro;auto.
    assert(epsex2 > distX a2 a2pin). apply lt_intro;auto.
    pose proof (lt_two_plus_two X eqX _ _ plusX zeroX).
    assert(epsex1 + epsex2> distX a1 a1pin + distX a2 a2pin).
    destruct (H14 (distX a1 a1pin) (distX a2 a2pin) (epsex1) (epsex2));apply lt_intro;auto.
    rewrite Hexeq in H15. unfold not. intros. rewrite H16 in H15. rewrite msy in H15.
    assert(distX a1pin a2 + distX a2 a2pin >= distX a1pin a2pin). apply mtr.
    assert(eps1 > distX a1pin a2pin).
    destruct (le_lt_eq _ _ _ (distX a1pin a2pin) (distX a1pin a2 + distX a2 a2pin)).
    apply H18 in H17. destruct H17. apply lttr with (y := distX a1pin a2 + distX a2 a2pin);auto.
    rewrite H17. auto. assert(distX a1pin a2pin < eps).
    assert(eps1 < eps). pose proof (lt_div X eqX _ leX plusX zeroX).
    destruct H19 with (a:=eps1) (b := eps2) (c := eps);auto. apply lt_intro;auto.
    apply lttr with (y := eps1);auto. pose proof (lt_not X eqX _ leX).
    destruct H20 with (x := distX a1pin a2pin) (y := eps). apply H22 in H0. unfold not in H0.
    apply H0. auto. auto.
Qed.

Theorem ms_trans : Metric equCX equCA leCX plusCX zeroCX pfCX
        (@distC _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HDD).
Proof.
    split.
    -intros. destruct(classic (equCA p1 p2)).
      +destruct p1. destruct p2. simpl. left. intros. simpl in H.
         destruct H with (eps := eps) as [N];auto. exists N. intros.
         destruct H6. rewrite He. assert(eqX zeroX a1). destruct H5;[reflexivity | auto].
         rewrite <-H6. pose proof orderPres2. pose proof mle.
         destruct (@le_lt_eq X eqX leX pofX zeroX (dist a b)). apply H9 in H8. destruct H8.
         assert(distX zeroX (dist a b) < distX zeroX eps). assert(eps > dist a b).
         destruct H3 with (n := n) (a1 := a) (a2 := b);auto. apply lt_intro;auto.
         destruct H7 with (a := zeroX) (b := dist a b) (c := eps);auto.
         { apply lt_intro;destruct H8;auto. }
         { apply lt_intro;destruct H11;auto. }
         { apply lt_intro;auto. }
         { rewrite dist_eq. apply H3 with (n := n);auto. }
        rewrite <- H8. pose proof (mre zeroX zeroX) as [Hex1 Hex2];rewrite Hex1.
        auto. reflexivity.
      +destruct p1. destruct p2. simpl. right. simpl in H. apply not_all_ex_not in H.
        destruct H as [eps]. apply not_all_ex_not in H. destruct H as [H2].
        destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1[eps2 [Heps1 [Heps2 Heq]]]];auto.
        destruct(division_of_eps _ _ _ _ _ _ eps1) as [epsex1[epsex2 [Hepsex1 [Hepsex2 Hexeq]]]];auto.
        destruct H0. destruct HCA with (eps := epsex1) as [N1];auto.
        destruct H1. destruct HCA0 with (eps := epsex2) as [N2];auto.
        destruct (always_greater N1 N2) as [G1]. destruct H3. exists G1.
        intros. apply not_ex_all_not with (n := n) in H. apply not_all_ex_not in H.
        destruct H as [N3]. apply not_all_ex_not in H. destruct H as [H8].
        apply not_all_ex_not in H. destruct H7. rewrite He. destruct H as [apin].
        apply not_all_ex_not in H. destruct H as [bpin]. apply not_all_ex_not in H. destruct H as [H7].
        apply not_all_ex_not in H. destruct H as [H9]. apply lt_not in H. assert(eqX a1 zeroX).
        destruct H6. reflexivity. symmetry. auto. rewrite H10. assert(~eqA a b). unfold not. intros.
        destruct H0 with (m := n) (a := a) (n := N3) (b := apin). split;apply (lt_trans _ G1 _);auto.
        apply (lt_trans _ n _);auto. split;auto. destruct H1 with (m := n) (a := b) (n := N3) (b := bpin).
        split;apply(lt_trans _ G1 _);auto. apply (lt_trans _ n _);auto. split;auto.
        assert(epsex1 > dist a apin). apply lt_intro;auto. assert(epsex2 > dist b bpin).
        apply lt_intro;auto. rewrite H11 in H12. rewrite msy in H12.
        assert(dist apin b + dist b bpin >= dist apin bpin). apply mtr.
        assert(dist apin b + dist b bpin < epsex1 + epsex2).
        pose proof (lt_two_plus_two _ eqX _ leX plusX zeroX  (dist apin b) (dist b bpin) (epsex1) (epsex2)) as [H15];auto. apply lt_intro;destruct H12;auto. apply lt_intro;destruct H13;auto.
        apply lt_intro;auto. rewrite Hexeq in H15. assert(eps1 < eps).
        pose proof (lt_div X eqX _ leX plusX zeroX eps1 eps2 eps) as [H16]. auto. auto. auto.
        apply lt_intro;auto. assert(dist apin b + dist b bpin < eps). apply lttr with (y := eps1);auto.
        assert(eps > dist apin bpin).
        destruct (le_lt_eq _ _ _(dist apin bpin)  (dist apin b + dist b bpin) ). apply H18 in H14.
        destruct H14. apply lttr with (y := dist apin b + dist b bpin);auto. rewrite H14;auto.
        assert(~eps > dist apin bpin). apply lt_not;auto. unfold not in H19. apply H19. auto.
        assert(dist a b >= zeroX). apply mle. assert(~(eqX (dist a b) zeroX)).
        unfold not. intros. apply mre in H13. unfold not in H11. apply H11. auto.
        apply lt_intro; auto. unfold not. intros. unfold not in H13. apply H13. symmetry;auto.
        auto.
     -intros. destruct p1. destruct p2. simpl. intros. exists 0. intros. destruct H3.
      destruct H4. rewrite He. rewrite He0. assert(eqA a b0). destruct H.
      apply HCseq3 with (m:= n);auto. assert(eqA b a0). destruct H0.
      apply HCseq3 with (m:=n);auto. rewrite H3. rewrite H4. rewrite (msy b0 a0).
      pose proof (mre (dist a0 b0) (dist a0 b0)) as [Hex1 ?];rewrite Hex1;auto;reflexivity.
     -intros. split.
        +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as [N];auto. exists N. intros. destruct H5. rewrite He.
        assert(eqX a2 zeroX). destruct H6. reflexivity. symmetry. auto. rewrite H5.
        rewrite msy. rewrite dist_eq. apply H3 with (n := n);auto.
      +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as[N];auto.
         exists N. intros. rewrite <-dist_eq. rewrite msy. apply H3 with (n := n);auto.
         apply dit with (a := a1) (b := a2);auto. reflexivity. apply sig.
     -intros. apply le_leC. destruct p1, p2, p3. simpl. intros. destruct H2. destruct H3. rewrite He.
       rewrite He0. destruct Ha0. rewrite He1. destruct Hb0. rewrite He2.
       assert(eqA a1 b1). destruct H0. apply HCseq3 with (m := n);auto. rewrite H2.
       assert(eqA a0 a). destruct H. apply HCseq3 with (m := n);auto. rewrite H3.
       assert(eqA b0 b). destruct H1. apply HCseq3 with (m := n);auto. rewrite H4.
       apply mtr.
     -intros. destruct p1,p2,p3,p4. simpl. intro. simpl in H0,H. intros.
      destruct(division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
      destruct H with (eps := eps1) as [N1];auto. destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. exists G. intros. destruct H10. destruct H11.
      rewrite He. rewrite He0.
      assert(distX (dist a b) (dist a0 b0) <= distX (dist a b) (dist a b0) + distX (dist a b0) (dist a0 b0)).
      apply mtr. rewrite HDD, (msy a b0), (msy a0 b0), HDD in H10.
      assert(dist b b0 + dist a a0 < eps). rewrite <-Heq.
      pose proof (lt_two_plus_two X eqX _ leX plusX zeroX).
      destruct H11 with (a := dist b b0) (b := dist a a0) (c := eps2) (d := eps1).
      destruct H7 with (n := n) (a1 := b) (a2 := b0). destruct H8. apply (lt_trans _ G _);auto.
      auto. auto. apply lt_intro;auto. destruct H6 with (n := n) (a1 := a) (a2 := a0).
      destruct H8. apply (lt_trans _ G _);auto. auto. auto. apply lt_intro;auto.
      rewrite (pfc eps1 _). apply lt_intro;auto.
      destruct (le_lt_eq _ _ _ (distX (dist a b) (dist b0 a0)) (dist b b0 + dist a a0)).
      apply H12 in H10. destruct H10. apply lttr with (y := dist b b0 + dist a a0);auto.
      rewrite (msy a0 b0). apply lt_intro;destruct H10;auto. apply lt_intro;destruct H11;auto.
      rewrite (msy a0 b0), H10. apply lt_intro; destruct H11; auto.
Qed.

(**The proof of the next theorem is itself redundant and trivial since it can be yielded by taking A = X.**)
Theorem ms_trans_X : Metric equCX equCX leCX plusCX zeroCX pfCX
        (@distC _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ HDDX).
Proof.
    split.
    -intros. destruct(classic (equCX p1 p2)).
      +destruct p1. destruct p2. simpl. left. intros. simpl in H.
         destruct H with (eps := eps) as [N];auto. exists N. intros.
         destruct H6. rewrite He. assert(eqX zeroX a1). destruct H5;[reflexivity | auto].
         rewrite <-H6. pose proof orderPres2. assert(distX a b >= zeroX) as H8. apply mle.
         destruct (@le_lt_eq X eqX leX pofX zeroX (distX a b)). apply H9 in H8. destruct H8.
         assert(distX zeroX (distX a b) < distX zeroX eps). assert(eps > distX a b).
         destruct H3 with (n := n) (a1 := a) (a2 := b);auto. apply lt_intro;auto.
         destruct H7 with (a := zeroX) (b := distX a b) (c := eps);auto.
         { apply lt_intro;destruct H8;auto. }
         { apply lt_intro;destruct H11;auto. }
         { apply lt_intro;auto. }
         { rewrite distX_eq. apply H3 with (n := n);auto. }
        rewrite <- H8. pose proof (mre zeroX zeroX) as [Hex1 Hex2];rewrite Hex1.
        auto. reflexivity.
      +destruct p1. destruct p2. simpl. right. simpl in H. apply not_all_ex_not in H.
        destruct H as [eps]. apply not_all_ex_not in H. destruct H as [H2].
        destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1[eps2 [Heps1 [Heps2 Heq]]]];auto.
        destruct(division_of_eps _ _ _ _ _ _ eps1) as [epsex1[epsex2 [Hepsex1 [Hepsex2 Hexeq]]]];auto.
        destruct H0. destruct HCA with (eps := epsex1) as [N1];auto.
        destruct H1. destruct HCA0 with (eps := epsex2) as [N2];auto.
        destruct (always_greater N1 N2) as [G1]. destruct H3. exists G1.
        intros. apply not_ex_all_not with (n := n) in H. apply not_all_ex_not in H.
        destruct H as [N3]. apply not_all_ex_not in H. destruct H as [H8].
        apply not_all_ex_not in H. destruct H7. rewrite He. destruct H as [apin].
        apply not_all_ex_not in H. destruct H as [bpin]. apply not_all_ex_not in H. destruct H as [H7].
        apply not_all_ex_not in H. destruct H as [H9]. apply lt_not in H. assert(eqX a1 zeroX).
        destruct H6. reflexivity. symmetry. auto. rewrite H10. assert(~eqX a b). unfold not. intros.
        destruct H0 with (m := n) (a := a) (n := N3) (b := apin). split;apply (lt_trans _ G1 _);auto.
        apply (lt_trans _ n _);auto. split;auto. destruct H1 with (m := n) (a := b) (n := N3) (b := bpin).
        split;apply(lt_trans _ G1 _);auto. apply (lt_trans _ n _);auto. split;auto.
        assert(epsex1 > distX a apin). apply lt_intro;auto. assert(epsex2 > distX b bpin).
        apply lt_intro;auto. rewrite H11 in H12. rewrite msy in H12.
        assert(distX apin b + distX b bpin >= distX apin bpin). apply mtr.
        assert(distX apin b + distX b bpin < epsex1 + epsex2).
        pose proof (lt_two_plus_two _ eqX _ leX plusX zeroX  (distX apin b) (distX b bpin) (epsex1) (epsex2)) as [H15];auto. apply lt_intro;destruct H12;auto. apply lt_intro;destruct H13;auto.
        apply lt_intro;auto. rewrite Hexeq in H15. assert(eps1 < eps).
        pose proof (lt_div X eqX _ leX plusX zeroX eps1 eps2 eps) as [H16]. auto. auto. auto.
        apply lt_intro;auto. assert(distX apin b + distX b bpin < eps). apply lttr with (y := eps1);auto.
        assert(eps > distX apin bpin).
        destruct (le_lt_eq _ _ _(distX apin bpin)  (distX apin b + distX b bpin) ). apply H18 in H14.
        destruct H14. apply lttr with (y := distX apin b + distX b bpin);auto. rewrite H14;auto.
        assert(~eps > distX apin bpin). apply lt_not;auto. unfold not in H19. apply H19. auto.
        assert(distX a b >= zeroX). apply mle. assert(~(eqX (distX a b) zeroX)).
        unfold not. intros. apply mre in H13. unfold not in H11. apply H11. auto.
        apply lt_intro; auto. unfold not. intros. unfold not in H13. apply H13. symmetry;auto.
        auto.
     -intros. destruct p1. destruct p2. simpl. intros. exists 0. intros. destruct H3.
      destruct H4. rewrite He. rewrite He0. assert(eqX a b0). destruct H.
      apply HCseq3 with (m:= n);auto. assert(eqX b a0). destruct H0.
      apply HCseq3 with (m:=n);auto. rewrite H3. rewrite H4. rewrite (msy b0 a0).
      pose proof (mre (distX a0 b0) (distX a0 b0)) as [Hex1 ?];rewrite Hex1;auto;reflexivity.
     -intros. split.
        +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as [N];auto. exists N. intros. destruct H5. rewrite He.
        assert(eqX a2 zeroX). destruct H6. reflexivity. symmetry. auto. rewrite H5.
        rewrite msy. rewrite distX_eq. apply H3 with (n := n);auto.
      +intros. destruct p1. destruct p2. simpl. simpl in H. intros.
        destruct H with (eps := eps) as[N];auto.
         exists N. intros. rewrite <-distX_eq. rewrite msy. apply H3 with (n := n);auto.
         apply dit with (a := a1) (b := a2);auto. reflexivity. apply sig.
     -intros. apply le_leC. destruct p1, p2, p3. simpl. intros. destruct H2. destruct H3. rewrite He.
       rewrite He0. destruct Ha0. rewrite He1. destruct Hb0. rewrite He2.
       assert(eqX a1 b1). destruct H0. apply HCseq3 with (m := n);auto. rewrite H2.
       assert(eqX a0 a). destruct H. apply HCseq3 with (m := n);auto. rewrite H3.
       assert(eqX b0 b). destruct H1. apply HCseq3 with (m := n);auto. rewrite H4.
       apply mtr.
     -intros. destruct p1,p2,p3,p4. simpl. intro. simpl in H0,H. intros.
      destruct(division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2 [Heps1 [Heps2 Heq]]]];auto.
      destruct H with (eps := eps1) as [N1];auto. destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. exists G. intros. destruct H10. destruct H11.
      rewrite He. rewrite He0.
      assert(distX (distX a b) (distX a0 b0) <= distX (distX a b) (distX a b0) + distX (distX a b0) (distX a0 b0)).
      apply mtr. rewrite HDDX, (msy a b0), (msy a0 b0), HDDX in H10.
      assert(distX b b0 + distX a a0 < eps). rewrite <-Heq.
      pose proof (lt_two_plus_two X eqX _ leX plusX zeroX).
      destruct H11 with (a := distX b b0) (b := distX a a0) (c := eps2) (d := eps1).
      destruct H7 with (n := n) (a1 := b) (a2 := b0). destruct H8. apply (lt_trans _ G _);auto.
      auto. auto. apply lt_intro;auto. destruct H6 with (n := n) (a1 := a) (a2 := a0).
      destruct H8. apply (lt_trans _ G _);auto. auto. auto. apply lt_intro;auto.
      rewrite (pfc eps1 _). apply lt_intro;auto.
      destruct (le_lt_eq _ _ _ (distX (distX a b) (distX b0 a0)) (distX b b0 + distX a a0)).
      apply H12 in H10. destruct H10. apply lttr with (y := distX b b0 + distX a a0);auto.
      rewrite (msy a0 b0). apply lt_intro;destruct H10;auto. apply lt_intro;destruct H11;auto.
      rewrite (msy a0 b0), H10. apply lt_intro; destruct H11; auto.
Qed.
End BaseSpace.


From st.STLCmuVS Require Import lang tactics lib.fixarrow.
From iris.base_logic.lib Require Export ghost_map.
From iris.proofmode Require Import tactics.
Require Export st.backtranslations.st_sem.list_gmap.

Section ghost.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuVS_lang Σ}.
  Context `{ghost_mapG_inst : !ghost_mapG Σ nat V}.

  Definition auth_list (γ : gname) (vs : list V) : iProp Σ :=
    ghost_map_auth γ 1 (list_gmap vs).

  Definition frag_elem (γ : gname) (i : nat) (v : V) : iProp Σ :=
    i ↪[ γ ] v. (* ghost_map_elem γ i (DfracOwn 1) v. *)

  Lemma ghost_empty :
    ⊢ |==> ∃ γ, auth_list γ [].
  Proof. by iApply ghost_map_alloc_empty. Qed.

  Lemma ghost_alloc γ vs v :
    auth_list γ vs -∗ |==> auth_list γ (vs ++ [v]) ∗ length vs ↪[ γ ] v.
  Proof.
    iIntros "Hvs".
    rewrite !/auth_list list_gmap_snoc.
    iApply (ghost_map_insert with "Hvs").
    rewrite -list_gmap_lookup. by apply lookup_ge_None.
  Qed.

  Lemma ghost_alloc_persist γ vs v :
    auth_list γ vs -∗ |==> auth_list γ (vs ++ [v]) ∗ length vs ↪[ γ ]□ v.
  Proof.
    iIntros "Hvs".
    rewrite !/auth_list list_gmap_snoc.
    iApply (ghost_map_insert_persist with "Hvs").
    rewrite -list_gmap_lookup. by apply lookup_ge_None.
  Qed.

  Lemma ghost_read γ vs i v :
    ⊢ auth_list γ vs -∗ i ↪[ γ ] v -∗ ⌜ vs !! i = Some v ⌝.
  Proof.
    iIntros "Hvs Hiv".
    rewrite /auth_list list_gmap_lookup.
    iApply (ghost_map_lookup with "Hvs Hiv").
  Qed.

  Lemma ghost_write γ vs v i v' :
    ⊢ auth_list γ vs -∗ i ↪[ γ ] v -∗ |==> auth_list γ (<[ i := v' ]> vs) ∗ i ↪[ γ ] v'.
  Proof.
    iIntros "Hvs Hiv".
    iDestruct (ghost_read with "Hvs Hiv") as %eq.
    rewrite !/auth_list (list_gmap_insert _ _ _ _ eq).
    iApply (ghost_map_update with "Hvs Hiv").
  Qed.

End ghost.