(*Version 1.4.2 - 25-05-2020
  finite_additivity_meas now finished
  additivty_meas also proven, incl. all lemmas
  proof complete!
*)

Require Import Sets.Ensembles.
Require Import Sets.Classical_sets.
Require Import Sets.Powerset.
Require Import Logic.
Require Import ClassicalFacts.
Require Import Omega.
Require Import Coq.Arith.Wf_nat.

Module WP_library.
(**** WP tactics library ****)
Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis.
Require Import Integration.
Require Import micromega.Lra.
Require Import Omega.
Require Import Max.
(* Require Import Unicode.Utf8. *)
Require Import Sets.Ensembles.
Require Import Sets.Classical_sets.

(** Guarantee indentation and introduce custom notation for forall *)
Notation "'for' 'all' x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' for  all  x .. y ']' , '//'  P ']'") : type_scope.

Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  only parsing) : type_scope.

Notation "'there' 'exists' x .. y , P " := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' there  exists  x .. y  ']' , '//'  P ']'") : type_scope.

Notation "∃ x .. y , P " := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  only parsing) : type_scope.

Notation "'fun' x .. y '↦' t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'fun' x .. y ']' '↦' '/' t ']'").

Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
Notation "x → y" := (x -> y)
  (at level 99, y at level 200, right associativity,
   only parsing): type_scope.
Notation "x ⇒ y" := (x -> y)
  (at level 99, y at level 200, right associativity,
   only parsing): type_scope.
(* the notation below is fun, but is no good for functions *)
(* need to see if this can be adapted so it only uses
   this notation for propositions *)
(*Notation "'if' x 'then' y" := (x -> y)
  (at level 99, y at level 200, right associativity): prop_scope.*)
Notation "x ⇨ y" := (x -> y)
  (at level 99, y at level 200, right associativity): type_scope.

Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "x ⇔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

Notation "x ≤ y" := (x <= y)%nat (at level 70, no associativity) : nat_scope.
Notation "x ≥ y" := (x >= y)%nat (at level 70, no associativity) : nat_scope.

Notation "x ≤ y" := (x <= y)%R (at level 70, no associativity) : R_scope.
Notation "x ≥ y" := (x >= y)%R (at level 70, no associativity) : R_scope.

Open Scope nat_scope.
Open Scope R_scope.

(* TODO: the below definition doesn't work very nicely *)
Notation "x ↦ y" := (fun x => y) (at level 0).

Notation "'ℕ'" := (nat).
Notation "'ℝ'" := (R).

(** Add field and lra to tactics to try automatically *)

Hint Extern 3 ( _ = _ ) => field : real.
Hint Extern 3 ( _ <= _ ) => lra : real.
Hint Extern 3 ( _ >= _ ) => lra : real.
Hint Extern 3 ( _ < _ ) => lra : real.
Hint Extern 3 ( _ > _ ) => lra : real.

Ltac wp_power :=
  timeout 5 (first [ solve [auto with *]
        | solve [eauto with *]
        | solve [firstorder (auto with *)]
        | solve [firstorder (eauto with *)]]).

Ltac intro_strict s t :=
  match goal with
    | [ |- forall _ : t, _ ] => intro s
  end.

Tactic Notation "Take" ident(s) ":" constr(t):=
  intro_strict s t.

Ltac assume_strict s t :=
  match goal with
    | [ |- ?u -> _ ] => (change u with t; intro s)
  end.

Tactic Notation "Assume" ident(s) :=
  intro s.

Tactic Notation "Assume" ident(s) ":" constr(t) :=
  assume_strict s t.

Ltac goal_check t :=
  tryif (change t)
    then (idtac "We indeed need to show that" t)
    else fail "This is not the current goal".

(** Make it possible to verify the goal t by writing
    "We need to show that t". *)
Tactic Notation "We" "need" "to" "show" "that" constr(t) :=
  goal_check t.

(** Make it possible to verify the goal t by writing
    "To show : t". *)
Tactic Notation "To" "show" ":" constr(t) :=
  goal_check t.

(** The tactic (hypo_check s t) checks if t is one of the
    current hypothesis, and if so, it renames it into s *)
Ltac hypo_check s t:=
match goal with
| [H : t |- _] => rename H into s
| _ => fail
end.

Tactic Notation "Choose" constr(t):=
  exists t.

Tactic Notation "Choose" ident(s) ":=" constr(t) :=
  pose (s := t);
  exists s.

Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" constr(v) (*":" constr(t)*):=
  destruct v as [s u].

(*Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" ident(v)
                "with" constr(t) :=
  destruct v with t as [s u]. *)

Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" constr(v)
                "with" constr(t) :=
  destruct v with t as [s u].

Tactic Notation "Because" ident(s)
  "both" ident(u) "and" ident(v) :=
  destruct s as [u v].

Tactic Notation "Because" ident(s)
  "both" ident(u) ":" constr(t_u)
  "and"  ident(v) ":" constr(t_v):=
  destruct s as [u v].

Tactic Notation "Because" ident(s)
  "either" ident(u) "or" ident(v) :=
  destruct s as [u | v].

(** Apply with goal check
    The next tactics verify whether certain steps have the desired effect. *)
Ltac new_goal_verified_apply s t :=
  apply s;
  match goal with
  | [|- t] => idtac "Expected goal was produced"
  | _ => fail "Lemma did not produce expected outcome"
  end.

(*Tactic Notation "By" constr(s)
  "it" "suffices" "to" "show" "that"
  constr(t) :=
  new_goal_verified_apply s t.*)

(** A powerful forward reasoning tactic.
    The sequential trying of auto and eauto
    is there because eauto can be much slower.
    TODO: is this what we want? *)
Ltac new_hyp_verified_pose_proof s t u:=
  assert (u : t) by timeout 5 (first [ solve [auto using s with *]
                          | solve [eauto using s with *]
                          | solve [firstorder using s]
                          | solve [firstorder (eauto with *) using s]
                          | idtac "Waterproof could not find a proof. If you believe the statement should hold, try making a smaller step"]).

Tactic Notation "By" constr(s)
  "it" "holds" "that" constr(t) "("ident(u)")"
  := new_hyp_verified_pose_proof s t u.

(*Tactic Notation "By" constr(s0) "," constr(s1)
  "it" "holds" "that" constr(t) "("ident(u)")"
  :=*)

(* TODO: align syntax with "By ... it holds that" *)
Tactic Notation "It" "holds" "that"
  constr(t) "(" ident(u) ")" :=
  assert (u : t) by first [ wp_power
                          | idtac "Waterproof could not find a proof. If you believe the statement should hold, try making a smaller step"].

Ltac conclude_proof t :=
  match goal with
  | [|-t] => idtac
  | _ => (idtac "Warning: The statement you provided does not exactly correspond to the current goal. This can make your proof less readable."; change t || fail "The provided statement cannot be converted to the current goal. If you are trying to prove an intermediate step, add a name to your hypothesis between brackets at the end of the sentence.")
  end; first [wp_power | fail "Waterproof could not find a proof. Try making a smaller step."].

Tactic Notation "It" "holds" "that" constr(t) :=
  conclude_proof t.

Tactic Notation "It" "follows" "that" constr(t) :=
  conclude_proof t.

Tactic Notation "It" "suffices" "to" "show" "that"
  constr(t) :=
  enough t by ( wp_power || fail "Waterproof could not confirm that proving the statement would be enough.").

Tactic Notation "It" "suffices" "to" "show" "that"
  constr(t) "by" tactic(tac) :=
  enough t by tac.

Tactic Notation "Write" "goal" "using" constr(t) "as"
  constr(s) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  enough s by wp_power;
  clear u.

Tactic Notation "Write" ident(H) "using" constr(t) "as"
  constr(s) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in H;
  clear u.

Tactic Notation "This" "follows" "by" "assumption" :=
  assumption.

Tactic Notation "We" "claim" "that"
  constr(t) "(" ident(u) ")" :=
  assert (u : t).

Tactic Notation "Rewrite" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  clear u.

Tactic Notation "rewrite" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  clear u.

Tactic Notation "Rewrite" "using" constr(t) "in" ident(s):=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in s;
  clear u.

Tactic Notation "rewrite" "using" constr(t) "in" ident(s):=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in s;
  clear u.

Tactic Notation "Rewrite" "<-" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite<-u;
  clear u.

Tactic Notation "replacing" constr(s) "with" constr(t) :=
  replace s with t by wp_power.

Tactic Notation "Apply" uconstr(t) :=
  apply t.

Tactic Notation "Unfold" constr(t) :=
  unfold t.

Tactic Notation "Unfold" constr(t) "in" ident(s):=
  unfold t in s.

Tactic Notation "Expand" "the" "definition" "of" reference(t) :=
  unfold t.

Tactic Notation "Expand" "the" "definition" "of"
  reference(t) "in" ident(s) :=
  unfold t in s.

Tactic Notation "Write" ident(s) "as" constr(t) :=
  change t in s.

Ltac trans_ineq eq_or_ineq :=
  match goal with
  | [|-?x ≤ ?z] =>
    match (type of eq_or_ineq) with
    | (x ≤ ?y) => apply (Rle_trans x y z eq_or_ineq)
    | _ => idtac "not a less-than-or-equal-to inequality"
    end
  | _ => idtac "Goal is not a less-than-or-equal-to inequality."
  end.

Tactic Notation "Define" ident(u) ":=" constr(t) :=
  set (u := t).

Tactic Notation "This" "follows" "by" "reflexivity" :=
  reflexivity.

Tactic Notation "Simplify" "what" "we" "need" "to" "show" :=
  simpl.

Hint Resolve Rmult_gt_0_compat : real.
Hint Resolve Rmult_lt_0_compat : real.

Ltac contra :=
  match goal with
  | [|- ?X] => destruct (classic X); try assumption
  | _ => idtac "failure of tactic"
  end.

Tactic Notation "We" "argue" "by" "contradiction" :=
  contra.

Tactic Notation "Contradiction" := contradiction.

Hint Resolve not_all_not_ex : contra_hints.
Hint Resolve not_all_ex_not : contra_hints.
Hint Resolve not_ex_all_not : contra_hints.
Hint Resolve ex_not_not_all : contra_hints.
Hint Resolve all_not_not_ex : contra_hints.
End WP_library.

Import WP_library.
(********* own notations *************)
Module Notations.

Notation "'subset' U" :=
  (Ensemble U) (at level 50).

Notation "'setOfSubsets' U" :=
  (Ensemble (subset U)) (at level 50).

Variable U : Type.

Definition empty {U} := Empty_set U.
Definition full {U} := Full_set U.
Notation "∅" :=
  (empty).

Notation "'Ω'" :=
  (full) (at level 0).

(*
Notation "∅" := (Empty_set U).
Notation "'Ω'" := (Full_set U) (at level 0).
*)
Notation "A ∩ B" :=
  (Intersection _ A B) (at level 50).

Notation "A ∪ B" :=
  (Union _ A B) (at level 50).

Notation "A \ B" :=
  (Setminus _ A B) (at level 50).

Notation "x ∈ A" :=
  (In _ A x) (at level 55).

Notation "x ∉ A" :=
  (¬ In _ A x) (at level 55).

Notation "A ⊂ B" :=
  (Included _ A B) (at level 50).

Notation "A 'and' B 'are' 'disjoint'" :=
  (Disjoint _ A B) (at level 50).

Notation "C 'is' 'a' 'disjoint' 'sequence'" :=
  (∀ m n : ℕ, m ≠ n ⇒ (C m) and (C n) are disjoint) (at level 50).

Notation "｛ x : T | P ｝" :=
  (fun (x : T) ↦ P) (x at level 99).

Tactic Notation "We" "prove" "equality" "by" "proving" "two" "inclusions" :=
   apply Extensionality_Ensembles;
   unfold Same_set;
   unfold Included;
   split.

Tactic Notation "We" "prove" "by" "induction" "on" ident(x) :=
  induction x.
(*Not nicest formulation, but 'Proof' is already taken*)

(* horrible notation, just to test and probably to be
   replaced. Problem is that
  writing 'By ... it holds that ... (name)' does not
  conclude the proof.
*)
Tactic Notation "By" constr(u) "it" "holds" "that" constr(t) "which" "concludes" ident(the) "proof":=
  By u it holds that t (the);
  apply the.
Ltac intros_strict x y t :=
  match goal with
    | [ |- forall _ _ : t, _] => intros x y
  end.

Tactic Notation "Take" ident(x) ident(y) ":" constr(t):=
  intros_strict x y t.
(*
Tactic Notation "Let" ident(A) "be" "a" "set" :=
  Take A : (subset U).

Tactic Notation "Let" ident(F) "be" "a" "set" "of" "sets" :=
  Take F : (setOfSubsets U).
*)
Hint Resolve Full_intro : measure_theory.  (*nieuwe database measure theory*)
Hint Resolve Intersection_intro : measure_theory.
Hint Resolve Union_introl Union_intror : measure_theory.
Hint Resolve Disjoint_intro : measure_theory.
End Notations.
Import Notations.

Module definitions.
Variable U : Type.

(*
Notation "∅" := (Empty_set U).
Notation "'Ω'" := (Full_set U) (at level 0).
*)
Definition is_π_system {U} (Π : setOfSubsets U)
  : Prop :=
    ∀ A : subset U, A ∈ Π ⇒
      ∀ B : subset U, B ∈ Π ⇒
         (A ∩ B) ∈ Π.

Notation "A is_a_π-system" :=
  (is_π_system A) (at level 50).

Definition Countable_union {U} (A : (ℕ → subset U) )
  : subset U :=
    ｛ x : U | ∃ n : ℕ, x ∈ (A n)｝.

Definition full_set_in_set {U} (Λ : setOfSubsets U)
  : Prop :=
    Ω (*Full_set U*) ∈ Λ.

Definition complement_in_set {U} (Λ : setOfSubsets U)
  : Prop :=
    ∀ A  : subset U, A ∈ Λ
      ⇒ (Ω \ A) ∈ Λ.

Definition closed_under_disjoint_countable_union {U} (Λ : setOfSubsets U)
  : Prop :=
    ∀ C : (ℕ → (subset U)),
      (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (C m) (C n))
        ⇒ (∀ n : ℕ, (C n) ∈ Λ) ⇒  (Countable_union C) ∈ Λ.

Definition closed_under_countable_union {U} (Λ : setOfSubsets U)
  : Prop :=
    ∀ C : (ℕ → (subset U)), (∀ n : ℕ, (C n) ∈ Λ)
      ⇒ (Countable_union C) ∈ Λ.

Definition is_λ_system {U} (Λ : setOfSubsets U)
  : Prop :=
    full_set_in_set Λ ∧
    complement_in_set Λ ∧
    closed_under_disjoint_countable_union Λ.

Notation "A is_a_λ-system" :=
  (is_λ_system A) (at level 50).

Definition is_σ_algebra {U} (F : setOfSubsets U)
  : Prop :=
    full_set_in_set F ∧
    complement_in_set F ∧
    closed_under_countable_union F.

Inductive σ_algebra : setOfSubsets U :=
  | σ_alg_omeg : full_set_in_set σ_algebra
  | σ_alg_comp : complement_in_set σ_algebra
  | σ_alg_cuCU : closed_under_countable_union σ_algebra.

Notation "A is_a_σ-algebra" :=
  (is_σ_algebra A) (at level 50).

Definition  σ_algebra_generated_by {U} (A : setOfSubsets U)
  : (setOfSubsets U) :=
    ｛B : subset U | ∀ F : setOfSubsets U, F is_a_σ-algebra ⇒ (A ⊂ F ⇒ B ∈ F)｝.

Notation "σ( A )" :=
 (σ_algebra_generated_by A) (at level 50).

Definition restriction {U} (F : setOfSubsets U) (A : (subset U))
  : (setOfSubsets U) :=
    ｛C : subset U | ∃B : subset U, B ∈ F ⇒ C = A ∩ B｝.

(* ≤ only works for Reals *)
Definition finite_union {U} (C : (ℕ ⇨ subset U) ) (n : ℕ)
  : subset U :=
    ｛x:U | (∃i : ℕ,  ((i ≤ n)%nat ∧ x ∈ (C i)))｝.

Definition finite_union_up_to {U} (C : (ℕ ⇨ subset U) ) (n : ℕ)
  : (subset U) :=
    ｛x : U | (∃i : ℕ,  ((i < n)%nat ∧ x ∈ (C i)))｝.

Definition disjoint_seq {U} (C : (ℕ ⇨ subset U) )
  : (ℕ ⇨ subset U)  :=
    fun (n:ℕ) ↦ (C n \ (finite_union_up_to C n)).

End definitions.

Import definitions.

Module set_lemmas.
(*first some definitions: *)
Fixpoint aux_seq {U : Type} (A B : subset U) (n : ℕ) {struct n}
  : (subset U) :=
    match n with
      0 => A
    | 1 => B
    | n => ∅
    end.

Section lemmas.
Variable U : Type.
(*
Notation "∅" :=
  (Empty_set U).

Notation "'Ω'" :=
  (Full_set U) (at level 0).
*)
Lemma intersection_empty : ∀A : subset U,
  (A ∩ ∅) = ∅.

Proof.
Take A : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_intersection.
destruct x_in_intersection.
Contradiction.

Take x : U; Assume x_in_empty.
Contradiction.
Qed.

Lemma empty_disjoint : ∀A : subset U,
  Disjoint _ A ∅.

Proof.
Take A : (subset U).
It suffices to show that (∀ x:U, x ∉ (A ∩ ∅)).
Take x : U.
By intersection_empty it holds that
  ((A ∩ ∅) = ∅) (int_empty).
Write goal using ((A ∩ ∅) = ∅) as (x ∉ ∅).
It holds that (x ∉ ∅).
Qed.

Lemma neq_equiv : ∀ x y : ℕ,
  (x ≠ y) ⇒ ((x < y)%nat ∨ (y < x)%nat).

Proof.
intros x y. omega.
Qed.

Lemma leq_equiv : ∀ x y : ℕ,
  (x ≤ y)%nat ⇒ ((x < y)%nat ∨ x = y).

Proof.
intros x y. omega.
Qed.

Lemma geq_equiv : ∀ x y : ℕ,
  (x ≥ y)%nat ⇒ (x = y ∨ (x > y)%nat).

Proof.
intros x y. omega.
Qed.

Lemma l_equiv : ∀ x y : ℕ,
  (x < y)%nat ⇒ (x = (y - 1)%nat ∨ (x < y - 1)%nat).

Proof.
intros x y. omega.
Qed.

Lemma union_to_or :
  ∀ A B : (subset U), ∀ x : U,
    x ∈ (A ∪ B) ⇒ (x ∈ A ∨ x ∈ B).

Proof.
Take A B : (subset U).
Take x : U; Assume x_in_union.
destruct x_in_union.
(* x ∈ A: *)
It follows that (x ∈ A ∨ x ∈ B).
(* x ∈ B: *)
It follows that (x ∈ A ∨ x ∈ B).
Qed.

Lemma intersection_symmetric :
  ∀ A B : subset U, A ∩ B = B ∩ A.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_AB.
destruct x_in_AB.
It holds that (x ∈ (B ∩ A)).

Take x : U; Assume x_in_BA.
destruct x_in_BA.
It holds that (x ∈ (A ∩ B)).
Qed.

Lemma disjoint_symmetric :
  ∀ A B : subset U, (Disjoint _ A B) ⇒ (Disjoint _ B A).

Proof.
Take A B : (subset U).
Assume A_B_disjoint.
destruct A_B_disjoint.
By intersection_symmetric it holds that
  ((A ∩ B) = (B ∩ A)) (AB_is_BA).
Write H using ((A ∩ B) = (B ∩ A))
  as (∀ x : U, x ∉ (B ∩ A)).
It follows that (Disjoint U B A).
Qed.
(*include last two in library? Should be trivial. *)

Lemma FU_up_to_0_empty :
  ∀ C : (ℕ ⇨ subset U) , finite_union_up_to C 0 = ∅.

Proof.
Take C : (ℕ ⇨ subset U) .
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU_0.
Write x_in_FU_0 as
  (x ∈ ｛x : U | ∃ i : ℕ , (i < 0)%nat ∧ x ∈ C i｝).
It holds that (¬(∃i : ℕ, (i<0)%nat ∧ x ∈ C i)) (no_N_l_0).
Contradiction.

Take x : U; Assume x_in_empty.
Contradiction.
Qed.

Lemma disj_seq_disjoint :
  ∀ C : (ℕ ⇨ subset U) ,
    (∀ m n : ℕ, m ≠ n ⇒ Disjoint _
      (disjoint_seq C m) (disjoint_seq C n)).

Proof.
Take C : (ℕ ⇨ subset U) .
Take m n : ℕ.
Assume m_neq_n.
By neq_equiv it holds that
  (m ≠ n ⇒ (m < n)%nat ∨ (m > n)%nat) (m_l_g_n).
It holds that ((m < n)%nat ∨ (m > n)%nat) (m_lg_n).
We argue by contradiction.
It holds that (∃ x: U,
  x ∈ ((disjoint_seq C m) ∩ (disjoint_seq C n))) (int_not_empty).
Choose x such that x_in_int according to int_not_empty.
By x_in_int it holds that
  (x ∈ disjoint_seq C m
    ∧ x ∈ disjoint_seq C n) (x_in_m_and_n).
By x_in_m_and_n it holds that
  (x ∈ disjoint_seq C m) (x_in_m).
By x_in_m_and_n it holds that
  (x ∈ disjoint_seq C n) (x_in_n).
It holds that
  ((x ∉ finite_union_up_to C m)
    ∧ (x ∉ finite_union_up_to C m)) (x_not_in_FU_mn).
It holds that
  (¬(∃i : ℕ,  ((i < m)%nat ∧ x ∈ (C i)))
    ∧ ¬(∃i : ℕ,  ((i < n)%nat ∧ x ∈ (C i)))) (no_i).
Because no_i both no_i_m and no_i_n.
Because m_lg_n either m_l_n or m_g_n.
(* m < n: *)
By no_i_m it holds that ((x ∉  C m)) (x_not_in_Cm).
By x_in_m it holds that (x ∈ C m) (x_in_Cm).
Contradiction.
(* m > n: *)
By no_i_n it holds that ((x ∉ C n)) (x_not_in_Cn).
By x_in_m it holds that (x ∈ C n) (x_in_Cn).
Contradiction.
Qed.

Lemma CU_sets_disjointsets_equal :
  ∀ C : (ℕ ⇨ subset U) ,
    Countable_union (disjoint_seq C) = Countable_union C.

Proof.
Take C : (ℕ ⇨ subset U) .
Define D := (disjoint_seq C).
We prove equality by proving two inclusions.

(* CU disjoint sets in CU C: *)
Take x : U; Assume x_in_CU_D.
It holds that (x ∈ Countable_union C).

(* CU C in CU disjoint sets: *)
Take x : U; Assume x_in_CU_C.
(*now choose minimal n such that x is in disj_C n*)
Choose n such that x_in_C_n according to x_in_CU_C.
Define aux_prop := (fun (n : ℕ) ↦ (x ∈ C n)).
By classic it holds that
  (∀ n, aux_prop n ∨ ¬aux_prop n) (aux_prop_decidable).
By dec_inh_nat_subset_has_unique_least_element it holds that
  (has_unique_least_element le aux_prop) (exists_least_n).
Choose n1 such that x_in_C_minimal_n according to exists_least_n.

It holds that (x ∈ Countable_union D).
Qed.

Lemma complement_as_intersection :
  ∀ A B : subset U,
    A \ B = (Ω \ B) ∩ A.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.

Take x : U.
Assume x_in_A_without_B.
It holds that (x ∈ ((Ω \ B) ∩ A)).

Take x : U.
Assume x_in_rhs.
By x_in_rhs it holds that
  (x ∈ (Ω \ B) ∧ (x ∈ A)) (x_in_A_and_comp_B).
It holds that (x ∈ (A \ B)).
Qed.

Lemma complements_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ∧ F is_a_λ-system
    ⇒ ∀ A B : subset U, A ∈ F ∧ B ∈ F
      ⇒ A \ B ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_and_λ_system.
By F_is_π_and_λ_system
  it holds that (F is_a_π-system) (F_is_π_system).
By F_is_π_and_λ_system
  it holds that (F is_a_λ-system) (F_is_λ_system).
Take A B : (subset U).
Assume A_and_B_in_F.
By F_is_λ_system it holds that
  (Ω \ B ∈ F) (comp_B_in_F).
By F_is_π_system it holds that
  (A ∩ (Ω \ B) ∈ F) (set_in_F).
By complement_as_intersection it holds that
  (A \ B = (Ω \ B) ∩ A) (set_is_complement).
Write goal using (A \ B = ((Ω \ B) ∩ A))
  as (((Ω \ B) ∩ A) ∈ F).
It holds that (((Ω \ B) ∩ A) ∈ F).
Qed.

Lemma union_as_complements :
  ∀ A B : subset U,
    (A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B))).

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_union.
By union_to_or it holds that
  (x ∈ A ∨ x ∈ B) (x_in_A_or_B).
By classic it holds that
  (¬((x ∉ A) ∧ (x ∉ B))) (not_not_A_and_not_B).
By not_not_A_and_not_B it holds that
  (¬(x ∈ (Ω \ A) ∧ x ∈ (Ω \ B))) (not_compA_and_compB).
By not_compA_and_compB it holds that
  (x ∉ ((Ω \ A) ∩ (Ω \ B))) (not_compA_int_compB).
It holds that (x ∈ (Ω \ ((Ω \ A) ∩ (Ω \ B)))).

Take x : U; Assume x_in_comp.
We argue by contradiction.
By union_to_or it holds that (¬ (x ∈ A ∨ x ∈ B)) (not_A_or_B).

It holds that
  (x ∉ ((Ω \ A) ∩ (Ω \ B))) (not_compA_int_compB).
By not_compA_int_compB it holds that
  (¬(x ∈ (Ω \ A) ∧ x ∈ (Ω \ B))) (not_compA_and_compB).
By not_compA_and_compB it holds that
  (¬((x ∉ A) ∧ (x ∉ B))) (not_not_A_and_not_B).
By not_not_A_and_not_B it holds that
  ((x ∈ A ∨ x ∈ B)) (A_or_B).
Contradiction.
Qed.

Lemma unions_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ⇒ F is_a_λ-system
    ⇒ ∀ A B : subset U, A ∈ F ⇒ B ∈ F
      ⇒ A ∪ B ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_system; Assume F_is_λ_system.
Take A B : (subset U).
Assume A_in_F; Assume B_in_F.

By union_as_complements it holds that
  ((A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B)))) (union_is_comp).
Write goal using
  ((A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B))))
    as ((Ω \ ((Ω \ A) ∩ (Ω \ B))) ∈ F).
By F_is_λ_system it holds that
  ((Ω \ A) ∈ F) (comp_A_in_F).
By F_is_λ_system it holds that
  ((Ω \ B) ∈ F) (comp_B_in_F).
By F_is_π_system it holds that
  ((Ω \ A) ∩ (Ω \ B) ∈ F) (int_in_F).
It holds that ((Ω \ ((Ω \ A) ∩ (Ω \ B))) ∈ F).
Qed.

Check ∅.
(*
Record emptyset {V : Type} := make_emptyset {
  und_set :  subset V; proof_is_empty : und_set = @empty V}.
Check und_set.
Coercion und_set : emptyset >-> Ensemble.

Definition test {V : Type} (A : emptyset) := Empty_set V.
Hint Resolve (∅ = Empty_set U) : sets.
*)

Lemma complement_full_is_empty :
  @empty U = (Ω \ Ω).

Proof.
We prove equality by proving two inclusions.
Take x : U; Assume x_in_empty.
Contradiction.

Take x : U; Assume x_in_complement_full.
Because x_in_complement_full
  both x_in_full and not_x_in_full.
Contradiction.
Qed.

Lemma empty_in_λ :
  ∀ F : setOfSubsets U,
    F is_a_λ-system ⇒ ∅ ∈ F.

Proof.
Take F : (setOfSubsets U); Assume F_is_λ_system.
By complement_full_is_empty it holds that
  (@empty U = (Ω \ Ω)) (comp_full_empty).
Write goal using (@empty U = (Ω \ Ω)) as ((Ω \ Ω) ∈ F).
It holds that ((Ω \ Ω) ∈ F).
Qed.

Lemma FU_S_as_union :
  ∀ C : (ℕ → (subset U)), ∀ n : ℕ,
    finite_union_up_to C (S n)
      = (finite_union_up_to C n) ∪ (C n).

Proof.
Take C : (ℕ → (subset U)).
Take n : ℕ.
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU_S.
Choose n0 such that x_in_C_n0 according to x_in_FU_S.
It holds that ((n0 ≤ n)%nat) (n0_le_n). (*avoid %nat? *)
By leq_equiv it holds that
  ((n0 < n)%nat ∨ n0 = n) (n0_l_e_n).
Because  n0_l_e_n either n0_l_n or n0_is_n.
(*n0 < n*)
It holds that (x ∈ (finite_union_up_to C n)) (x_in_FU).
It holds that (x ∈ (finite_union_up_to C n ∪ C n)).
(*n0 = n*)
Write goal using (n = n0) as
  (x ∈ (finite_union_up_to C n0 ∪ C n0)).
It holds that (x ∈ C n0) (x_in_Cn0).
It holds that ( x ∈ (finite_union_up_to C n0 ∪ C n0)).

Take x : U; Assume x_in_FU_with_Cn.
By union_to_or it holds that
  ((x ∈ (finite_union_up_to C n)) ∨ (x ∈ C n)) (x_in_FU_or_Cn).
It holds that (x ∈ finite_union_up_to C (S n)).
Qed.

Lemma FU_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ⇒ F is_a_λ-system
    ⇒ ∀ C : (ℕ → (subset U)), (∀ n : ℕ, (C n) ∈ F)
      ⇒ ∀ n : ℕ, (finite_union_up_to C n) ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_system.
Assume F_is_λ_system.
Take C : (ℕ ⇨ subset U).
Assume all_Cn_in_F.
Take n : ℕ.
We prove by induction on n.
(* Base case: *)
By FU_up_to_0_empty it holds that
  (finite_union_up_to C 0 = ∅) (FU0_is_empty).
Write goal using (finite_union_up_to C 0 = ∅)
  as (∅ ∈ F).
Apply empty_in_λ; Apply F_is_λ_system.
(* Induction step: *)
By FU_S_as_union it holds that
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n)) (FU_union).
Write goal using
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n))
      as ((finite_union_up_to C n) ∪ (C n) ∈ F).
By all_Cn_in_F it holds that (C n ∈ F) (Cn_in_F).
By unions_in_π_and_λ it holds that
  ((finite_union_up_to C n ∪ C n) ∈ F) which concludes the proof.

Qed.

Lemma CU_aux_is_union :
  ∀ A B : subset U, Countable_union (aux_seq A B) = A ∪ B.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_CU.
Choose n such that x_in_C_n according to x_in_CU.
We prove by induction on n.
It holds that (x ∈ (A ∪ B)).
We prove by induction on n.
It holds that (x ∈ (A ∪ B)).

(* Write x_in_C_n as (x ∈ ∅).  *)
Contradiction.

Take x : U; Assume x_in_intersection.
destruct x_in_intersection.
It holds that (x ∈ aux_seq A B 0) (x_in_aux0).
We need to show that
  (x ∈ ｛x0 : U | ∃ n : ℕ, x0 ∈ aux_seq A B n｝).
It holds that (∃ n : ℕ, x ∈ aux_seq A B n) (exists_n_A).
It follows that (x ∈ Countable_union (aux_seq A B)).

It holds that (x ∈ aux_seq A B 1) (x_in_aux0).
We need to show that
  (x ∈ ｛x0 : U | ∃ n : ℕ, x0 ∈ aux_seq A B n｝).
It holds that (∃ n : ℕ, x ∈ aux_seq A B n) (exists_n_B).
It follows that (x ∈ Countable_union (aux_seq A B)).
Qed.

Lemma disjoint_aux :
  ∀ A B : subset U, (Disjoint _ A B)
    ⇒ (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (aux_seq A B m) (aux_seq A B n)).

Proof.
Take A B : (subset U).
Assume A_B_disjoint.
Take m n : ℕ.
Assume m_neq_n.
We prove by induction on m.
We prove by induction on n.
(*Case m = n = 0:*)
Contradiction.
(*Case m=0, n=1:*)
We prove by induction on n.
Write goal using (aux_seq A B 1 = B) as (Disjoint U (aux_seq A B 0) B).
Write goal using (aux_seq A B 0 = A) as (Disjoint U A B).
It holds that (Disjoint U A B).
(*Case m=0, n>1*)
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (Disjoint U (aux_seq A B 0) ∅).
By empty_disjoint it holds that
  (Disjoint U (aux_seq A B 0) ∅) which concludes the proof.

(*Case m =1, n=0: *)
We prove by induction on m.
We prove by induction on n.
Write goal using (aux_seq A B 1 = B)
  as (Disjoint U B (aux_seq A B 0)).
Write goal using (aux_seq A B 0 = A)
  as (Disjoint U B A).
By disjoint_symmetric it holds that
  ((Disjoint _ B A)) which concludes the proof.

(*Case m=n=1: *)
We prove by induction on n.
Contradiction.
(*Case m=1, n>1: *)
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (Disjoint U (aux_seq A B 1) ∅).
By empty_disjoint it holds that
  (Disjoint U (aux_seq A B 1) ∅) which concludes the proof.

(*Case m>n: *)
Write goal using (aux_seq A B (S (S m)) = ∅)
  as (Disjoint U ∅ (aux_seq A B n)).
By disjoint_symmetric it holds that
  (Disjoint U (aux_seq A B n) ∅
    ⇒ Disjoint U ∅ (aux_seq A B n)) (disj_symm).
It suffices to show that (Disjoint U (aux_seq A B n) ∅).
Apply empty_disjoint.
Qed.
End lemmas.
End set_lemmas.
(***********************************************************)
Import set_lemmas.

Module proofs.
Require Import Reals.

Variable U : Type.
Variable F : setOfSubsets U.
Variable μ : (subset U ⇨ ℝ).
(*Definition σ_algebras := (sig (is_σ_algebra)). *)
Notation "'Σ' Cn 'equals' x" :=
  (infinite_sum Cn x) (at level 50).

Notation "'Σ' 'of' Cn 'up' 'to' n" :=
  (sum_f_R0 Cn n) (at level 50).

Notation "an 'converges' 'to' a" :=
  (Un_cv an a) (at level 50).

(*
Definition σ_algebra1 := sig is_σ_algebra.
Variable F : σ_algebra1.
Definition myclass :=  Ensemble (Ensemble U).
Definition myprojection : (σ_algebra1 -> myclass) := (@proj1_sig myclass is_σ_algebra).
Coercion myprojection : σ_algebra1 >-> myclass.
*)
Definition σ_additive_on F μ : Prop :=
  ∀ C : (ℕ → (subset U)), (∀ n : ℕ, C n ∈ F)
    ⇒ (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (C m) (C n))
      ⇒ Σ (fun (n:ℕ) ↦ (μ (C n))) equals (μ (Countable_union C)).
(*infinite_sum fn l is the proposition 'the sum of all terms of fn converges to l'*)

Notation "μ is_σ-additive_on F" :=
  (σ_additive_on F μ) (at level 50).

Notation "｜ x - y ｜" := (R_dist x y) (at level 20).

Definition is_measure_on F μ : Prop :=
  is_σ_algebra F ∧ μ ∅ = 0 ∧ μ is_σ-additive_on F.

Definition is_probability_measure_on (F : setOfSubsets U) (μ : (subset U → ℝ))
  : Prop :=
    is_measure_on F μ ∧ μ Ω = 1.

Notation "C 'is' 'an' 'increasing' 'sequence' 'of' 'sets'" (* (C : (ℕ → (subset U)))
  : Prop*) :=
    (∀n : ℕ, (C n) ⊂ C (S n)) (at level 50).

Lemma increasing_seq_mn :
     ∀ C : (ℕ → (subset U)),
      C is an increasing sequence of sets
        ⇒ (∀m n : ℕ, (m ≤ n)%nat
          ⇒ C m ⊂ C n).

Proof.
Take C : (ℕ ⇨ subset U).
Assume C_is_increasing.
Take m n : ℕ; Assume m_le_n.
induction n.
It holds that ((m = 0)%nat) (m0).
Write goal using ((m = 0)%nat)
  as (C 0%nat ⊂ C 0%nat).
It holds that (C 0%nat ⊂ C 0%nat).
By leq_equiv it holds that
  (((m < (S n))%nat ∨ m = (S n))) (m_l_eq_Sn).
Because m_l_eq_Sn either m_l_Sn or m_eq_Sn.
By IHn it holds that
  (C m ⊂ C n) (Cm_subs_Cn).
By C_is_increasing it holds that
  (C n ⊂ C (S n)) (Cn_subs_CSn).
It follows that (C m ⊂ C (S n)).

Write goal using (m = S n)
  as (C (S n) ⊂ C (S n)).
It holds that (C (S n) ⊂ C (S n)).
Qed.

Check complement_full_is_empty.
Check ∅.

Lemma empty_in_σ :
  F is_a_σ-algebra ⇒ ∅ ∈ F.

Proof.
Assume F_is_σ_algebra.
By complement_full_is_empty it holds that
  (@empty U = (Ω \ Ω)) (comp_full_empty).
Write goal using (@empty U = (Ω \ Ω)) as ((Ω \ Ω) ∈ F).
It holds that ((Ω \ Ω) ∈ F).
Qed.

Lemma unions_in_σ :
  F is_a_σ-algebra
    ⇒  ∀ A B : subset U, A ∈ F ∧ B ∈ F
      ⇒ A ∪ B ∈ F.

Proof.
Assume F_is_σ_algebra.
Take A B : (subset U).
Assume A_and_B_in_F.

We claim that (∀ n : ℕ, aux_seq A B n ∈ F) (all_aux_in_F).
Take n : ℕ.
We prove by induction on n.
It holds that (aux_seq A B 0 ∈ F).
We prove by induction on n. (*0 and 1 defined, rest inductively. Other way? *)
It holds that (aux_seq A B 1 ∈ F).
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (∅ ∈ F).
By empty_in_σ it holds that
  (∅ ∈ F) (empty_in_F).
Apply empty_in_F.

By CU_aux_is_union it holds that
  (A ∪ B = Countable_union (aux_seq A B)) (union_to_CU).
Write goal using (A ∪ B = Countable_union (aux_seq A B))
  as (Countable_union (aux_seq A B) ∈ F).
It holds that (Countable_union (aux_seq A B) ∈ F).
Qed.

Lemma FU_in_sigma :
  F is_a_σ-algebra
    ⇒ ∀ C : (ℕ → (subset U)), (∀ n : ℕ, (C n) ∈ F)
      ⇒ ∀ n : ℕ, (finite_union_up_to C n) ∈ F.

Proof.
Assume F_is_σ.
Take C : (ℕ ⇨ subset U).
Assume all_Cn_in_F.
Take n : ℕ.
We prove by induction on n.
(* Base case: *)
By FU_up_to_0_empty it holds that
  (finite_union_up_to C 0 = ∅) (FU0_is_empty).
Write goal using (finite_union_up_to C 0 = ∅)
  as (∅ ∈ F).
Apply empty_in_σ; Apply F_is_σ.
(* Induction step: *)
By FU_S_as_union it holds that
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n)) (FU_union).
Write goal using
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n))
      as ((finite_union_up_to C n) ∪ (C n) ∈ F).
By all_Cn_in_F it holds that (C n ∈ F) (Cn_in_F).
By unions_in_σ it holds that
  ((finite_union_up_to C n ∪ C n) ∈ F) (xx); Apply xx.
Qed.

Lemma aux_additive :
  is_measure_on F μ
    ⇒ ∀ A B : subset U, A ∈ F ⇒ B ∈ F
      ⇒ Disjoint _ A B
         ⇒ (infinite_sum (fun (n:ℕ) ↦ (μ ((aux_seq A B) n)))
  (μ (Countable_union (aux_seq A B)))).

Proof.
Assume μ_is_measure_on_F.
Take A B : (subset U).
Assume A_in_F; Assume B_in_F.
Assume A_B_disjoint.
Define C := (aux_seq A B).
By μ_is_measure_on_F it holds that
  (μ is_σ-additive_on F) (add_on_F).
Apply add_on_F.
Take n : ℕ.
We prove by induction on n.
It holds that (C 0%nat ∈ F).
We prove by induction on n.
It holds that (C 1%nat ∈ F).

It holds that (C (S (S n)) = ∅) (CSS_empty).
By empty_in_σ it holds that
  (C (S (S n)) ∈ F) which concludes the proof.

By disjoint_aux it holds that
  ( ∀ m n : ℕ,
    m ≠ n ⇨ Disjoint U (C m) (C n)) which concludes the proof.

Qed.

Lemma aux_ge2_empty :
  ∀ A B : subset U, ∀ n : ℕ,
    (n > 1)%nat ⇒ aux_seq A B n = ∅.

Proof.
Take A B : (subset U).

Take n : ℕ; Assume n_g_1.
Expand the definition of aux_seq.
(*More case distinction than induction, but
  this works far better for 'Fixpoint' definitions*)
We prove by induction on n.
It holds that (¬(0 > 1)%nat) (not_0_g_1).
Contradiction.
We prove by induction on n.
It holds that (¬(1 > 1)%nat) (not_1_g_1).
Contradiction.
It holds that (@empty U = @ empty U).
Qed.

Lemma additivity_meas :
  is_measure_on F μ
    ⇒ ∀ A B : subset U, A ∈ F ⇒ B ∈ F
      ⇒ Disjoint _ A B
         ⇒ μ (A ∪ B) = μ A + μ B.

Proof.
Assume μ_is_measure_on_F.
Take A B : (subset U).
Assume A_in_F; Assume B_in_F.
Assume A_B_disjoint.
Define C := (aux_seq A B).
Define seq_μC := (fun (n:ℕ) ↦ (μ (C n))).
By CU_aux_is_union it holds that
  (A ∪ B = Countable_union C) (union_is_CU).
Write goal using (A ∪ B = Countable_union C)
  as (μ (Countable_union C) = μ A + μ B).
By aux_additive it holds that
  (infinite_sum seq_μC
    (μ (Countable_union C))) (sum_meas_is_meas_CU).

We claim that (infinite_sum seq_μC
  (μ A + μ B)) (series_is_sumAB).
We need to show that (
   ∀ ε : ℝ, ε > 0
    ⇒ ∃ N : ℕ ,
       ∀ n : ℕ, (n ≥ N)%nat
        ⇒ R_dist (Σ of seq_μC up to n) (μ A + μ B) < ε).
Take ε : R; Assume ε_g0.

We claim that ( ∀ n : ℕ, (n ≥ 1)%nat
  ⇒ R_dist (Σ of seq_μC up to n)
    (μ A + μ B) < ε) (holds_for_ge_1).
We prove by induction on n.
(* n=0: *)
It holds that (¬(0 ≥ 1)%nat) (not_0_geq_1).
Contradiction.
(* induction step *)
It holds that ((n ≥ 0)%nat) (n_geq_0).
By geq_equiv it holds that
  (n = 0%nat ∨ (n > 0)%nat) (n_0_or_n_g0).
Because n_0_or_n_g0 either n_0 or n_g0.
(* n=0: *)
It holds that (S n = 1%nat) (Sn_is_1).
Write goal using (S n = 1%nat)
  as ((1 ≥ 1)%nat
  ⇒ R_dist (Σ of seq_μC up to 1)
    (μ A + μ B) < ε).
Write goal using (Σ of seq_μC up to 1 = μ A + μ B)
  as (R_dist (μ A + μ B) (μ A + μ B) < ε).
By R_dist_eq it holds that
  (R_dist (μ A + μ B)  (μ A + μ B) = 0) (dist_is_0).
It follows that (R_dist (μ A + μ B) (μ A + μ B) < ε).
(* n>0: *)
It holds that ((n ≥ 1)%nat) (n_geq_1).
By IHn it holds that
  (R_dist (Σ of seq_μC up to n) (μ A + μ B) < ε) (dist_l_eps).
We claim that (seq_μC (S n) = 0) (µSn_0).
By aux_ge2_empty it holds that
  (C (S n) = ∅) (CSn_empty).
By μ_is_measure_on_F it holds that
  (μ ∅ = 0) (µ_empty_0).
We need to show that (μ (C (S n)) = 0).
Write goal using (C (S n) = ∅)
  as (μ ∅ = 0).
Apply µ_empty_0.

Write goal using (Σ of seq_μC up to (S n)
  = Σ of seq_μC up to n + seq_μC (S n))
    as (R_dist (Σ of seq_μC up to n + seq_μC (S n))
      (μ A + μ B) < ε).
Write goal using (seq_μC (S n) = 0)
  as (R_dist (Σ of seq_μC up to n + 0) (μ A + μ B) < ε).
Write goal using (Σ of seq_μC up to n + 0 = Σ of seq_μC up to n)
  as (R_dist (Σ of seq_μC up to n ) (μ A + μ B) < ε).
Apply dist_l_eps.

It follows that (∃ N : ℕ ,
  ∀ n : ℕ, (n ≥ N)%nat
    ⇒ R_dist (Σ of seq_μC up to n)
      (μ A + μ B) < ε).
By uniqueness_sum it holds that
  (μ (Countable_union C) = μ A + μ B) which concludes the proof.
Qed.

Lemma FU_up_to_1_is_0 :
  ∀ C : (ℕ → (subset U)),
      finite_union_up_to C 1 = C 0%nat.

Proof.
Take C : (ℕ ⇨ subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU.
destruct x_in_FU.
It holds that (x0 = 0%nat) (x0_is_0).
Write goal using (0%nat = x0)
  as (x ∈ C x0).
It holds that (x ∈ C x0).

Take x : U; Assume x_in_C0.
It holds that (x ∈ finite_union_up_to C 1).
Qed.

Lemma finite_additivity_meas :
  is_measure_on F μ
    ⇒ ∀ C : (ℕ → (subset U)), (∀n : ℕ, C n ∈ F)
      ⇒ C is a disjoint sequence
         ⇒ ∀ N : ℕ,  μ (finite_union_up_to C (S N))
          = Σ of (fun (n : ℕ) ↦ (μ (C n))) up to N.

Proof.
Assume μ_is_measure_on_F.
Take C : (ℕ ⇨ subset U).
Assume all_Cn_in_F.
Assume C_n_disjoint.
Define seq_μC := (fun (n : ℕ) ↦ μ (C n)).
Define FU_C := (finite_union_up_to C).
Take N : ℕ.
We prove by induction on N.
(* Base case: *)
By FU_up_to_1_is_0 it holds that
  (finite_union_up_to C 1 = C 0%nat) (FU1_is_C0).
Write goal using (FU_C 1%nat = C 0%nat)
  as (μ (C 0%nat) = Σ of seq_μC up to 0%nat).
It holds that (μ (C 0%nat) = Σ of seq_μC up to 0).
(*Induction step: *)
It holds that (Σ of seq_μC up to (S N)
  = Σ of seq_μC up to N + seq_μC (S N)) (sum_to_sum).
Write goal using (Σ of seq_μC up to (S N)
  = Σ of seq_μC up to N + seq_μC (S N))
    as (μ (FU_C (S (S N)))
      = Σ of seq_μC up to N + seq_μC (S N)).

By FU_S_as_union it holds that
  (FU_C (S (S N))
    = (FU_C (S N)) ∪ (C (S N))) (FU_to_union).
We claim that (Disjoint _
  (FU_C (S N)) (C (S N))) (FUSn_CSn_disj).
We argue by contradiction.
By H it holds that (∃ x : U,
  x ∈ ((FU_C (S N)) ∩ (C (S N)))) (int_not_empty).
Choose x such that x_in_int
  according to int_not_empty.
destruct x_in_int. (*how to destruct with certain names?*)
Choose n0 such that x_in_Cn
  according to H0.
It holds that (x ∈ C n0 ∧ x ∈ C (S N)) (x_in_Cn0_and_CSN).
By C_n_disjoint it holds that
  (Disjoint _ (C n0) (C (S N))) (Cn0_CSN_disj).
destruct Cn0_CSN_disj.
It holds that (x ∉ C n0 ∩ C (S N)) (not_x_in_int_Cn0_CSN).
By not_x_in_int_Cn0_CSN it holds that
  (¬ (x ∈ C n0 ∧ x ∈ C (S N))) (not_x_in_Cn0_and_CSN).
Contradiction.
(*now show: both sets in F *)
It holds that (C (S N) ∈ F) (CSN_in_F).
By FU_in_sigma it holds that
  (FU_C (S N) ∈ F) (FU_C_in_F).

By additivity_meas it holds that
  (μ ((FU_C (S N)) ∪ (C (S N)))
    = μ (FU_C (S N)) + μ (C (S N))) (muFUS_is_muFU_muS).

Write goal using (FU_C (S (S N))
  = (FU_C (S N)) ∪ (C (S N)))
    as (μ ((FU_C (S N)) ∪ (C (S N)))
      = Σ of seq_μC up to N + seq_μC (S N)).
Write goal using (μ ((FU_C (S N)) ∪ (C (S N)))
  = μ (FU_C (S N)) + μ (C (S N)))
    as (μ (FU_C (S N)) + μ (C (S N))
      = Σ of seq_μC up to N + seq_μC (S N)).
It holds that (μ (FU_C (S N)) + μ (C (S N))
  = Σ of seq_μC up to N + seq_μC (S N)).
Qed.

Lemma FUn_disj_is_Cn :
  ∀C : (ℕ → (subset U)), C is an increasing sequence of sets
    ⇒ ∀ n : ℕ, finite_union_up_to (disjoint_seq C) (S n) = C n.

Proof.
Take C : (ℕ ⇨ subset U) .
Assume C_is_incr_seq.
Define D := (disjoint_seq C).
Take n : ℕ.
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU.
Choose n0 such that x_in_Dn0 according to x_in_FU.
By x_in_Dn0 it holds that
  (x ∈ C n0) (x_in_Cn0).
(*It holds that ((n0 < n)%nat) (n0_l_n).
By l_equiv it holds that
  (n0 = (n - 1)%nat ∨ (n < n - 1)%nat) (n0_eq_l_n1).*)
By increasing_seq_mn it holds that
  (C n0 ⊂ C n) (Cn0_subs_Cn).
It follows that (x ∈ C n).

Take x : U; Assume x_in_C.
Define aux_prop := (fun (n : ℕ) ↦ (x ∈ C n)). (*n-1?*)
By classic it holds that
  (∀ n, aux_prop n ∨ ¬aux_prop n) (aux_prop_decidable).
By dec_inh_nat_subset_has_unique_least_element it holds that
  (has_unique_least_element le aux_prop) (exists_least_n).
Choose n1 such that x_in_C_minimal_n according to exists_least_n.
It holds that ( aux_prop n1
  ∧ ( ∀ n2 : ℕ, aux_prop n2
    ⇒ (n1 ≤ n2)%nat)) (aux_n1_and_n1_le_n2).
Because aux_n1_and_n1_le_n2 both aux_n1 and n1_le_n2.
It holds that (x ∈ D n1) (x_in_Dn1).
We claim that ( (n1 < S n)%nat ) (n1_l_n).
By x_in_C it holds that (aux_prop n) (aux_n_min_1).
By n1_le_n2 it holds that
  ((n1 ≤ n)%nat) (n1_leq_n_min_1).
It holds that
  ((n1 < S n)%nat).

It holds that (∃i : ℕ,
  ((i < (S n))%nat ∧ x ∈ (D i))) (exists_i).
It follows that (x ∈ finite_union_up_to D (S n)).
Qed.

Lemma intersection_to_complement :
   ∀ A B : subset U,
    A ∩ B = Ω \ ((Ω \ A) ∪ (Ω \ B)).

Proof. (*analogous to complement_as_union_intersection, could be combined? *)
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_lhs.
destruct x_in_lhs. (*"Because x_in_rhs both x_in_comp_A and x_in_B" doesn't work*)
By H it holds that (x ∉ Ω \ A) (x_not_in_A).
By H0 it holds that (x ∉ Ω \ B) (x_not_in_comp).

We claim that (x ∉ (Ω \ A) ∪ (Ω \ B)) (x_not_in_AB).
We argue by contradiction.
We claim that (x ∈ (Ω \ A) ∪ (Ω \ B)) (x_in_AB).
Apply NNPP; Apply H1.
destruct x_in_AB.
Contradiction.
Contradiction.
It follows that (x ∈ Ω \ ((Ω \ A) ∪ (Ω \ B))).

Take x : U; Assume x_in_rhs.
destruct x_in_rhs.
By H0 it holds that
  ((x ∉ Ω \ A) ∧ (x ∉ Ω \ B)) (x_not_in_int_comp).
Because x_not_in_int_comp
  both x_not_in_compA and x_not_in_compB.
We claim that (x ∈ A) (x_in_A).
We argue by contradiction.
By H1 it holds that (x ∈ Ω \ A) (x_in_compA).
Contradiction.

We claim that (x ∈ B) (x_in_B).
We argue by contradiction.
By H1 it holds that (x ∈ Ω \ B) (x_in_compB).
Contradiction.
It follows that (x ∈ A ∩ B).
Qed.

Lemma intersections_in_σ :
  F is_a_σ-algebra
    ⇒  ∀ A B : subset U, A ∈ F ∧ B ∈ F
      ⇒ A ∩ B ∈ F.

Proof.
Assume F_is_σ_algebra.
Take A B : (subset U).
Assume A_and_B_in_F.
By intersection_to_complement it holds that
  (A ∩ B = Ω \ ((Ω \ A) ∪ (Ω \ B))) (int_is_comp).
Write goal using (A ∩ B = Ω \ ((Ω \ A) ∪ (Ω \ B)))
  as (Ω \ ((Ω \ A) ∪ (Ω \ B)) ∈ F).
By unions_in_σ it holds that
 ((Ω \ A) ∪ (Ω \ B) ∈ F) (compA_compB_in_F).
It follows that (Ω \ ((Ω \ A) ∪ (Ω \ B)) ∈ F).
Qed.

Lemma complements_in_σ :
  F is_a_σ-algebra
    ⇒ ∀ A B : subset U, A ∈ F ∧ B ∈ F
      ⇒ A \ B ∈ F.

Proof.
Assume F_is_σ.
Take A B : (subset U).
Assume A_and_B_in_F.
By F_is_σ it holds that
  (Ω \ B ∈ F) (comp_B_in_F).
By intersections_in_σ it holds that
  ((Ω \ B) ∩ A ∈ F) (set_in_F).
By complement_as_intersection it holds that
  (A \ B = (Ω \ B) ∩ A) (set_is_complement).
Write goal using (A \ B = ((Ω \ B) ∩ A))
  as (((Ω \ B) ∩ A) ∈ F).
It holds that ((Ω \ B) ∩ A ∈ F).
Qed.

Lemma disj_seq_in_F :
  F is_a_σ-algebra
    ⇒ ∀C : (ℕ → (subset U)), C is an increasing sequence of sets
      ⇒ (∀ n : ℕ, C n ∈ F)
        ⇒ (∀n : ℕ, (disjoint_seq C) n ∈ F).

Proof.
Assume F_is_σ.
Take C : (ℕ ⇨ subset U) .
Assume C_is_incr_seq.
Assume all_Cn_in_F.
Define D := (disjoint_seq C).

Take n : ℕ.
We need to show that (C n \ (finite_union_up_to C n) ∈ F).
We claim that ((finite_union_up_to C n) ∈ F) (FU_in_F).
Apply FU_in_sigma.
Apply F_is_σ.
Apply all_Cn_in_F.
It holds that (C n ∈ F) (Cn_in_F).
By complements_in_σ it holds that
  (C n \ finite_union_up_to C n ∈ F) which concludes the proof.
Qed.

(*D naar D_ nog aanpassen*)
Lemma incr_cont_meas :
  is_measure_on F μ
    ⇒ ∀ C_ : (ℕ → (subset U)), C_ is an increasing sequence of sets
      ⇒ (∀ n : ℕ, C_ n ∈ F)
        ⇒ (fun (n : ℕ) ↦ (μ (C_ n))) converges
          to (μ (Countable_union C_)).
(*Un_cv Cn l is the proposition 'sequence Cn converges to limit l'*)
(*Proof using alternative sequence from pi-lambda proof; not the one in lecture notes*)
Proof.
Assume μ_is_measure_on_F.
Take C_ : (ℕ ⇨ subset U) .
Assume C_is_incr_seq.
Assume all_Cn_in_F.
Define D_ := (disjoint_seq C_).
Define D := (Countable_union D_).
Define seq_μC := (fun (n : ℕ) ↦ μ (C_ n)).
Define seq_μD := (fun (n : ℕ) ↦ μ (D_ n)).
By CU_sets_disjointsets_equal it holds that
  ((Countable_union C_) = D) (CUC_is_CUD).
Write goal using
  ((Countable_union C_) = D)
    as (seq_μC converges to (μ (D))).
By μ_is_measure_on_F it holds that
  (μ is_σ-additive_on F) (μ_is_σ_additive).
By disj_seq_disjoint it holds that
  (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (D_ m) (D_ n)) (D_disj).
By disj_seq_in_F it holds that
  (∀n : ℕ, D_ n ∈ F) (all_Dn_in_F).
By μ_is_σ_additive it holds that
  (infinite_sum seq_μD
    (μ (D))) (μDn_is_μCUD).

We need to show that (
  ∀ ε : ℝ, ε > 0
    ⇒ ∃ N : ℕ , ∀ n : ℕ,  (n ≥ N)%nat
      ⇒ R_dist (μ (C_ n)) (μ(D)) < ε).
Take ε : ℝ; Assume ε_g0.
By μDn_is_μCUD it holds that (
  ∃ N : ℕ , ∀ n : ℕ,  (n ≥ N)%nat
    ⇒ R_dist (Σ of seq_μD up to n)
     (μ D) < ε) (exists_N_μSumD_μCUD_l_ε).
Choose N such that μSumN_μCU_l_ε
  according to exists_N_μSumD_μCUD_l_ε.

It suffices to show that (∀ n : ℕ,
  (n ≥ N)%nat ⇨ R_dist (μ(C_ n))
    (μ(D)) < ε).
Take n : ℕ; Assume n_geq_N.
We claim that (μ(C_ n) =
  (Σ of seq_μD up to n) ) (μCn_is_sum_μDn).
By FUn_disj_is_Cn it holds that
  (finite_union_up_to D_ (S n) = C_ n) (FUD_is_C).
Write goal using (C_ n = finite_union_up_to D_ (S n))
  as (μ (finite_union_up_to D_ (S n))
    = Σ of seq_μD up to n).
By finite_additivity_meas it holds that
  (μ(finite_union_up_to D_ (S n))
    = Σ of (fun (n : ℕ) ↦ μ(D_ n)) up to n) (xx); Apply xx.

Write goal using (μ(C_ n) = Σ of seq_μD up to n)
  as (R_dist (Σ of seq_μD up to n)
    (μ(D)) < ε).
It holds that (R_dist (Σ of seq_μD up to n)
  (μ(D)) < ε).
Qed.

Lemma monotonicity_meas :
  ∀μ : (subset U → ℝ), is_measure_on F μ
    ⇒ ∀ A B : subset U, A ⊂ B
      ⇒ μ A ≤ μ B.

Proof.

Admitted.

Theorem uniqueness_of_prob_meas :
  ∀μ1 : (subset U → ℝ), is_measure_on F μ1
    ⇒ ∀μ2 : (subset U → ℝ), is_measure_on F μ2
      ⇒ ∀Π, Π is_a_π-system (* ⇒ Π ⊂ F *)
        ⇒ ∀ A : subset U, A ∈ Π ⇒ μ1 A = μ2 A
          ⇒ ∀ B : subset U, B ∈ (σ(Π)) ⇒ μ1 A = μ2 A.
Proof.
Admitted.


From iris.proofmode Require Import tactics.

Set Default Proof Using "Type".

Section bi.
Context {PROP:bi} `{!BiPureForall PROP}.

(* TODO: logically equivalent to say P0 a v0 -∗ P1 a v1 -∗ False (with decidable
equality on A) *)

Class ConflictsWith {L V} (P0 P1 : L -> V -> PROP) := conflicts_with :
  ∀ a0 v0 a1 v1,
    P0 a0 v0 -∗ P1 a1 v1 -∗ ⌜ a0 ≠ a1 ⌝.

Lemma big_sepM_disjoint_pred {L V} {P0 P1 : L -> V -> PROP} `{!EqDecision L} `{!Countable L} `{!BiAffine PROP}
  `{!ConflictsWith P0 P1}
  (m0 m1 : gmap L V) :
  ( ( [∗ map] a↦v ∈ m0, P0 a v ) -∗
    ( [∗ map] a↦v ∈ m1, P1 a v ) -∗
    ⌜ m0 ##ₘ m1 ⌝ ).
Proof using BiPureForall0.
  iIntros "H0 H1" (i).
  unfold option_relation.
  destruct (m0 !! i) eqn:He; destruct (m1 !! i) eqn:H1; try solve [ iPureIntro; auto ].
  iDestruct (big_sepM_lookup with "H0") as "H0"; eauto.
  iDestruct (big_sepM_lookup with "H1") as "H1"; eauto.
  iDestruct (conflicts_with with "H0 H1") as %Hcc.
  congruence.
Qed.

Class Conflicting {L V} (P: L → V → PROP) := conflicting : ConflictsWith P P.

Global Instance conflicting_conflicts_with `(P: L → V → PROP) `{H: !ConflictsWith P P} :
  Conflicting P.
Proof. exact H. Qed.

Global Instance conflicting_sep_l {L V} (P Q: L → V → PROP) `{H: !Conflicting P} :
  Conflicting (λ l v, P l v ∗ Q l v)%I.
Proof.
  iIntros (????) "[HP1 _] [HP2 _]".
  iApply (conflicting with "HP1 HP2").
Qed.

Global Instance conflicting_sep_r {L V} (P Q: L → V → PROP) `{H: !Conflicting Q} :
  Conflicting (λ l v, P l v ∗ Q l v)%I.
Proof.
  iIntros (????) "[_ HQ1] [_ HQ2]".
  iApply (conflicting with "HQ1 HQ2").
Qed.

Lemma conflicting_false `(P: L → V → PROP) `{!Conflicting P} a v0 v1 :
  P a v0 -∗ P a v1 -∗ False.
Proof.
  iIntros "H1 H2".
  iDestruct (conflicting with "H1 H2") as %Hneq.
  auto.
Qed.

End bi.


Require Import Classical.
(* Used in various places:
    - existence of a derivation in the axiomatic system for a sequent
      (should be decidable as Bi-Int is, but this would require extra work)
    - some set-theoretic arguments (maybe they can be constructivised *)

Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import Prop_Bi_Int_calcs.
Require Import Prop_Bi_Int_logics.
Require Import Prop_Bi_Int_extens_interactions.
Require Import Prop_wBi_Int_meta_interactions.
Require Import Prop_sBi_Int_meta_interactions.
Require Import Prop_Bi_Int_Kripke_sem.
Require Import Prop_Bi_Int_Lindenbaum_lem.

Definition CompNotDer (s: prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V))) : Prop :=
  (complete (fst s, snd s) /\ (wpair_derrec (fst s, snd s) -> False)).

Lemma clos_deriv : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A, wBIC_rules (Γ, A) -> (In _ Γ A)).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). destruct o.
auto. simpl in H2. exfalso. apply H1. exists [A]. repeat split.
apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H3. subst.
auto. inversion H4. simpl. apply MP with (ps:=[(Γ, Imp A (Or A (Bot V)));(Γ, A)]).
2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Bot V). auto. inversion H4. subst. 2: inversion H5.
assumption.
Qed.

Lemma primality : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) ->
                                (forall A B, (In _ Γ (Or A B))  -> ((In _ Γ A) \/ (In _ Γ B))).
Proof.
intros. destruct H. simpl in H. simpl in H1. pose (H A). pose (H B).
destruct o ; destruct o0 ; auto. simpl in H2. simpl in H3. exfalso. apply H1.
destruct (eq_dec_form A B). subst. exists [B].
repeat split. apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H4.
subst. auto. inversion H5. simpl. apply MP with (ps:=[(Γ, Imp B (Or B (Bot V)));(Γ, B)]).
2: apply MPRule_I. intros. inversion H4. subst. apply Ax. apply AxRule_I.
apply RA2_I. exists B. exists (Bot V). auto. inversion H5. 2: inversion H6. subst.
apply MP with (ps:=[(Γ,(Or B B) → B);(Γ,(Or B B))]). 2: apply MPRule_I.
intros. inversion H6. subst.
apply MP with (ps:=[(Γ,(B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H7. subst.
apply MP with (ps:=[(Γ,(B → B) → (B → B) → (Or B B) → B);(Γ,(B → B))]). 2: apply MPRule_I.
intros. inversion H8. subst. apply Ax. apply AxRule_I. apply RA4_I.
exists B. exists B. exists B. auto. inversion H9. 2: inversion H10.
subst. apply wimp_Id_gen. inversion H8. 2: inversion H9. subst. apply wimp_Id_gen.
inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
exists (A :: [B]). repeat split. apply NoDup_cons. intro. inversion H4. auto.
inversion H5. apply NoDup_cons ; auto ; apply NoDup_nil. intros.
simpl. inversion H4. subst. auto. inversion H5. subst. auto. inversion H6.
simpl. apply MP with (ps:=[(Γ, Imp (Or A B) (Or A (Or B (Bot V))));(Γ, Or A B)]).
2: apply MPRule_I. intros. inversion H4. subst.
apply MP with (ps:=[(Γ,(B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (B → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H5. subst.
apply MP with (ps:=[(Γ,(A → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))) → (Or A B → Or A (Or B (Bot V))));
(Γ, (A → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros. inversion H6. subst.
apply Ax. apply AxRule_I. apply RA4_I. exists A. exists B. exists (Or A (Or B (Bot V))).
auto. inversion H7. subst. 2: inversion H8. apply Ax. apply AxRule_I.
apply RA2_I. exists A. exists (Or B (Bot V)). auto. inversion H6. 2: inversion H7.
subst.
apply MP with (ps:=[(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, ((Or B (Bot V)) → Or A (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H7. subst.
apply MP with (ps:=[(Γ, (B → (Or B (Bot V))) → ((Or B (Bot V)) → Or A (Or B (Bot V))) → (B → Or A (Or B (Bot V))));
(Γ, (B → (Or B (Bot V))))]). 2: apply MPRule_I. intros.
inversion H8. subst. apply Ax. apply AxRule_I. apply RA1_I. exists B.
exists (Or B (Bot V)). exists (Or A (Or B (Bot V))). auto. inversion H9. subst.
2: inversion H10. apply Ax. apply AxRule_I. apply RA2_I. exists B. exists (Bot V). auto.
inversion H8. 2: inversion H9. subst. apply Ax. apply AxRule_I. apply RA3_I.
exists A. exists (Or B (Bot V)). auto. inversion H5. subst. 2: inversion H6.
apply Id. apply IdRule_I. auto.
Qed.

Lemma cp_Bot_R : forall (Γ Δ : @Ensemble (BPropF V)), CompNotDer (Γ, Δ) -> (In _ Δ (Bot V)).
Proof.
intros. destruct H. simpl in H. simpl in H0. pose (H (Bot V)). destruct o ; auto.
simpl in H1. exfalso. apply H0. exists []. repeat split. apply NoDup_nil.
intros. inversion H2. simpl. apply Id. apply IdRule_I. auto.
Qed.

Definition Canon_worlds : Type :=
  {x : prod (@Ensemble (BPropF V)) (@Ensemble (BPropF V)) | CompNotDer x}.

Definition Canon_relation (P0 P1 : Canon_worlds) : Prop :=
  Included _ (fst (proj1_sig P0)) (fst (proj1_sig P1)).

Definition Canon_valuation (P : Canon_worlds) (q : V) : Prop :=
  In _ (fst (proj1_sig P)) (# q).

Lemma C_R_refl : R_refl Canon_relation.
Proof.
unfold R_refl. intros. unfold Canon_relation.
intro. intros. assumption.
Qed.

Lemma C_R_trans : R_trans Canon_relation.
Proof.
unfold R_trans. intros. unfold Canon_relation.
intro. intros. unfold Canon_relation in H0. unfold Canon_relation in H.
apply H0. apply H. auto.
Qed.

Lemma C_R_props : (R_refl Canon_relation * R_trans Canon_relation).
Proof.
split. apply C_R_refl. apply C_R_trans.
Qed.

Lemma C_val_persist : val_persist_R _ Canon_valuation Canon_relation.
Proof.
unfold val_persist_R. intros.
unfold Canon_valuation in H0. unfold Canon_relation in H.
unfold Canon_valuation. apply H. auto.
Qed.

Lemma truth_lemma : forall A (cp : Canon_worlds),
  (wforces Canon_worlds Canon_relation C_R_props Canon_valuation C_val_persist cp A) <->
  (In _ (fst (proj1_sig cp)) A).
Proof.
induction A ; intro ; split ; intros ; destruct cp ; simpl ; try simpl in H ; auto.
(* Bot V *)
- inversion H.
- destruct x. simpl in H. unfold CompNotDer in c. destruct c. simpl in H1. apply H1.
  unfold wpair_derrec. simpl. exists []. repeat split. apply NoDup_nil. intros.
  inversion H2. simpl. apply Id. apply IdRule_I. auto.
(* Top V *)
- pose (classic (In (BPropF V) (fst x) (Top V))). destruct o. auto.
  exfalso. destruct x. simpl in H0. simpl in c. unfold CompNotDer in c.
  clear H. destruct c. simpl in H. simpl in H1. apply H1. unfold wpair_derrec.
  exists [Top V]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H2. subst. simpl. unfold complete in H. simpl in H. clear H2.
  pose (H (Top V)). destruct o. exfalso. apply H0. auto. auto. inversion H3.
  simpl. apply MP with (ps:=[(e, Imp (Top V) (Or (Top V) (Bot V))); (e, (Top V))]).
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I.
  exists (Top V). exists (Bot V). auto. inversion H3. subst.
  apply MP with (ps:=[(e, Imp (Imp (Top V) (Top V)) (Top V)); (e, Imp (Top V) (Top V))]).
  intros. inversion H4. subst. apply Ax. apply AxRule_I. apply RA15_I.
  exists (Top V → Top V). auto. inversion H5. subst. apply wimp_Id_gen. inversion H6.
  apply MPRule_I. inversion H4. apply MPRule_I.
(* And A1 A2 *)
- destruct H. apply IHA1 in H. simpl in H. apply IHA2 in H0. simpl in H0.
  apply clos_deriv with (Δ:=snd x). auto.
  apply MP with (ps:=[(fst x, A1 → (And A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H1. subst.
  apply MP with (ps:=[(fst x, (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A2))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(fst x, (A1 → A1) → (A1 → A2) → (A1 → (And A1 A2)));(fst x, (A1 → A1))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply RA7_I. exists A1. exists A1. exists A2. auto. inversion H4.
  subst. 2: inversion H5. apply wimp_Id_gen. inversion H3. subst. 2: inversion H4.
  apply MP with (ps:=[(fst x, A2 → (A1 → A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H4. subst. apply wThm_irrel.
  inversion H5. subst. 2: inversion H6. apply Id. apply IdRule_I. assumption.
  inversion H2. subst. apply Id. apply IdRule_I. assumption. inversion H3.
- split. apply IHA1. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A1);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA5_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2. simpl. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp (And A1 A2) A2);(fst x, (And A1 A2))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA6_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
(* Or A1 A2 *)
- destruct H.
  apply IHA1 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A1 (Or A1 A2));(fst x, A1)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA2_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
  apply IHA2 in H. simpl in H. apply clos_deriv with (Δ:=snd x) ; auto.
  apply MP with (ps:=[(fst x, Imp A2 (Or A1 A2));(fst x, A2)]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA3_I. exists A1. exists A2. auto. inversion H1. 2: inversion H2.
  subst. apply Id. apply IdRule_I ; auto.
- apply primality with (Δ:=snd x) in H ; auto. destruct H. left. apply IHA1 ; auto.
  right. apply IHA2 ; auto.
(* Imp A1 A2 *)
- destruct x. simpl. destruct (classic (In (BPropF V) e (A1 → A2))).
  auto. exfalso. unfold CompNotDer in c. simpl in c. destruct c.
  assert (wpair_derrec (Union _ e (Singleton _ A1), Singleton _ A2) -> False).
  intro. apply gen_wBIC_Deduction_Theorem in H1. apply H0.
  { apply clos_deriv with (Δ:=e0). unfold CompNotDer ; auto. destruct H1.
    destruct H1. destruct H2. destruct x. simpl in H3. simpl in H2.
    apply MP with (ps:=[(e, Imp (Bot V) (A1 → A2));(e, Bot V)]). 2: apply MPRule_I.
    intros. inversion H4. subst. apply wEFQ. inversion H5. 2: inversion H6. subst.
    assumption. inversion H1. subst. pose (H2 b). assert (List.In b (b :: x)). apply in_eq.
    apply s in H4. inversion H4. subst. destruct x. simpl in H3.
    apply absorp_Or1 in H3. auto. pose (H2 b). assert (List.In b (A1 → A2 :: b :: x)).
    apply in_cons. apply in_eq. apply s0 in H5. inversion H5. subst. inversion H1.
    subst. exfalso. apply H10. apply in_eq. }
  apply Lindenbaum_lemma in H1. destruct H1. destruct H1.
  destruct H1. destruct H2. destruct H3.
  assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
  pose (H s).
  assert (J2: Canon_relation (exist (fun x : Ensemble (BPropF V) * Ensemble (BPropF V) =>
  CompNotDer x) (e, e0) (conj c f)) s). unfold Canon_relation. simpl.
  intro. intros. apply H1. apply Union_introl. auto. apply w in J2.
  apply IHA2 in J2. simpl in J2.
  apply H4. exists [A2]. repeat split. apply NoDup_cons. auto. apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H2. apply In_singleton. inversion H6.
  simpl. apply MP with (ps:=[(x, Imp A2 (Or A2 (Bot V)));(x, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H6. 2: inversion H7. subst. apply Id. apply IdRule_I. auto.
  apply IHA1. simpl. apply H1. apply Union_intror. apply In_singleton.
- intros. destruct x. simpl in H. destruct v. simpl. destruct x. simpl.
  apply IHA1 in H1. simpl in H1. unfold Canon_relation in H0. simpl in H0.
  apply H0 in H. unfold CompNotDer in c0. destruct c0. simpl in f. simpl in c0.
  apply IHA2. simpl.
  assert (wpair_derrec (e1, Singleton _ A2)). exists [A2]. repeat split.
  apply NoDup_cons ; auto ; apply NoDup_nil. intros. inversion H2. subst. apply In_singleton.
  inversion H3. simpl.
  apply MP with (ps:=[(e1, Imp A2 (Or A2 (Bot V)));(e1, A2)]). 2: apply MPRule_I.
  intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2. exists (Bot V).
  auto. inversion H3. subst.
  apply MP with (ps:=[(e1, Imp A1 A2);(e1, A1)]). 2: apply MPRule_I.
  intros. inversion H4. subst. apply Id. apply IdRule_I. auto.
  inversion H5. 2: inversion H6. subst. apply Id. apply IdRule_I. auto.
  inversion H4.
  apply clos_deriv with (Δ:=e2). unfold CompNotDer ; auto. destruct H2. destruct H2.
  destruct H3. destruct x. simpl in H4. apply MP with (ps:=[(e1, Imp (Bot V) A2);(e1, Bot V)]).
  2: apply MPRule_I. intros. inversion H5. subst. apply wEFQ. inversion H6. 2: inversion H7.
  subst. auto. inversion H2. subst. pose (H3 b). assert (List.In b (b :: x)).
  apply in_eq. apply s in H5. inversion H5. subst. destruct x. simpl in H4.
  apply absorp_Or1 in H4. auto. exfalso. pose (H3 b0). assert (List.In b0 (b :: b0 :: x)).
  apply in_cons. apply in_eq. apply s0 in H6. inversion H6. subst. apply H7. apply in_eq.
(* Excl A1 A2 *)
- destruct H. destruct H. destruct (classic (In (BPropF V) (fst x) (Excl A1 A2))). auto.
  exfalso. destruct H0. assert (wBIC_rules (fst x, Excl A1 A2) -> False). intro. apply H1.
  apply clos_deriv with (Δ:=snd x) ; auto. apply IHA1 in H0.
  simpl in H0. assert (In (BPropF V) (fst (proj1_sig x0)) (Or A2 (Excl A1 A2))).
  apply clos_deriv with (Δ:=(snd (proj1_sig x0))). unfold CompNotDer ; auto.
  destruct x0. simpl. auto. destruct x0. simpl.
  apply MP with (ps:=[(fst x0, Imp A1 (Or A2 (Excl A1 A2)));(fst x0, A1)]). 2: apply MPRule_I.
  intros. inversion H4. subst. apply Ax. apply AxRule_I. apply RA11_I. exists A1.
  exists A2. auto. inversion H5. 2: inversion H6. subst. apply Id. apply IdRule_I.
  auto. apply primality with (Δ:=snd (proj1_sig x0)) in H4. destruct H4 ; auto.
  apply H2. apply IHA2. auto. destruct x0. simpl. auto.
- assert (wpair_derrec ((Singleton _ A1), Union _ (snd x) (Singleton _ A2)) -> False).
  intro. destruct H0. destruct H0. destruct H1. simpl in H2. simpl in H1.
  destruct x. simpl in H. simpl in H1. destruct c. simpl in H3. simpl in H4.
  pose (remove_disj x0 A2 (Singleton (BPropF V) A1)).
  assert (wBIC_rules (Singleton (BPropF V) A1, Or A2 (list_disj (remove eq_dec_form A2 x0)))).
  apply MP with (ps:=[(Singleton (BPropF V) A1, list_disj x0 → Or A2
   (list_disj (remove eq_dec_form A2 x0)));(Singleton (BPropF V) A1, list_disj x0)]).
  2: apply MPRule_I. intros. inversion H5. subst. auto. inversion H6. subst.
  auto. inversion H7. clear w. clear H2.
  assert (Singleton (BPropF V) A1 = Union _ (Empty_set _) (Singleton (BPropF V) A1)).
  apply Extensionality_Ensembles. split. intro. intros. inversion H2. subst.
  apply Union_intror. apply In_singleton. intro. intros. inversion H2.
  subst. inversion H6. inversion H6. subst. apply In_singleton. rewrite H2 in H5.
  assert (J1: Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1) =
  Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1)). auto.
  assert (J2: Or A2 (list_disj (remove eq_dec_form A2 x0)) = Or A2 (list_disj (remove eq_dec_form A2 x0))). auto.
  pose (wBIC_Deduction_Theorem (Union (BPropF V) (Empty_set (BPropF V)) (Singleton (BPropF V) A1),
  Or A2 (list_disj (remove eq_dec_form A2 x0))) H5 A1 (Or A2 (list_disj (remove eq_dec_form A2 x0)))
  (Empty_set _) J1 J2). apply wdual_residuation in w. clear J2. clear J1. clear H2.
  clear H5.
  apply H4. exists (remove eq_dec_form A2 x0). repeat split. apply NoDup_remove.
  auto. intros. simpl. pose (H1 A). assert (List.In A x0). apply In_remove with (B:= A2).
  auto. apply u in H5. inversion H5. subst. auto. subst. inversion H6.
  subst. exfalso. apply remove_In in H2. auto. simpl.
  apply MP with (ps:=[(e, Excl A1 A2 → list_disj (remove eq_dec_form A2 x0));(e, Excl A1 A2)]).
  2: apply MPRule_I. intros. inversion H2. subst.
  pose (wBIC_monot (Empty_set (BPropF V), Excl A1 A2 → list_disj (remove eq_dec_form A2 x0))
  w e). apply w0. clear w0. simpl. intro. intros. inversion H5. inversion H5.
  subst. 2: inversion H6. clear H2. clear H5. apply Id. apply IdRule_I. auto.
  apply Lindenbaum_lemma in H0. destruct H0. destruct H0. destruct H0.
  destruct H1. destruct H2.
  assert (J1: CompNotDer (x0, x1)). unfold CompNotDer. auto.
  pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x0,x1) J1).
  exists s. unfold Canon_relation. simpl. split. destruct x. simpl.
  intro. intros. destruct c. simpl in H5. pose (H5 x). destruct o.
  simpl in H7. auto. simpl in H7. exfalso. pose (H1 x). simpl in i.
  assert (In (BPropF V) (Union (BPropF V) e0 (Singleton (BPropF V) A2)) x).
  apply Union_introl. auto. apply i in H8. apply H3. exists [x].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H9. subst. simpl. auto. inversion H10.
  simpl. apply MP with (ps:=[(x0, Imp x (Or x (Bot V))); (x0, x)]).
  2: apply MPRule_I. intros. inversion H9. subst.
  apply Ax. apply AxRule_I. apply RA2_I. exists x. exists (Bot V). auto.
  inversion H10. 2: inversion H11. subst. apply Id. apply IdRule_I.
  auto. split. apply IHA1. simpl. apply H0. apply In_singleton.
  intro. apply IHA2 in H4. simpl in H4. apply H3. exists [A2].
  repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
  intros. inversion H5. subst. simpl. apply H1. apply Union_intror.
  apply In_singleton. inversion H6. simpl.
  apply MP with (ps:=[(x0, Imp A2 (Or A2 (Bot V)));(x0, A2)]). 2: apply MPRule_I.
  intros. inversion H5. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A2.
  exists (Bot V). auto. inversion H6. 2: inversion H7. subst. clear H5.
  clear H6. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCounterCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (wpair_derrec (Γ, Δ) -> False) -> ((loc_conseq Γ Δ) -> False).
Proof.
intros Γ Δ WD.
apply Lindenbaum_lemma in WD. destruct WD. destruct H. destruct H. destruct H0.
destruct H1. intro. unfold loc_conseq in H3.
assert (J1: complete (fst (x, x0), snd (x, x0)) /\ (wpair_derrec (fst (x, x0), snd (x, x0)) -> False)). auto.
pose (@exist (prod (Ensemble (BPropF V)) (Ensemble (BPropF V))) CompNotDer (x,x0) J1).
pose (H3 Canon_worlds Canon_relation C_R_props Canon_valuation C_val_persist s).
assert ((forall A : BPropF V, In (BPropF V) Γ A -> wforces Canon_worlds Canon_relation C_R_props
Canon_valuation C_val_persist s A)). intros. apply truth_lemma. auto.
apply e in H4. destruct H4. destruct H4. apply truth_lemma in H5. simpl in H5.
apply H2. exists [x1]. repeat split. apply NoDup_cons ; auto ; apply NoDup_nil.
intros. inversion H6. simpl. subst. apply H0 ; auto. inversion H7. simpl.
apply MP with (ps:=[(x, Imp x1 (Or x1 (Bot V)));(x, x1)]). 2: apply MPRule_I.
intros. inversion H6. subst. apply Ax. apply AxRule_I. apply RA2_I. exists x1. exists (Bot V).
auto. inversion H7. subst. 2: inversion H8. apply Id. apply IdRule_I. auto.
Qed.

Theorem wCompleteness : forall (Γ Δ : @Ensemble (BPropF V)),
    (loc_conseq Γ Δ) -> wpair_derrec (Γ, Δ).
Proof.
intros Γ Δ LC. pose (wCounterCompleteness Γ Δ).
pose (classic (wpair_derrec (Γ, Δ))). destruct o. auto. exfalso.
apply f ; assumption.
Qed.


Require Import VST.progs64.io.
Require Import VST.progs64.io_specs.
Require Import VST.floyd.proofauto.

Local Open Scope itree_scope.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition putchar_spec := DECLARE _putchar putchar_spec.
Definition getchar_spec := DECLARE _getchar getchar_spec.

Definition getchar_blocking_spec :=
 DECLARE _getchar_blocking
  WITH k : byte -> IO_itree
  PRE [ ]
    PROP ()
    PARAMS ()
    GLOBALS ()
    SEP (ITREE (r <- read stdin;; k r))
  POST [ tint ]
   EX i : byte,
    PROP ()
    LOCAL (temp ret_temp (Vubyte i))
    SEP (ITREE (k i)).

Definition putchar_blocking_spec :=
 DECLARE _putchar_blocking
  WITH c : byte, k : IO_itree
  PRE [ tint ]
    PROP ()
    PARAMS (Vubyte c)
    GLOBALS ()
    SEP (ITREE (r <- write stdout c ;; k))
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vubyte c))
    SEP (ITREE k).

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by lia.
  rewrite <- Nat2Z.inj_div by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite Nat2Z.inj_div, Z2Nat.id by lia; simpl.
  apply Z.div_lt; auto; lia.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list byte :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); lia.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list byte :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; lia.
Defined.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (intr i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition print_int_spec :=
 DECLARE _print_int
  WITH i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i))
    GLOBALS ()
    SEP (ITREE (write_list stdout (chars_of_Z i) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (ITREE tr).

Definition read_sum n d : IO_itree :=
   ITree.iter (fun '(n, d) =>
       if zlt n 1000 then if zlt d 10 then
         write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
              c <- read stdin;;
              Ret (inl (n + d, Byte.unsigned c - char0)) (* loop again with these parameters *)
       else Ret (inr tt) else Ret (inr tt)) (* inr to end the loop *)
     (n, d).

Definition main_itree := c <- read stdin;; read_sum 0 (Byte.unsigned c - char0).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog main_itree gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [putchar_spec; getchar_spec;
  print_intr_spec; print_int_spec; getchar_blocking_spec; putchar_blocking_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

Opaque Nat.div Nat.modulo.

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

Lemma body_getchar_blocking: semax_body Vprog Gprog f_getchar_blocking getchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (-1 <= Int.signed i <= two_p 8 - 1) LOCAL (temp _r (Vint i))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- read stdin;; k r) else k (Byte.repr (Int.signed i))))).
  - Exists (Int.neg (Int.repr 1)); entailer!.
    { simpl; lia. }
    rewrite if_true; auto.
  - entailer!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call k.
    Intros i.
    forward.
    Exists i; entailer!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    forward.
    Exists (Byte.repr (Int.signed i)); entailer!.
    unfold Vubyte; rewrite Byte.unsigned_repr, Int.repr_signed; auto.
    split; try lia.
    etransitivity; [apply H|].
    simpl; rep_lia.
Qed.

Lemma body_putchar_blocking: semax_body Vprog Gprog f_putchar_blocking putchar_blocking_spec.
Proof.
  start_function.
  forward.
  forward_while (EX i : int, PROP (Int.signed i = -1 \/ Int.signed i = Byte.unsigned c) LOCAL (temp _r (Vint i); temp _c (Vubyte c))
    SEP (ITREE (if eq_dec (Int.signed i) (-1) then (r <- write stdout c;; k) else k))).
  - Exists (Int.neg (Int.repr 1)); entailer!.
    rewrite if_true; auto.
  - entailer!.
  - subst; rewrite Int.signed_repr by rep_lia.
    rewrite if_true by auto.
    forward_call (c, k).
    Intros i.
    forward.
    Exists i; entailer!.
  - assert (Int.signed i <> -1).
    { intro X.
      apply f_equal with (f := Int.repr) in X.
      rewrite Int.repr_signed in X; auto. }
    rewrite if_false by auto.
    destruct H; [contradiction | subst].
    forward.
    entailer!.
    unfold Vubyte.
    rewrite <- H, Int.repr_signed; auto.
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - forward.
    forward.
    rewrite modu_repr, divu_repr by (lia || computable).
    rewrite intr_eq.
    destruct (Z.leb_spec i 0); try lia.
    rewrite write_list_app, bind_bind.
    forward_call (i / 10, write_list stdout [Byte.repr (i mod 10 + char0)];; tr).
    { split; [apply Z.div_pos; lia | apply Z.div_le_upper_bound; lia]. }
    simpl write_list.
    forward_call (Byte.repr (i mod 10 + char0), tr).
    { entailer!.
      unfold Vubyte; rewrite Byte.unsigned_repr; auto.
      pose proof (Z_mod_lt i 10); unfold char0; rep_lia. }
    { rewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; auto. }
    entailer!.
  - forward.
    subst; entailer!.
    simpl.
    rewrite bind_ret_l; auto.
Qed.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n, 0 < n ->
  chars_of_Z n = intr n.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intro.
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; lia|].
  simpl.
  rewrite ?Zaux.Zdiv_eucl_unique in *.  (* Coq 8.15 and after *)
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; lia. }
    assert (n / 10 = 0) as Hz by lia.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try lia.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite H; auto; try lia.
    split; try lia.
    apply Z.div_lt; auto; lia.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_if (PROP () LOCAL () SEP (ITREE tr)).
  - subst.
    forward_call (Byte.repr char0, tr).
    { rewrite chars_of_Z_eq; simpl.
      erewrite <- sepcon_emp at 1; apply sepcon_derives; [|cancel].
      rewrite bind_ret'; apply derives_refl. }
    entailer!.
  - forward_call (i, tr).
    { rewrite chars_of_Z_intr by lia; cancel. }
    entailer!.
Qed.

Lemma read_sum_eq : forall n d, read_sum n d ≈
  (if zlt n 1000 then if zlt d 10 then
     write_list stdout (chars_of_Z (n + d));; write stdout (Byte.repr newline);;
     c <- read stdin;; read_sum (n + d) (Byte.unsigned c - char0)
   else Ret tt else Ret tt).
Proof.
  intros.
  unfold read_sum; rewrite unfold_iter.
  unfold ITree.iter.
  if_tac; [|rewrite bind_ret_l; reflexivity].
  if_tac; [|rewrite bind_ret_l; reflexivity].
  repeat setoid_rewrite bind_bind.
  setoid_rewrite bind_ret_l.
  setoid_rewrite tau_eutt.
  reflexivity.
Qed.

Lemma signed_char_unsigned : forall c, Byte.unsigned c <= two_p 8 - 1.
Proof.
  intros.
  pose proof (Byte.unsigned_range c).
  unfold Byte.modulus, two_power_nat in H; simpl in *; lia.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  unfold main_pre.
  sep_apply (has_ext_ITREE(E := @IO_event nat)).
  forward.
  unfold main_itree.
  rewrite <- !seq_assoc. (* Without this, forward_call gives a type error! *)
  forward_call (fun c => read_sum 0 (Byte.unsigned c - char0)).
  Intros c.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c); rewrite Int.unsigned_repr; rep_lia).
  set (Inv := EX n : Z, EX c : byte,
    PROP (0 <= n < 1009)
    LOCAL (temp _c (Vubyte c); temp _n (Vint (Int.repr n)))
    SEP (ITREE (read_sum n (Byte.unsigned c - char0)))).
  unfold Swhile; forward_loop Inv break: Inv.
  { Exists 0 c; entailer!. }
  subst Inv.
  clear dependent c; Intros n c.
  forward_if.
  forward.
  forward_if.
  { forward.
    Exists n c; entailer!. }
  forward.
  destruct (zlt (Byte.unsigned c) char0).
  { rewrite Int.unsigned_repr_eq in H1.
    rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in H1; unfold char0 in *; rep_lia. }
  rewrite Int.unsigned_repr in H1 by (unfold char0 in *; rep_lia).
  rewrite read_sum_eq.
  rewrite if_true by auto.
  destruct (zlt _ _); [|unfold char0 in *; lia].
  forward_call (n + (Byte.unsigned c - char0),
    write stdout (Byte.repr newline);; c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (Byte.repr newline, c' <- read stdin;; read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  forward_call (fun c' => read_sum (n + (Byte.unsigned c - char0)) (Byte.unsigned c' - char0)).
  Intros c'.
  forward.
  rewrite zero_ext_inrange by (pose proof (signed_char_unsigned c'); rewrite Int.unsigned_repr; rep_lia).
  Exists (n + (Byte.unsigned c - char0)) c'; entailer!.
  { forward.
    Exists n c; entailer!. }
  subst Inv.
  Intros n c'.
  forward.
Qed.

Definition ext_link := ext_link_prog prog.

#[export] Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons_ext.
{ simpl; Intro i.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons_ext.
{ simpl; Intro i'.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons body_getchar_blocking.
semax_func_cons body_putchar_blocking.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.

Require Import VST.veric.SequentialClight.
Require Import VST.progs64.io_dry.

Lemma init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Ltac alloc_block m n := match n with
  | O => idtac
  | S ?n' => let m' := fresh "m" in let Hm' := fresh "Hm" in
    destruct (dry_mem_lemmas.drop_alloc m) as [m' Hm']; alloc_block m' n'
  end.
try first [
  (* This version works in Coq 8.15, CompCert 3.10 *)
  alloc_block Mem.empty 62%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
 |
  (* This version worked in Coq 8.13, CompCert 3.9 *)
  alloc_block Mem.empty 60%nat;
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end;
  reflexivity
].
Qed.

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (AST.prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Axiom (Jsub: forall ef se lv m t v m' (EFI : ef_inline ef = true) m1
       (EFC : Events.external_call ef se lv m t v m'), juicy_mem.mem_sub m m1 ->
       exists m1' (EFC1 : Events.external_call ef se lv m1 t v m1'),
         juicy_mem.mem_sub m' m1' /\ proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC1) =
         proj1_sig (Clight_core.inline_external_call_mem_events _ _ _ _ _ _ _ EFI EFC)).

Theorem prog_ext_correct : exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ semax.genv_symb_injective (Clight_core.cl_core_sem (globalenv prog))
             (io_dry_spec ext_link) {| genv_genv := Genv.globalenv prog; genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - repeat intro; hnf.
    apply I.
  - apply Jsub.
  - apply add_funspecs_frame.
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - intros; apply I.
  - apply CSHL_Sound.semax_prog_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    split; auto.
Qed.

Require Import VST.progs64.os_combine.
Require Import VST.progs64.io_combine.
Require Import VST.progs64.io_os_specs.
Require Import VST.progs64.io_os_connection.

(* correctness down to OS traces, with relationship between syscall events and actual external reads/writes *)
Theorem prog_OS_correct : forall {H : io_os_specs.ThreadsConfigurationOps},
  exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
     forall n s0, s0.(io_log) = [] -> s0.(console) = {| cons_buf := []; rpos := 0 |} ->
    exists traces, OS_safeN_trace prog n Traces.TEnd traces main_itree s0 q init_mem /\
     forall t s, traces (t, s) -> exists z', consume_trace main_itree z' t /\ t = trace_of_ostrace s.(io_log) /\
      valid_trace_user s.(io_log).
Proof.
  intros.
  edestruct IO_OS_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - apply Jsub.
  - apply prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    auto.
Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.theory.premetric
  HoTT.HIT.surjective_factor
  HoTT.Classes.implementations.assume_rationals
  HoTTClasses.cauchy_completion.

Require Export
  HoTTClasses.cauchy_reals.base
  HoTTClasses.cauchy_reals.abs
  HoTTClasses.cauchy_reals.order
  HoTTClasses.cauchy_reals.metric.

Local Set Universe Minimization ToSet.

Lemma R_Qpos_bounded@{} : forall x : real,
  merely (exists q : Q+, abs x < rat (' q)).
Proof.
apply (C_ind0 _ _).
- intros q;apply tr. simple refine (existT _ _ _).
  + exists (abs q + 1).
    abstract (apply le_lt_trans with (abs q);
    [apply Qabs_nonneg|apply pos_plus_lt_compat_r;solve_propholds]).
  + simpl. apply rat_lt_preserving. change (abs q < abs q + 1).
    abstract (apply pos_plus_lt_compat_r;solve_propholds).
- intros x IH.
  generalize (IH 1).
  apply (Trunc_ind _);intros [q E].
  apply tr;exists (q + 2).
  change (abs (lim x) < rat (' q + ' 2)).
  apply Rlt_close_rat_plus with (abs (x 1)).
  + trivial.
  + apply (non_expanding abs).
    apply (equiv_lim _).
Defined.

Lemma R_bounded_2@{} : forall u v,
  merely (exists d : Q+, abs u < rat (' d) /\ abs v < rat (' d)).
Proof.
intros.
apply (merely_destruct (R_Qpos_bounded u)).
intros [d Ed].
apply (merely_destruct (R_Qpos_bounded v)).
intros [n En].
apply tr;exists (join d n).
repeat split.
- apply R_lt_le_trans with (rat (' d));trivial.
  apply rat_le_preserving,join_ub_l.
- apply R_lt_le_trans with (rat (' n));trivial.
  apply rat_le_preserving,join_ub_r.
Qed.

Definition QRmult@{} : Q -> real -> real
  := fun q => lipschitz_extend _ (Compose rat (q *.)) (pos_of_Q q).

Instance QRmult_lipschitz : forall q, Lipschitz (QRmult q) (pos_of_Q q)
  := _.
Typeclasses Opaque QRmult.

Lemma QRmult_negate : forall q u, - QRmult q u = QRmult (- q) u.
Proof.
intro;apply (unique_continuous_extension _ _ _).
intros r;apply (ap rat). apply negate_mult_distr_l.
Qed.

Lemma QRmult_plus_distr : forall q r u, QRmult q u + QRmult r u = QRmult (q + r) u.
Proof.
intros q r;apply (unique_continuous_extension _);try apply _.
{ change (Continuous (uncurry (+) ∘ map2 (QRmult q) (QRmult r) ∘ BinaryDup)).
  apply _. }
intros s;apply (ap rat). symmetry;apply distribute_r.
Qed.

Lemma QRmult_lipschitz_interval_aux (a:Q+)
  : forall x, abs x <= rat (' a) ->
  forall q r : Q, abs (QRmult q x - QRmult r x) <= rat (abs (q - r) * ' a).
Proof.
intros x E q r. rewrite QRmult_negate,QRmult_plus_distr.
change (rat (abs (q - r) * ' a)) with (QRmult (abs (q - r)) (rat (' a))).
rewrite <-E. clear E.
revert x;apply (unique_continuous_extension _).
- change (Continuous (uncurry join ∘
    map2 (abs ∘ QRmult (q - r)) (QRmult (abs (q - r)) ∘ (⊔ rat (' a)) ∘ abs) ∘
    BinaryDup)).
  apply _.
- change (Continuous (QRmult (abs (q - r)) ∘ (⊔ rat (' a)) ∘ abs)).
  apply _.
- intros s.
  change (rat (abs ((q - r) * s) ⊔ abs (q - r) * (abs s ⊔ ' a)) =
    rat (abs (q - r) * (abs s ⊔ ' a))).
  apply (ap rat).
  apply join_r.
  rewrite Qabs_mult. apply mult_le_compat.
  + apply Qabs_nonneg.
  + apply Qabs_nonneg.
  + reflexivity.
  + apply join_ub_l.
Qed.

Instance Qbounded_lipschitz (a : Q+)
  : forall v : Interval (- rat (' a)) (rat (' a)),
    Lipschitz (fun q : Q => QRmult q (interval_proj _ _ v)) a.
Proof.
intros v e x y xi.
apply Qclose_alt in xi. apply metric_to_equiv.
eapply R_le_lt_trans.
+ apply (QRmult_lipschitz_interval_aux a).
  apply (snd (Rabs_le_pr _ _)).
  split;apply v.2.
+ apply rat_lt_preserving. rewrite mult_comm.
  apply pos_mult_le_lt_compat;try split;try solve_propholds.
  * reflexivity.
  * apply Qabs_nonneg.
Qed.

Definition Rbounded_mult@{} (a : Q+)
  : real -> Interval (- rat (' a)) (rat (' a)) -> real
  := fun u v => lipschitz_extend _
      (fun q => QRmult q (interval_proj _ _ v)) a u.

Instance Rbounded_mult_lipschitz : forall a v,
  Lipschitz (fun u => Rbounded_mult a u v) a
  := _.
Typeclasses Opaque Rbounded_mult.

Definition interval_back
  : sigT (fun a : Q+ => Interval (- rat (' a)) (rat (' a))) -> real
  := fun x => x.2.1.

Instance interval_proj_issurj@{}
  : TrM.RSU.IsConnMap@{Uhuge Ularge UQ UQ Ularge} (trunc_S minus_two) interval_back.
Proof.
apply BuildIsSurjection. intros x.
generalize (R_Qpos_bounded x). apply (Trunc_ind _);intros [q E].
apply tr. simple refine (existT _ _ _).
- exists q. exists x. apply Rabs_le_pr. apply R_lt_le. exact E.
- simpl. reflexivity.
Defined.

Lemma Rbounded_mult_respects : forall z x y, interval_back x = interval_back y ->
  Rbounded_mult x.1 z x.2 = Rbounded_mult y.1 z y.2.
Proof.
intros z x y E.
revert z. apply (unique_continuous_extension _ _ _).
intros q. unfold Rbounded_mult.
exact (ap _ E).
Qed.

Definition Rmult@{} : Mult real
  := fun x => surjective_factor@{UQ UQ UQ Uhuge Ularge
                                       Ularge Ularge Ularge UQ Ularge
                                       UQ Uhuge Ularge}
                                     _ interval_back (Rbounded_mult_respects x).

Global Existing Instance Rmult.

Lemma Rmult_pr@{} x : (fun y => Rbounded_mult y.1 x y.2) =
  Compose (x *.) interval_back.
Proof.
apply path_forall,surjective_factor_pr.
Qed.

Definition Rmult_rat_rat@{} q r : (rat q) * (rat r) = rat (q * r)
  := idpath.

Lemma Rmult_interval_proj_applied : forall a x y,
  x * interval_proj (rat (- ' a)) (rat (' a)) y =
  Rbounded_mult a x y.
Proof.
intros;change (Rbounded_mult a x) with
  ((fun y : exists a, Interval (rat (- ' a)) (rat (' a)) =>
    Rbounded_mult y.1 x y.2) ∘ (fun s => existT _ a s)).
rewrite Rmult_pr. reflexivity.
Qed.

Lemma Rmult_interval_proj : forall a y,
  (fun x => x * interval_proj (rat (- ' a)) (rat (' a)) y) =
  (fun x => Rbounded_mult a x y).
Proof.
intros. apply path_forall. intros x.
apply Rmult_interval_proj_applied.
Qed.

Lemma Rmult_lipschitz_aux : forall a y,
  Lipschitz (.* (interval_proj (rat (- ' a)) (rat (' a)) y)) a.
Proof.
intros a y. rewrite Rmult_interval_proj. apply _.
Qed.

Lemma Rmult_lipschitz_aux_alt : forall a y, abs y <= rat (' a) ->
  Lipschitz (.* y) a.
Proof.
intros a y E. apply Rabs_le_pr in E.
change y with (interval_proj (rat (- ' a)) (rat (' a)) (existT _ y E)).
apply Rmult_lipschitz_aux.
Qed.

Instance Rmult_continuous_r@{} : forall y : real, Continuous (.* y).
Proof.
intros. red. apply (merely_destruct (R_Qpos_bounded y)).
intros [a Eq]. apply R_lt_le in Eq. apply Rabs_le_pr in Eq.
change (Continuous (.* y)). eapply lipschitz_continuous.
change (.* y) with (.* (interval_proj (rat (- ' a)) (rat (' a)) (existT _ y Eq))).
apply Rmult_lipschitz_aux.
Qed.

Lemma Rmult_rat_l q x : rat q * x = QRmult q x.
Proof.
apply (merely_destruct (R_Qpos_bounded x)).
intros [d Ed].
apply R_lt_le in Ed. apply Rabs_le_pr in Ed.
change (rat q * x) with
  (rat q * interval_proj (rat (- ' d)) (rat (' d)) (existT _ x Ed)).
rewrite Rmult_interval_proj_applied. reflexivity.
Qed.

Lemma Rmult_abs_l : forall a b c, abs (a * b - a * c) = abs a * abs (b - c).
Proof.
intros a b c;revert a. apply (unique_continuous_extension _).
{ change (Continuous (abs ∘ uncurry plus ∘ map2 (.* b) (negate ∘ (.* c)) ∘
    (@BinaryDup real))).
  apply _.
}
{ change (Continuous ((.* (abs (b - c))) ∘ abs)).
  apply _. }
intros q.
change (abs (rat q)) with (rat (abs q)).
rewrite !Rmult_rat_l.
revert b c. apply unique_continuous_binary_extension.
{ change (Continuous (abs ∘ uncurry plus ∘ map2 (QRmult q) (negate ∘ QRmult q))).
  apply _. }
{ change (Continuous (QRmult (abs q) ∘ abs ∘ uncurry plus ∘ map2 id negate)).
  apply _. }
intros r s. change (rat (abs (q * r - q * s)) = rat (abs q * abs (r - s))).
apply (ap rat).
rewrite negate_mult_distr_r,<-plus_mult_distr_l.
apply Qabs_mult.
Qed.

Lemma Rmult_le_compat_abs@{} : forall a b c d : real, abs a <= abs c ->
  abs b <= abs d ->
  abs a * abs b <= abs c * abs d.
Proof.
intros ???? E1 E2;rewrite <-E1,<-E2. clear E1 E2.
red;simpl.
revert a c. apply unique_continuous_binary_extension.
{ change (Continuous (uncurry join ∘ map2
    ((.* abs b) ∘ abs ∘ fst)
    ((.* (join (abs b) (abs d))) ∘ uncurry join ∘ map2 abs abs) ∘
  BinaryDup)).
  repeat apply continuous_compose. 1,3:apply _.
  apply map2_continuous. 1,2:apply _.
  { apply continuous_compose. 2:apply _.
    apply continuous_compose;apply _. }
  { apply continuous_compose;apply _. }
}
{ change (Continuous ((.* (join (abs b) (abs d))) ∘ uncurry join ∘ map2 abs abs)).
  apply _. }
intros q r.
change (abs (rat q)) with (rat (abs q));
change (abs (rat r)) with (rat (abs r)).
change (rat (abs q) ⊔ rat (abs r)) with
  (rat (abs q ⊔ abs r)).
rewrite !Rmult_rat_l.
revert b d. apply unique_continuous_binary_extension.
{ change (Continuous (uncurry join ∘ map2
    (QRmult (abs q) ∘ abs ∘ fst)
    (QRmult (join (abs q) (abs r)) ∘ uncurry join ∘ map2 abs abs) ∘
  BinaryDup)).
  apply _. }
{ change (Continuous (QRmult (join (abs q) (abs r)) ∘ uncurry join ∘ map2 abs abs)).
  apply _. }
intros s t.
change (rat (abs q * abs s ⊔ (abs q ⊔ abs r) * (abs s ⊔ abs t)) =
rat ((abs q ⊔ abs r) * (abs s ⊔ abs t))).
apply (ap rat).
apply join_r. apply mult_le_compat.
- apply Qabs_nonneg.
- apply Qabs_nonneg.
- apply join_ub_l.
- apply join_ub_l.
Qed.

Lemma Rmult_continuous@{} : Continuous (uncurry (@mult real _)).
Proof.
intros [u1 v1] e.
apply (merely_destruct (R_bounded_2 u1 v1));intros [d [Ed1 Ed2]].
pose (k := d + 1).
(* assert (Ed3 : ' d < ' k). { apply pos_plus_lt_compat_r;solve_propholds. } *)
apply tr;exists (meet 1 (e / 2 / (k + 1)));
intros [u2 v2] [xi1 xi2];unfold uncurry;simpl in *.
rewrite (pos_split2 e). apply (triangular _ (u2 * v1)).
- apply R_lt_le in Ed2.
  pose proof (Rmult_lipschitz_aux_alt _ _ Ed2) as E1.
  apply lipschitz_uniform in E1.
  apply E1. eapply rounded_le;[exact xi1|].
  etransitivity;[apply meet_lb_r|].
  apply mult_le_compat;try solve_propholds.
  + reflexivity.
  + unfold cast;simpl. apply flip_le_dec_recip.
    * solve_propholds.
    * change (' d <= ' d + 1 + 1). rewrite <-plus_assoc.
      apply nonneg_plus_le_compat_r. solve_propholds.
- apply metric_to_equiv. rewrite Rmult_abs_l.
  apply R_le_lt_trans with (abs (rat (' k)) * abs (rat (' (e / 2 / (k + 1))))).
  + apply Rmult_le_compat_abs.
    * change (abs (rat (' k))) with (rat (abs (' k))).
      unfold abs at 2. rewrite (fst (abs_sig (' _)).2);[|solve_propholds].
      unfold k.
      eapply Rle_close_rat;[|apply (non_expanding abs (x:=u1))].
      ** apply R_lt_le;trivial.
      ** eapply rounded_le;[exact xi1|]. apply meet_lb_l.
    * change (abs (rat (' (e / 2 / (k + 1))))) with
        (rat (abs (' (e / 2 / (k + 1))))).
      unfold abs at 2. rewrite (fst (abs_sig (' _)).2);[|solve_propholds].
      apply equiv_to_metric in xi2.
      etransitivity;[apply R_lt_le,xi2|].
      apply rat_le_preserving,meet_lb_r.
  + apply rat_lt_preserving.
    rewrite <-Qabs_mult.
    change (' k * ' (e / 2 / (k + 1))) with
      (' (k * (e / 2 / (k + 1)))).
    unfold abs;rewrite (fst (abs_sig (' _)).2);[|solve_propholds].
    assert (Hrw : e / 2 = (e / 2) * 1)
      by (apply pos_eq;ring_tac.ring_with_nat);
    rewrite Hrw;clear Hrw.
    assert (Hrw : k * (e / 2 * 1 / (k + 1)) = (e / 2) * (k / (k + 1)))
      by (apply pos_eq;ring_tac.ring_with_nat);
    rewrite Hrw;clear Hrw.
    apply pos_mult_le_lt_compat;try split;try solve_propholds.
    * reflexivity.
    * apply (strictly_order_reflecting (.* (' (k + 1)))).
      unfold cast;simpl. unfold cast at 2;simpl.
      rewrite mult_1_l.
      rewrite <-mult_assoc, (mult_comm (/ _)),dec_recip_inverse,mult_1_r;
      [|apply lt_ne_flip;solve_propholds].
      apply pos_plus_le_lt_compat_r.
      ** solve_propholds.
      ** reflexivity.
Qed.
Global Existing Instance Rmult_continuous.

Instance Rmult_continuous_l : forall x : real, Continuous (x *.).
Proof.
change (forall x, Continuous (uncurry (@mult real _) ∘ (pair x))).
intros;apply continuous_compose; apply _.
Qed.

Instance real_ring@{} : Ring real.
Proof.
repeat (split;try apply _);
unfold sg_op,mon_unit,mult_is_sg_op,one_is_mon_unit;
change Rmult with mult;change R1 with one.
- hnf. apply unique_continuous_ternary_extension.
  + change (Continuous (uncurry mult ∘ map2 (@id real) (uncurry mult) ∘
      prod_assoc^-1)).
    (* Why does [apply _] not work here? *)
    repeat apply continuous_compose; apply _.
  + change (Continuous (uncurry mult ∘ map2 (uncurry mult) (@id real))).
    apply _.
  + intros. change (rat (q * (r * s)) = rat (q * r * s)). apply (ap rat).
    apply associativity.
- hnf. apply (unique_continuous_extension _ _ _).
  intros;apply (ap rat),left_identity.
- hnf. apply (unique_continuous_extension _ _ _).
  intros;apply (ap rat),right_identity.
- hnf. apply unique_continuous_binary_extension.
  + apply _.
  + change (Continuous (uncurry (@mult real _) ∘ prod_symm)). apply _.
  + intros;apply (ap rat),commutativity.
- hnf. apply unique_continuous_ternary_extension.
  + change (Continuous (uncurry mult ∘ map2 (@id real) (uncurry plus) ∘
      prod_assoc^-1)).
    apply _.
  + change (Continuous (uncurry (@plus real _) ∘
      map2 (uncurry mult) (uncurry mult) ∘
      map2 id prod_symm ∘ prod_assoc^-1 ∘ prod_symm ∘ map2 id prod_assoc ∘
      prod_assoc^-1 ∘ map2 BinaryDup id ∘ prod_assoc^-1)).
    repeat apply continuous_compose;apply _.
  + intros;change (rat (q * (r + s)) = rat (q * r + q * s));
    apply (ap rat),distribute_l.
Qed.

Instance Rmult_nonneg_compat : forall x y : real, PropHolds (0 ≤ x) ->
  PropHolds (0 ≤ y) ->
  PropHolds (0 ≤ x * y).
Proof.
unfold PropHolds.
intros x y E1 E2;rewrite <-E1,<-E2;clear E1 E2.
revert x y;apply unique_continuous_binary_extension.
- change (Continuous ((join 0) ∘ uncurry (@mult real _) ∘ map2 (join 0) (join 0))).
  apply continuous_compose;[|apply _]. apply continuous_compose;[apply _|].
  apply _.
- change (Continuous (uncurry (@mult real _) ∘ (map2 (join 0) (join 0)))).
  apply _.
- intros. change (rat (0 ⊔ (0 ⊔ q) * (0 ⊔ r)) = rat ((0 ⊔ q) * (0 ⊔ r))).
  apply ap. apply join_r.
  apply nonneg_mult_compat;apply join_ub_l.
Qed.

Instance real_srorder : SemiRingOrder Rle.
Proof.
apply from_ring_order;apply _.
Qed.


Require Import TestSuite.admit.
Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Arguments paths_ind [A] a P f y p.
Arguments paths_rec [A] a P f y p.
Arguments paths_rect [A] a P f y p.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

(** A typeclass that includes the data making [f] into an adjoint equivalence. *)
Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.

Record Equiv A B := BuildEquiv {
  equiv_fun :> A -> B ;
  equiv_isequiv :> IsEquiv equiv_fun
}.

Definition equiv_path (A B : Type) (p : A = B) : Equiv A B.
Admitted.

Class Univalence := {
  isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B)
}.

Definition ua_downward_closed `{Univalence} : Univalence.
  constructor.
  intros A B.
  destruct H as [H].
  generalize (fun A B => @eisretr _ _ _ (H (A : Type) (B : Type))).
  generalize (fun A B => @eissect _ _ _ (H (A : Type) (B : Type))).
  let g := match goal with |- _ -> _ -> ?g => constr:(g) end in
  let U0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U0) end in
  let U1 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U1) end in
  let U2 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U2) end in
  let U3 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U3) end in
  let f0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f) end in
  let f' := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f') end in
  change ((forall (A : U0) (B : U1), Sect (f0 A B) ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B))
          -> (forall (A : U2) (B : U3), Sect ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B) (f' A B))
          -> g);
    generalize (fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B));
    clear H;
    simpl;
    intros fi sect retr.
  pose proof fi as fi'.
  Set Printing All.
  change (forall (A : Type) (B : Type) (_ : Equiv A B), @paths Type A B) in fi'.
  (*refine (@isequiv_adjointify
              _ _
              _ _
              _
              _);
    admit.
  Grab Existential Variables.*)
  admit.
  (*destruct p.*)
  (*specialize (H (A' : Type)).*)
Defined.
(* Error: Unsatisfied constraints:
Top.62 < Top.61
Top.64 <= Top.62
Top.63 <= Top.62
 (maybe a bugged tactic).*)