Require Import Bool.

Definition basic_predicate :=
  (fun a => Is_true (andb a true)).

Theorem exists_basics : ex basic_predicate.
Proof.
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    simpl.
    exact I.
Qed.

Theorem exsists_basics : exists a, Is_true (andb a true).
Proof.
  pose (witness := true).
  refine (ex_intro _ witness _).
    simpl.
    exact I.
Qed.

Theorem basic_forall_exists : forall b, exists a, Is_true (eqb a b).
Proof.
  intros b.
  case b.
    (* b = true *)
    pose (witness := true).
    refine (ex_intro _ witness _).
      simpl.
      exact I.
    (* b = false *)
    pose (witness := false).
    refine (ex_intro _ witness _).
      simpl.
      exact I.
Qed.

Theorem forall_exists : forall P : Set -> Prop, (forall x, ~(P x)) -> ~(exists x, P x).
Proof.
  intros P.
  intros fa_x_not_Px.
  unfold not.
  intros ex_x_Px.
  destruct ex_x_Px as [ witness pf_Pwitness ].
  pose (not_Pwitness := fa_x_not_Px witness).
  unfold not in not_Pwitness.
  pose (pf_False := not_Pwitness pf_Pwitness).
  case pf_False.
Qed.

Theorem eq_symetric : forall x y : Set, x = y -> y = x.
Proof.
  intros x y x_eq_y.
  destruct x_eq_y.
  exact (eq_refl x).
Qed.

Theorem eq_transitive : forall x y z : Set, x = y -> y = z -> x = z.
Proof.
  intros x y z x_eq_y y_eq_z.
  destruct x_eq_y.
  destruct y_eq_z.
  exact (eq_refl x).
Qed.

Theorem eq_transitive_1 : forall x y z : Set, x = y -> y = z -> x = z.
Proof.
  intros x y z x_eq_y y_eq_z.
  rewrite x_eq_y.
  rewrite <- y_eq_z.
  exact (eq_refl y).
Qed.

Theorem andb_symmetric : forall a b, a && b = b && a.
Proof.
  intros a b.
  case a, b.
    simpl. exact (eq_refl true).
    simpl. exact (eq_refl false).
    simpl. exact (eq_refl false).
    simpl. exact (eq_refl false).
Qed.

Theorem neq_nega : forall a, a <> negb a.
Proof.
  intros a.
  unfold not.
  case a.
    simpl.
    intros true_eq_false.
    discriminate true_eq_false.
    simpl.
    intros false_eq_true.
    discriminate false_eq_true.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega.

Set Implicit Arguments.

Inductive pos : nat -> Set :=
  | pos_fst : forall n, pos (S n)
  | pos_nxt : forall n, pos n -> pos (S n).

Arguments pos_fst {n}.
Arguments pos_nxt {n}.

Notation pos0  := (@pos_fst _).
Notation pos1  := (pos_nxt pos0).
Notation pos2  := (pos_nxt pos1).
Notation pos3  := (pos_nxt pos2).
Notation pos4  := (pos_nxt pos3).
Notation pos5  := (pos_nxt pos4).
Notation pos6  := (pos_nxt pos5).
Notation pos7  := (pos_nxt pos6).
Notation pos8  := (pos_nxt pos7).
Notation pos9  := (pos_nxt pos8).
Notation pos10 := (pos_nxt pos9).
Notation pos11 := (pos_nxt pos10).
Notation pos12 := (pos_nxt pos11).
Notation pos13 := (pos_nxt pos12).
Notation pos14 := (pos_nxt pos13).
Notation pos15 := (pos_nxt pos14).
Notation pos16 := (pos_nxt pos15).
Notation pos17 := (pos_nxt pos16).
Notation pos18 := (pos_nxt pos17).
Notation pos19 := (pos_nxt pos18).
Notation pos20 := (pos_nxt pos19).

Definition pos_iso n m : n = m -> pos n -> pos m.
Proof. intros []; auto. Defined.

Section pos_inv.

  Let pos_inv_t n :=
    match n as x return pos x -> Set with
      | 0   => fun _ => False
      | S n => fun i => (( i = pos_fst ) + { p | i = pos_nxt p })%type
    end.

  Let pos_inv : forall n p, @pos_inv_t n p.
  Proof.
    intros _ [ | n p ]; simpl; [ left | right ]; auto; exists p; auto.
  Defined.

  Definition pos_O_inv : pos 0 -> False.
  Proof. apply pos_inv. Defined.

  Definition pos_S_inv n (p : pos (S n)) : ( p = pos_fst ) + { q | p = pos_nxt q }.
  Proof. apply (pos_inv p). Defined.

  Definition pos_nxt_inj n (p q : pos n) (H : pos_nxt p = pos_nxt q) : p = q :=
    match H in _ = a return
       match a as a' in pos m return
           match m with
             | 0 => Prop
             | S n' => pos n' -> Prop
           end with
         | pos_fst   => fun _  => True
         | pos_nxt y => fun x' => x' = y
       end p with
     | eq_refl => eq_refl
   end.

End pos_inv.

Arguments pos_S_inv {n} p /.

Section pos_invert.

  (* Position inversion, "singleton elimination" free version
     One problem remains to fully use it ... it is not
     correctly traversed by type checking algorithm
     of fixpoints (structural recursion)

     pos_S_inv work better in that respect
  *)

  Let pos_invert_t n : (pos n -> Type) -> Type :=
    match n with
        0   => fun P => True
      | S n => fun P => (P (pos_fst) * forall p, P (pos_nxt p))%type
    end.

  Let pos_invert n : forall (P : pos n -> Type), pos_invert_t P -> forall p, P p.
  Proof.
    intros P HP; induction p; simpl in HP; apply HP.
  Defined.

  Theorem pos_O_invert X : pos 0 -> X.
  Proof.
    apply pos_invert; simpl; trivial.
  Defined.

  Theorem pos_S_invert n P : P (@pos_fst n) -> (forall p, P (pos_nxt p)) -> forall p, P p.
  Proof.
    intros; apply pos_invert; split; auto.
  Defined.

End pos_invert.

Arguments pos_S_invert [n] P _ _ p /.

Ltac pos_O_inv p := exfalso; apply (pos_O_inv p).

Ltac pos_S_inv p :=
  let H := fresh in
  let q := fresh
  in  rename p into q; destruct (pos_S_inv q) as [ H | (p & H) ]; subst q.

(*
Ltac pos_O_inv p := apply (@pos_O_invert _ p).
Ltac pos_S_inv x := induction x as [ | x ] using pos_S_invert.
*)

Ltac pos_inv p :=
  match goal with
    | [ H: pos 0     |- _ ] => match H with p => pos_O_inv p end
    | [ H: pos (S _) |- _ ] => match H with p => pos_S_inv p end
  end.

Tactic Notation "invert" "pos" hyp(H) := pos_inv H; simpl.

Definition pos_O_any X : pos 0 -> X.
Proof. intro p; invert pos p. Qed.

Fixpoint pos_list n : list (pos n) :=
  match n with
    | 0   => nil
    | S n => pos0::map pos_nxt (pos_list n)
  end.

Fact pos_list_prop n p : In p (pos_list n).
Proof.
  induction p as [ | n p Hp ].
  left; auto.
  simpl; right.
  apply in_map_iff.
  exists p; auto.
Qed.

Fact pos_list_length n : length (pos_list n) = n.
Proof.
  induction n; simpl; auto.
  rewrite map_length; f_equal; auto.
Qed.

Fact pos_reification X n (R : pos n -> X -> Prop) : (forall p, exists x, R p x) -> exists f, forall p, R p (f p).
Proof.
  revert R; induction n as [ | n IHn ]; intros R HR.
  exists (pos_O_any X); intros p; invert pos p.
  set (R' q x := R (pos_nxt q) x).
  destruct (IHn R') as (f & Hf).
  intros p; apply HR.
  unfold R' in Hf.
  destruct (HR pos_fst) as (x & Hx).
  exists (fun p => match pos_S_inv p with inl _ => x | inr (exist _ q _) => f q end).
  intros p; invert pos p; auto.
Qed.

Fact pos_reif_t X n (R : pos n -> X -> Prop) : (forall p, { x | R p x }) -> { f | forall p, R p (f p) }.
Proof.
  intros H.
  exists (fun p => (proj1_sig (H p))).
  intros; apply (proj2_sig (H p)).
Qed.

Section pos_eq_dec.

  Definition pos_eq_dec n (x y : pos n) : { x = y } + { x <> y }.
  Proof.
    revert n x y.
    induction x as [ x | n x IH ]; intros y; invert pos y.
    left; trivial.
    right; discriminate.
    right; discriminate.
    destruct (IH y) as [ | C ].
    left; subst; trivial.
    right; contradict C; revert C; apply pos_nxt_inj.
  Defined.

End pos_eq_dec.

Section pos_map.

  Definition pos_map m n := pos m -> pos n.

  Definition pm_ext_eq m n (r1 r2 : pos_map m n) := forall p, r1 p = r2 p.

  Definition pm_lift m n (r : pos_map m n) : pos_map (S m) (S n).
  Proof.
    intros p.
    invert pos p.
    apply pos_fst.
    apply pos_nxt, (r p).
  Defined.

  Fact pm_lift_fst m n (r : pos_map m n) : pm_lift r pos0 = pos0.
  Proof. auto. Qed.

  Fact pm_lift_nxt m n (r : pos_map m n) p : pm_lift r (pos_nxt p) = pos_nxt (r p).
  Proof. auto. Qed.

  Arguments pm_lift [ m n ] r p.

  Fact pm_lift_ext m n r1 r2 : @pm_ext_eq m n r1 r2 -> pm_ext_eq (pm_lift r1) (pm_lift r2).
  Proof.
    intros H12 p; unfold pm_lift.
    invert pos p; simpl; auto.
    f_equal; apply H12.
  Qed.

  Definition pm_comp l m n : pos_map l m -> pos_map m n -> pos_map l n.
  Proof.
    intros H1 H2 p.
    exact (H2 (H1 p)).
  Defined.

  Fact pm_comp_lift l m n r s : pm_ext_eq (pm_lift (@pm_comp l m n r s)) (pm_comp (pm_lift r) (pm_lift s)).
  Proof.
    intros p.
    unfold pm_comp, pm_lift; simpl.
    invert pos p; simpl; auto.
  Qed.

  Definition pm_id n : pos_map n n := fun p => p.

End pos_map.

Arguments pm_lift { m n } _ _ /.
Arguments pm_comp [ l m n ] _ _ _ /.
Arguments pm_id : clear implicits.

Section pos_nat.

  Fixpoint pos_nat n (p : pos n) : { i | i < n }.
  Proof.
    refine (match p with
              | pos_fst   => exist _ 0 _
              | pos_nxt q => exist _ (S (proj1_sig (pos_nat _ q))) _
            end).
    apply lt_O_Sn.
    apply lt_n_S, (proj2_sig (pos_nat _ q)).
  Defined.

  Definition pos2nat n p := proj1_sig (@pos_nat n p).

  Fact pos2nat_prop n p : @pos2nat n p < n.
  Proof. apply (proj2_sig (pos_nat p)). Qed.

  Fixpoint nat2pos n : forall x, x < n -> pos n.
  Proof.
     refine (match n as n' return forall x, x < n' -> pos n' with
              | O   => fun x H => _
              | S i => fun x H => _
            end).
    exfalso; revert H; apply lt_n_O.
    destruct x as [ | x ].
    apply pos_fst.
    apply pos_nxt.
    apply (nat2pos i x); revert H; apply lt_S_n.
  Defined.

  Definition nat_pos n : { i | i < n } -> pos n.
  Proof. intros (? & H); revert H; apply nat2pos. Defined.

  Arguments pos2nat n !p /.

  Fact pos2nat_inj n (p q : pos n) : pos2nat p = pos2nat q -> p = q.
  Proof.
    revert q.
    induction p as [ n p | n p IHp ]; intros q; invert pos q; simpl; auto; try discriminate 1.
    intros H; f_equal; apply IHp; injection H; trivial.
  Qed.

  Fact pos2nat_nat2pos n i (H : i < n) : pos2nat (nat2pos H) = i.
  Proof.
    revert i H;
    induction n as [ | n IHn ]; intros [ | i ] H; simpl; auto; try omega.
    f_equal.
    apply IHn.
  Qed.

  Fact nat2pos_pos2nat n p (H : pos2nat p < n) : nat2pos H = p.
  Proof.
    apply pos2nat_inj; rewrite pos2nat_nat2pos; auto.
  Qed.

  Fact pos2nat_fst n : pos2nat (@pos_fst n) = 0.
  Proof. auto. Qed.

  Fact pos2nat_nxt n p : pos2nat (@pos_nxt n p) = S (pos2nat p).
  Proof. auto. Qed.

  Fixpoint pos_sub n (p : pos n) { struct p } : forall m, n < m -> pos m.
  Proof.
    destruct p as [ | n p ]; intros [ | m ] Hm.
    exfalso; clear pos_sub; abstract omega.
    apply pos_fst.
    exfalso; clear pos_sub; abstract omega.
    apply pos_nxt.
    apply (pos_sub n p), lt_S_n, Hm.
  Defined.

  Fact pos_sub2nat n p m Hm : pos2nat (@pos_sub n p m Hm) = pos2nat p.
  Proof.
    revert m Hm; induction p as [ n | n p IH ]; intros [ | m ] Hm; try omega.
    simpl; auto.
    simpl pos_sub; repeat rewrite pos2nat_nxt; f_equal; auto.
  Qed.

End pos_nat.

Section pos_prod.

  Variable n : nat.

  Let ll := flat_map (fun p => map (fun q => (p,q)) (pos_list n)) (pos_list n).
  Let ll_prop p q : In (p,q) ll.
  Proof.
    apply in_flat_map; exists p; split.
    apply pos_list_prop.
    apply in_map_iff.
    exists q; split; auto.
    apply pos_list_prop.
  Qed.

  Definition pos_not_diag := filter (fun c => if pos_eq_dec (fst c) (snd c) then false else true) ll.

  Fact pos_not_diag_spec p q : In (p,q) pos_not_diag <-> p <> q.
  Proof.
    unfold pos_not_diag.
    rewrite filter_In; simpl.
    destruct (pos_eq_dec p q).
    split.
    intros (_ & ?); discriminate.
    intros []; auto.
    split; try tauto; split; auto.
  Qed.

End pos_prod.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This module states the functional form of the axiom of choice over
  setoids, commonly called extensional axiom of choice [[Carlström04]],
  [[Martin-Löf05]]. This is obtained by a decomposition of the axiom
  into the following components:

  - classical logic
  - relational axiom of choice
  - axiom of unique choice
  - a limited form of functional extensionality

  Among other results, it entails:
  - proof irrelevance
  - choice of a representative in equivalence classes

  [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent to
  AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.

  [[Martin-Löf05] Per Martin-Löf, 100 years of Zermelo’s axiom of
  choice: what was the problem with it?, lecture notes for KTH/SU
  colloquium, 2005.

*)

Require Export ClassicalChoice. (* classical logic, relational choice, unique choice *)
Require Export ExtensionalFunctionRepresentative.

Require Import ChoiceFacts.
Require Import ClassicalFacts.
Require Import RelationClasses.

Theorem setoid_choice :
  forall A B,
  forall R : A -> A -> Prop,
  forall T : A -> B -> Prop,
  Equivalence R ->
  (forall x x' y, R x x' -> T x y -> T x' y) ->
  (forall x, exists y, T x y) ->
  exists f : A -> B, forall x : A, T x (f x) /\ (forall x' : A, R x x' -> f x = f x').
Proof.
  apply setoid_functional_choice_first_characterization. split; [|split].
  - exact choice.
  - exact extensional_function_representative.
  - exact classic.
Qed.

Theorem representative_choice :
  forall A (R:A->A->Prop), (Equivalence R) ->
  exists f : A->A, forall x : A, R x (f x) /\ forall x', R x x' -> f x = f x'.
Proof.
  apply setoid_fun_choice_imp_repr_fun_choice.
  exact setoid_choice.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui & Wang Qian & Zhang Lianyi, 2009-05-11

definition and correctness proof of a boolean function checking that
there is a loop in a TRS
*)

Set Implicit Arguments.

From Coq Require Import Euclid Wf_nat.
From CoLoR Require Import LogicUtil ATrs ListUtil RelUtil AMatching ListDec
     APosition NatUtil.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation beq_rule := (@beq_rule Sig).

  Variable R : rules Sig.

(***********************************************************************)
(** predicates saying that [t::us] is in a sequence of rewriting steps *)

  Fixpoint FS t us :=
    match us with
      | nil => True
      | u :: us' => red R t u /\ FS u us'
    end.

  Definition terms_of_reduc : forall t, {us| FS t us} -> list term.

  Proof.
    intros t x. destruct x. exact x.
  Defined.

  Arguments terms_of_reduc [t] _.

  Definition proof_of_reduc :
    forall t, forall x : {us| FS t us}, FS t (terms_of_reduc x).

  Proof.
    intros t x. destruct x. exact f.
  Defined.

  Lemma FS_rtc : forall us t, FS t us -> red R # t (last us t).

  Proof.
    induction us. simpl. intros. apply rt_refl. simpl FS. intuition.
    apply rt_trans with a. apply rt_step. hyp. simpl. destruct us.
    apply rt_refl. rewrite last_default with (d2:=a). apply IHus. hyp. discr.
  Qed.

(***********************************************************************)
(** data necessary for a sequence of rewrite steps *)

  Definition data := (position * rule Sig)%type.

  Definition rewrite (t : term) (d : data) : option term :=
    let (p,a) := d in let (l,r) := a in
      if mem beq_rule (mkRule l r) R then
        match subterm_pos t p with
          | None => None
          | Some u =>
            match matches l u with
              | None => None
              | Some s => replace_pos t p (sub s r)
            end
        end
        else None.

  Lemma rewrite_correct : forall t d u, rewrite t d = Some u -> red R t u.

  Proof.
    intros t [p [l r]] u. unfold rewrite.
    case_eq (mem beq_rule (mkRule l r) R); intros. 2: discr.
    revert H0. case_eq (subterm_pos t p); intros. 2: discr.
    revert H1. case_eq (matches l t0); intros. rename t1 into s. 2: discr.
    rewrite red_pos_ok. ex p l r s. split_all.
    rewrite mem_ok in H. hyp. apply beq_rule_ok.
    ded (matches_correct H1). rewrite H3. hyp.
  Qed.

  Arguments rewrite_correct [t d u] _.

  Fixpoint rewrites t (ds : list data) : option (list term) :=
    match ds with
      | nil => Some nil
      | d :: ds' =>
        match rewrite t d with
          | None => None
          | Some u =>
            match rewrites u ds' with
              | None => None
              | Some us => Some (u::us)
            end
        end
    end.

  Lemma rewrites_correct : forall ds t us, rewrites t ds = Some us -> FS t us.

  Proof.
    induction ds; simpl; intros. inversion H. exact I.
    revert H. case_eq (rewrite t a); intros. 2: discr.
    revert H0. case_eq (rewrites t0 ds); intros. 2: discr.
    inversion H1. simpl. ded (rewrite_correct H). intuition.
  Qed.

  Arguments rewrites_correct [ds t us] _.

  Notation default := (Var 0).

  Lemma FS_red : forall ts t, FS t ts -> forall i, i < length ts ->
    red R (nth i (t::ts) default) (nth (S i) (t::ts) default).

  Proof.
    induction ts; simpl; intros. lia. destruct H. destruct i. hyp.
    ded (IHts _ H1 i (lt_S_n H0)). hyp.
  Qed.

(***********************************************************************)
(** hyps for non-termination *)

  Section loop.

    Variables (t : term) (ds : list data)
      (us : list term) (h1 : rewrites t ds = Some us).

    Definition k := length us.

    Definition nth i := nth i us default.

    Definition last_term := nth (k-1).

    Variable h0 : k > 0.

    Lemma FS_red' : forall i, i < k - 1 -> red R (nth i) (nth (S i)).

    Proof.
      intros. unfold nth.
      change (red R (List.nth (S i) (t :: us) default)
        (List.nth (S (S i)) (t :: us) default)).
      apply FS_red. eapply rewrites_correct. apply h1. unfold k in *. lia.
    Qed.

    Variables (p : position) (u : term) (h2 : subterm_pos last_term p = Some u)
      (s : substitution Sig) (h3 : matches t u = Some s).

(***********************************************************************)
(** proof of non-termination *)

    Definition c : context Sig.

    Proof.
      destruct (subterm_pos_elim h2). exact x.
    Defined.

    Definition g t := fill c (sub s t).

    Lemma last_term_g : last_term = g t.

    Proof.
      unfold g, c. destruct (subterm_pos_elim h2). destruct a.
      rewrite H0. ded (matches_correct h3). subst u. refl.
    Qed.

    Lemma red_g : forall a b, red R a b -> red R (g a) (g b).

    Proof.
      intros. apply red_fill. apply red_sub. hyp.
    Qed.

    Definition seq : nat -> term.

    Proof.
      intro n. destruct (eucl_dev k h0 n). exact (iter (nth r) g q).
    Defined.

    Lemma IS_seq : IS (red R) seq.

    Proof.
      intro n; pattern n; apply lt_wf_ind; clear n; intros. unfold seq at -2 .
      destruct (eucl_dev k h0 n); simpl. destruct (le_gt_dec (k-1) r).
      (* r = k-1 *)
      assert (r = k-1). lia. assert (S n = (S q)*k + 0). rewrite mult_succ_l.
      lia. rewrite H1. unfold seq. destruct (eucl_dev k h0 (S q * k + 0)).
      destruct (eucl_div_unique h0 g1 e0). rewrite <- H3, <- H2. simpl.
      rewrite <- iter_com. apply red_iter. apply red_g.
      rewrite H0. fold last_term. rewrite last_term_g.
      apply red_g. unfold nth.
      change (red R (List.nth 0 (t :: us) default)
        (List.nth 1 (t :: us) default)).
      apply FS_red. apply (rewrites_correct h1). hyp.
      (* r < k-1 *)
      assert (S n = q*k + S r). lia. rewrite H0. unfold seq.
      destruct (eucl_dev k h0 (q * k + S r)). assert (k>S r). lia.
      destruct (eucl_div_unique H1 g2 e0). rewrite <- H3, <- H2.
      apply red_iter. apply red_g. apply FS_red'. lia.
    Qed.

    Lemma loop : EIS (red R).

    Proof.
      exists seq. apply IS_seq.
    Qed.

  End loop.

(***********************************************************************)
(** boolean function testing non-termination *)

  Definition is_loop t ds p :=
    match rewrites t ds with
      | None => false
      | Some us =>
        match us with
          | nil => false
          | _ =>
            let u := last us default in
              match subterm_pos u p with
                | None => false
                | Some v =>
                  match matches t v with
                    | None => false
                    | Some _ => true
                  end
              end
        end
    end.

  Lemma is_loop_correct : forall t ds p, is_loop t ds p = true -> EIS (red R).

  Proof.
    intros t ds p. unfold is_loop. case_eq (rewrites t ds). 2: discr.
    destruct l. discr. set (us := t0::l). set (u := last us default).
    case_eq (subterm_pos u p). 2: discr. intro v.
    case_eq (matches t v); intros.
    2: discr. assert (h0 : k us > 0). unfold k, us. simpl. lia.
    assert (h : u = last_term us). unfold last_term, k, nth.
    rewrite <- last_nth.
    refl. rewrite h in H0. exists (seq us h0 p H0 t1). eapply IS_seq. apply H1.
    hyp.
  Qed.

End S.

Arguments rewrite_correct [Sig R t d u] _.
Arguments rewrites_correct [Sig R ds t us] _.

(***********************************************************************)
(** tactics *)

Ltac check_loop t' ds' p' :=
  apply is_loop_correct with (t:=t') (ds:=ds') (p:=p');
    (check_eq || fail 10 "not a loop").

Ltac loop t' ds' p' :=
  match goal with
    | |- EIS (red_mod ?E _) =>
      remove_relative_rules E; check_loop t' ds' p'
    | |- EIS (red _) => check_loop t' ds' p'
  end.


From mathcomp Require Import all_ssreflect all_algebra.
From rlzrs Require Import all_rlzrs.
Require Import FunctionalExtensionality.
Require Import all_cs Rstruct under.
From metric Require Import reals metric standard.
Require Import Reals Qreals Psatz ClassicalChoice.

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope R_scope.

Section signed_digits.
Inductive SD := minusone | zero | one.

Definition SD2OB sd := match sd with
	| minusone => some false
	| zero => None
	| one => some true
end.

Lemma SD_eqClass: Equality.class_of SD.
Proof.
exists (fun sd sd' => (SD2OB sd == SD2OB sd')%bool).
by case; case; try exact: ReflectT; try exact: ReflectF.
Qed.

Canonical SD_eqType := Equality.Pack SD_eqClass Type.

Lemma SD_count: SD \is_countable.
Proof.
apply/enum_count.
exists (fun n => match n with
	 | 0%nat => Some minusone
	 | S 0 => Some zero
	 | S (S n) => Some one
         end).
by case; [exists 0%nat | exists 1%nat | exists 2%nat].
Qed.

Definition SD2Z sd : Z := match sd with
	| one => 1%Z
	| zero => 0%Z
	| minusone => -1%Z
end.
End signed_digits.

Section SDs.
Fixpoint SDs2Zn (sds: nat -> SD) n := match n with
	| 0%nat => 0%Z
	| m.+1 => (2 * SDs2Zn sds m + SD2Z (sds m))%Z
end.

Lemma SDs2ZnS sds n :
	SDs2Zn sds n.+1 = (2 * SDs2Zn sds n + SD2Z (sds n))%Z.
Proof. by trivial. Qed.

Definition SD2R sd := match sd with
	| one => 1
	| zero => 0
	| minusone => -1
end.

Lemma IZR_SD2Z_SD2R sd: SD2R sd = IZR (SD2Z sd).
Proof. by case: sd. Qed.

Definition SDs2Rn (sds: nat -> SD) n := \sum_(i < n) SD2R (sds i) * /2 ^ i.+1.

Lemma SDs2Rn_SDs2Zn sds n: SDs2Rn sds n = IZR (SDs2Zn sds n) / 2^n.
Proof.
elim: n => [ | n ih]; first by rewrite /SDs2Rn big_ord0 /GRing.zero /=; try lra.
rewrite SDs2ZnS plus_IZR mult_IZR Rdiv_plus_distr Rmult_comm /Rdiv.
rewrite /SDs2Rn in ih.
rewrite /SDs2Rn big_ord_recr /= ih IZR_SD2Z_SD2R Rmult_assoc.
have ->: 2 * / (2 * 2 ^ n) = / 2 ^ n by have lt:= pow_lt 2 n; rewrite Rinv_mult_distr; try lra.
rewrite /GRing.mul/GRing.add/=; try lra.
Qed.

Lemma SDs2Zn_SDs2Rn sds n: IZR (SDs2Zn sds n) = 2 ^ n * SDs2Rn sds n.
Proof.
have lt:= pow_lt 2 n.
by rewrite SDs2Rn_SDs2Zn /Rdiv Rmult_comm Rmult_assoc Rinv_l; try lra.
Qed.

Lemma SDs2Rn0 sds: SDs2Rn sds 0%nat = 0.
Proof. by rewrite /SDs2Rn big_ord0. Qed.

Lemma Rabs_SDs2Rn u n : Rabs (SDs2Rn u n) <= 1 - /2^n.
Proof.
rewrite /SDs2Rn; case: n => [ | n]; first by rewrite big_ord0/= /GRing.zero /=; split_Rabs; lra.
elim: n => [ | n ih].
	rewrite /SDs2Rn big_ord1/= /GRing.mul /=.
	by case: (u 0%nat) => /=; split_Rabs; try lra.
rewrite /SDs2Rn big_ord_recr/=.
have p2lt: 0 < /2^n by apply /Rinv_0_lt_compat/pow_lt; lra.
have p2lt': 0 < 2^n by apply /pow_lt; lra.
apply/Rle_trans; first exact/Rabs_triang.
have ->: 1 - / (2 * (2 * 2 ^ n)) = 1 - /2^n.+1 + (/2^n.+1 -  / (2 * (2 * 2 ^ n))) by lra.
apply Rplus_le_compat; first exact ih; rewrite !Rinv_mult_distr; try lra.
by case: (u n.+1); rewrite /GRing.mul /= ?Rmult_0_l; split_Rabs; try lra.
Qed.

Lemma SDs2RnS sds n : SDs2Rn sds n.+1 = SDs2Rn sds n + SD2R (sds n) * /2^n.+1.
Proof.
by rewrite /SDs2Rn big_ord_recr /=.
Qed.

Lemma SDs2RSn sds n : SDs2Rn sds n.+1 = /2 * SDs2Rn (fun i => sds i.+1) n + /2 * SD2R (sds 0%nat).
Proof.
rewrite /SDs2Rn big_ord_recl /= addrC.
congr (_ + _); last rewrite Rmult_1_r /GRing.mul /=; try lra.
elim: n => [ | n ih]; first by rewrite !big_ord0 /GRing.zero /=; lra.
rewrite big_ord_recr /= ih [\sum_(i < n.+1) _] big_ord_recr /=.
have ->: bump 0%nat n = n.+1 by rewrite /bump.
rewrite Rmult_plus_distr_l.
congr (_ + _).
have plt:= pow_lt 2 n.
by rewrite !Rinv_mult_distr /GRing.mul /=; try lra.
Qed.

Lemma Rabs_SDs2Rnm sds n m (ineq: (n <= m)%nat):
	Rabs (SDs2Rn sds m - SDs2Rn sds n) <= /2^n  - /2^m.
Proof.
elim: n m ineq sds => [m ineq sds| n ih m ineq].
	rewrite {2}/SDs2Rn big_ord0 Rminus_0_r Rinv_1; exact: Rabs_SDs2Rn.
move => sds; case: m ih ineq => // m ih ineq.
rewrite !SDs2RSn; specialize (ih m ineq (fun i => sds i.+1)).
have lt1:= pow_lt 2n; have lt2:= pow_lt 2 m; rewrite /= !Rinv_mult_distr; split_Rabs; try lra.
Qed.

Lemma fchy_SDs2Rn sds : fast_Cauchy_sequence (SDs2Rn sds).
Proof.
move => n m; have lt: 0 < /2 ^ m by apply/Rinv_0_lt_compat/pow_lt; lra.
have lt': 0 < /2 ^ n by apply/Rinv_0_lt_compat/pow_lt; lra.
case/orP: (leq_total n m) => ineq; first rewrite dst_sym;
  by apply/Rle_trans; first apply/Rabs_SDs2Rnm => //; lra.
Qed.

Lemma cchy_SDs2Rn sds :	Cauchy_sequence (SDs2Rn sds).
Proof. exact/fchy_cchy/fchy_SDs2Rn. Qed.

Definition SDs2R := limit \o (F2MF SDs2Rn).

Lemma SDs2R_tot: SDs2R \is_total.
Proof.
  rewrite /SDs2R comp_F2MF => sds.
  have [x xprp]:= R_cmplt (cchy_SDs2Rn sds).
  by exists x.
Qed.

Lemma SDs2R_sing: SDs2R \is_singlevalued.
Proof. by apply /comp_sing; [exact /lim_sing | exact /F2MF_sing]. Qed.

Notation lim_eff:= (@efficient_limit metric_R).

Lemma SDs2R_lim_eff: SDs2R =~= lim_eff \o (F2MF SDs2Rn).
Proof.
rewrite /SDs2R lim_eff_spec !comp_F2MF => sds x.
split => [limx | [cchy limx]]//.
by split; first by have := fchy_SDs2Rn sds.
Qed.

Lemma SDs2R_eff sds x: SDs2R sds x <-> lim_eff (SDs2Rn sds) x.
Proof. have:= SDs2R_lim_eff; rewrite comp_F2MF => prp; apply prp. Qed.

Lemma SDs2R_UI u x: SDs2R u x -> -1 <= x <= 1.
Proof.
move => /SDs2R_eff val; move: (val 0%nat) => /=.
rewrite /SDs2Rn big_ord0 /distance/= Rminus_0_r; split_Rabs; lra.
Qed.
End SDs.

Section Lists.
Fixpoint SDL2R L:= match L with
	| [::] => 0
	| sd :: K => SDL2R K + SD2R sd * /2 ^ (size L)
end.

Lemma SDL2RS sd L: SDL2R (sd :: L) = SDL2R L + SD2R sd * /2 ^ (size L).+1.
Proof. done. Qed.

Fixpoint SDL2Z L := match L with
	| [::] => 0%Z
	| sd :: K => (2 * SDL2Z K + SD2Z sd)%Z
end.

Lemma SDL2ZS a L: SDL2Z (a :: L) = (2 * SDL2Z L + SD2Z a)%Z.
Proof. done. Qed.

Lemma SDL2Z_SDL2R L: IZR (SDL2Z L) = SDL2R L * 2^(size L).
Proof.
elim: L => [ | a L]; first by rewrite /=; lra.
rewrite SDL2ZS [RHS]/= plus_IZR mult_IZR => -> /=; have lt:= pow_lt 2 (size L).
rewrite Rmult_plus_distr_r Rmult_assoc Rinv_l ?IZR_SD2Z_SD2R; try lra.
Qed.

Lemma SDs2Zn_SDL2Z sds n:
	SDs2Zn sds n = SDL2Z (iseg sds n).
Proof. by elim: n => // n ih; rewrite SDs2ZnS ih. Qed.

Lemma SDs2Rn_SDL2R sds n:
	SDs2Rn sds n = SDL2R (iseg sds n).
Proof.
elim: n => [ | n ih]; first by rewrite /SDs2Rn big_ord0.
by rewrite /= SDs2RnS /= size_iseg ih.
Qed.
End Lists.

Section rep_UI.
Definition UI := { x | -1 <= x <= 1}.

Definition rep_UI := make_mf (fun sds (x: UI) => SDs2R sds (projT1 x)).

Lemma rep_UI_tot: rep_UI \is_total.
Proof.
by move => sds; have [x val]:= SDs2R_tot sds; exists (exist _ x (SDs2R_UI sds x val)).
Qed.

Lemma rep_UI_sing: 	rep_UI \is_singlevalued.
Proof.
move => sds x y sdsnx sdsny; apply /eq_sub /SDs2R_sing; [apply sdsnx | apply sdsny].
Qed.

Definition rep_UI_inc := make_mf (fun phi (x: UI) =>
	forall L, Rabs (projT1 x - SDL2R L) <= /2^(size L)
	->
	Rabs (projT1 x - SDL2R (phi L :: L)) <= /2^(size L).+1).

Fixpoint UI_inc_to_UI_rec (Lf: seq SD -> SD) m := match m with
	| 0%nat => [::]
	| S k => (Lf (UI_inc_to_UI_rec Lf k):: UI_inc_to_UI_rec Lf k)
end.

Lemma UI_inc_to_UI_rec_size Lf n:
	size (UI_inc_to_UI_rec Lf n) = n.
Proof. by elim: n => // n /= ->. Qed.

Definition UI_inc_to_UI (Lf: seq SD -> SD) n := Lf (UI_inc_to_UI_rec Lf n).

Lemma UI_inc_to_UI_inseg Lf n:
	iseg (UI_inc_to_UI Lf) n = UI_inc_to_UI_rec Lf n.
Proof. by elim :n => // n /= ->. Qed.

Lemma UI_inc_to_UI_correct Lf x:
	rep_UI_inc Lf x -> rep_UI (UI_inc_to_UI Lf) x.
Proof.
Admitted.
(* move: x => [x ineq] Lfnx; rewrite /rep_UI SDs2R_eff; elim => [ | n /=].
	by rewrite /= SDs2Rn0; split_Rabs; try lra.
rewrite SDs2RnS SDs2Rn_SDL2R Rabs_minus_sym UI_inc_to_UI_inseg.
have ltn: 0<2^n by apply pow_lt; lra.
rewrite -{2}(UI_inc_to_UI_rec_size Lf n); try lra; move => ih.
have /=:= Lfnx (UI_inc_to_UI_rec Lf n) ih.
by rewrite UI_inc_to_UI_rec_size Rabs_minus_sym.
Qed.*)

Lemma rep_UI_inc_sing: rep_UI_inc \is_singlevalued.
Proof.
move => Lf x y Lfnx Lfny.
by apply /(rep_UI_sing (UI_inc_to_UI Lf)); apply UI_inc_to_UI_correct.
Qed.

Lemma rep_UI_inc_nc (x: UI):
	(forall q, exists a, Rabs (projT1 x - SDL2R q) <= /2^(size q)
		-> Rabs (projT1 x - SDL2R (a :: q)) <= /2^(size q).+1)
	-> x \from codom rep_UI_inc.
Proof. by move => R; apply (choice _ R). Qed.

Lemma rep_UI_inc_sur: rep_UI_inc \is_cototal.
Proof.
move => [x ineq].
apply rep_UI_inc_nc => sdL.
case: (classic (x <= SDL2R sdL)) => leq.
	exists minusone => /= ineq'.
have leq':= pow_lt 2 (size sdL).
	rewrite Rinv_mult_distr; try lra.
	have leq'': 0 < /2 ^ (size sdL) by apply Rinv_0_lt_compat; lra.
	by split_Rabs; try lra.
exists one => /= ineq'.
have leq':= pow_lt 2 (size sdL).
rewrite Rinv_mult_distr; try lra.
have leq'': 0 < /2 ^ (size sdL) by apply Rinv_0_lt_compat; lra.
by split_Rabs; try lra.
Qed.

Definition UI_inc := make_cs [::] zero (list_count SD_count) SD_count rep_UI_inc_sur rep_UI_inc_sing.

Lemma rep_UI_sur: rep_UI \is_cototal.
Proof.
move => x.
have [Lf Lfnx]:= rep_UI_inc_sur x.
exists (UI_inc_to_UI Lf).
by apply UI_inc_to_UI_correct.
Qed.

Definition cs_UI:= make_cs 0%nat zero nat_count SD_count rep_UI_sur rep_UI_sing.
End rep_UI.

Section SD_and_SD_inc.
(* The representation rec_SD_inc provides more information about signed digits:
One can extend any valid begining segment of a name in the usual representation
to a full name. Its definition is convenient for proving the signed digit representation
surjective and it is comptuationally equivalent. The equivalence is currently not executable
since I couldn't figure out how to properly do branching on rational numbers.*)

(* This function should do the branching over the rational numbers so it
is executable. *)
Definition UI_to_UI_inc sds L :=
	if is_left (Z_lt_dec (SDs2Zn sds (size L).+1) (2 * SDL2Z L)) then minusone
		else if is_left (Z_lt_dec (2 * SDL2Z L) (SDs2Zn sds (size L).+1)) then one
			else zero.

Fixpoint sds n := match n with
	| 0%nat => one
	| S 0 => zero
	| S (S 0) => minusone
	| S (S (S n)) => sds n
end.

(*
Lemma UI_to_UI_inc_correct sds x:
	rep_UI sds x -> rep_UI_inc (UI_to_UI_inc sds) x.
Proof.
move: x => [x xui] /SDs2R_eff /= sdsnx L /= ineq1.
have g0: 0 < 2 ^ size L by apply pow_lt; lra.
have := sdsnx (size L).+1; rewrite Rabs_minus_sym Rinv_mult_distr; try lra.
move => ineq2.
rewrite /UI_to_UI_inc; case: ifP; case: Z_lt_dec => // lt _.
- move/(Zlt_le_succ _ _)/IZR_le: lt.
  rewrite /Z.succ plus_IZR mult_IZR SDs2Zn_SDs2Rn SDL2Z_SDL2R => /= lt.
  have ineq3: (SDs2Rn sds (size L).+1) <= SDL2R L - /2* /2^size L.
  + apply: (Rmult_le_reg_r (2* 2^size L)); try lra.
    rewrite [(_ - _) * _]Rmult_comm Rmult_minus_distr_l.
    by rewrite -Rinv_mult_distr; try lra; rewrite Rinv_r; lra.
    split_Rabs; try lra.
    admit.
case: ifP; case: Z_lt_dec => // gt _.
- move/(Zlt_le_succ _ _)/IZR_le: gt.
  rewrite /Z.succ plus_IZR mult_IZR SDs2Zn_SDs2Rn SDL2Z_SDL2R => /= gt.
  + have ineq3: (SDL2R L) <= SDs2Rn sds (size L).+1 - /2* /2^size L.
		apply: (Rmult_le_reg_r (2* 2^size L)); try lra.
		rewrite [(_ - _) * _]Rmult_comm Rmult_minus_distr_l.
		by rewrite -Rinv_mult_distr; try lra; rewrite Rinv_r; lra.
	        split_Rabs; try lra.
                admit.
have eq: (SDs2Zn sds (size L).+1 = 2 * SDL2Z L)%Z by lia.
have:= IZR_eq _ _ eq.
move: eq; rewrite SDs2Zn_SDs2Rn mult_IZR SDL2Z_SDL2R /= => _ eq.
have: (SDs2Rn sds (size L).+1 = SDL2R L).
	apply: (Rmult_eq_reg_l (2 * 2 ^size L)); lra.
by move <-; split_Rabs; try lra.
Qed.
*)
(* Lemma UI_UI_inc_iso: wisomorphic rep_space_UI rep_space_UI_inc.
Proof.
do 2 exists ((fun x y => x = y)).
split; last split; last by split => x y; apply comp_id_l.
	apply rec_cmpt; exists UI_to_UI_inc => phi x phinx _.
	by exists x; split => //; apply UI_to_UI_inc_correct.
apply rec_cmpt; exists UI_inc_to_UI => phi x phinx _.
by exists x; split => //; apply UI_inc_to_UI_correct.
Qed.*)
End SD_and_SD_inc.

Section sd_coinduction.
(*
Lemma SDs2R_hd sds x: SDs2R sds x -> - 1 <= 2 * x - SD2R (sds 0%nat) <= 1.
Proof.
move: x => x; rewrite /=/GRing.zero /=. SDs2R_eff => unx.
specialize (unx 1%nat); move: unx; rewrite /SDs2Rn big_ord1.
by case: (sds 0%nat) => /=; rewrite /GRing.mul /=; split_Rabs; lra.
Qed.*)
(*
Lemma SDs2R_tl sds x: SDs2R sds x -> SDs2R (fun n => sds n.+1) (2 * x - SD2R (sds 0%nat)).
Proof.
rewrite !SDs2R_eff => unx n; apply: (Rmult_le_reg_l (/2)); try lra.
rewrite -[/2 * / _]Rinv_mult_distr; try lra; last by have:= pow_lt 2 n; lra.
apply/ Rle_trans; last by apply: unx n.+1.
rewrite {2}/SDs2Rn big_ord_recl /= /SDs2Rn.
suff <- : (/ 2 * \sum_(i < n) SD2R (sds i.+1) * /2 ^ i.+1) = \sum_(i < n) SD2R (sds (bump 0 i)) * / (2 * (2 * 2 ^ i)) by rewrite /GRing.mul /GRing.add/=; split_Rabs; try lra.
elim: n => [ | n ih]; first by rewrite !big_ord0 /GRing.zero /=; lra.
have p2lt: 0 < 2^n by apply pow_lt; lra.
rewrite big_ord_recr/= Rmult_plus_distr_l ih [RHS]big_ord_recr/=.
congr (_ + _).
have -> : bump 0 n = n.+1%nat by trivial.
rewrite !Rinv_mult_distr; try lra.
by rewrite /GRing.mul/=; try lra.
Qed.*)
End sd_coinduction.

Section output_and_examples.
Definition SDs2Qn sds n := (inject_Z (SDs2Zn sds n) / (2#1)^Z.of_nat n)%Q.
(*Example: Compute Qreduction.Qred (SDs2Qn sds 17). *)
End output_and_examples.

Section all_reals.
Definition ZUI2R (zx: Z * UI) := IZR zx.1 + projT1 zx.2.

Definition count_pos n := match n with
	| 0%nat => None
	| S n => Some (Pos.of_nat n)
end.

Lemma count_pos_sur: count_pos \is_surjective.
Proof.
case => [p | ]; last by exists 0%nat.
by exists (Pos.to_nat p).+1; rewrite /count_pos Pos2Nat.id.
Qed.

Definition cs_Z:= @cs_id Z (1%Z) Z_count.

Definition rep_R := (F2MF ZUI2R) \o (@representation (cs_Z \*_cs cs_UI)).

(*
Lemma rep_R_sur: rep_R \is_cototal.
Proof.
move => x; have ineq: -1 <= x - up x <= 1 by have := archimed x; lra.
pose y:UI := (exist _ (x - up x) ineq).
have [phi2 phi2ny]:= rep_UI_sur y.
pose phi1: names cs_Z := (fun _ => up x).
exists (name_pair phi1 (phi2: names UI_sd_cs)).
split; last by move => a b; apply F2MF_tot.
exists (up x, y).
split; last by rewrite /F2MF /y /ZUI2R /=; lra.
rewrite /=/prod_rep.
have ->:= @lprj_pair cs_Z UI_sd_cs.
by have ->:= @rprj_pair cs_Z UI_sd_cs.
Qed.
*)
Lemma rep_R_sing: rep_R \is_singlevalued.
Proof. apply/comp_sing; [apply: F2MF_sing | by have:=(@rep_sing (cs_Z \*_cs cs_UI)) ]. Qed.

(*
Canonical cs_R := @continuity_space.Pack R _ _ rep_R (some_question _) (some_answer _) (countable_questions _) (countable_answers _) rep_R_is_rep.
*)
End all_reals.


Set Implicit Arguments.

Require Import Coq.Program.Basics.
Require Import Coq.micromega.Lia.
Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qabs.
Require Import Coq.micromega.Lqa.
Require Import List.
Import ListNotations.

Require Import axioms.
Require Import misc.
Require Import order.
Require Import Q.

Local Open Scope program_scope.

(** A real number in the unit interval represented by its infinite
    binary expansion. *)
Definition real : Type := nat -> bool.

Definition real_zero : real := const false.
Definition real_one : real := const true.

(** Non-empty binary intervals. *)
Definition interval : Type := list bool.

(** Measurable sets generated by binary intervals and closed under
    countable union. *)
Inductive meas : Type :=
| meas_empty : meas
| meas_interval : interval -> meas
| meas_union : (nat -> meas) -> meas.

(** The Borel measure of a binary interval. *)
Definition interval_measure (bs : interval) : Q :=
  1 / (Qpow 2 (length bs)).

(** We can directly compute the intersection of two binary intervals,
    producing a new interval, or None if the intersection is empty. *)
Fixpoint interval_intersection (u v : list bool) : option (interval) :=
  match (u, v) with
  | ([], _) => Some v
  | (_, []) => Some u
  | (x :: xs, y :: ys) =>
    match interval_intersection xs ys with
    | None => None
    | Some zs =>
      if eqb x y then Some (x :: zs) else None
    end
  end.

Inductive comparable {A : Type} : list A -> list A -> Prop :=
| comparable_nil1 : forall l2,
    comparable nil l2
| comparable_nil2 : forall l1,
    comparable l1 nil
| comparable_cons : forall x l1 l2,
    comparable l1 l2 ->
    comparable (x :: l1) (x :: l2).

Inductive incomparable {A : Type} : list A -> list A -> Prop :=
| incomparable_head : forall x y xs ys,
    x <> y ->
    incomparable (x :: xs) (y :: ys)
| incomparable_tail : forall x xs ys,
    incomparable xs ys ->
    incomparable (x :: xs) (x :: ys).

Lemma not_incomparable_comparable {A : Type} `{EqType A} (l1 l2 : list A) :
  not (incomparable l1 l2) <-> comparable l1 l2.
Proof.
  split.
  - revert l2.
    induction l1; intros [] Hnotincomp; try constructor.
    destruct (eqb_spec a a0); subst.
    + constructor.
      apply IHl1.
      intro HC. apply Hnotincomp.
      apply incomparable_tail; auto.
    + exfalso; apply Hnotincomp; constructor; auto.
  - induction 1; intro HC; inversion HC; subst; congruence.
Qed.

Lemma incomparable_not_comparable {A : Type} `{EqType A} (l1 l2 : list A) :
  incomparable l1 l2 <-> ~ comparable l1 l2.
Proof.
  split.
  - induction 1; intro HC; inversion HC; subst; congruence.
  - revert l2.
    induction l1; intros l2 Hnotcomp.
    + exfalso; apply Hnotcomp; constructor.
    + destruct l2.
      * exfalso; apply Hnotcomp; constructor.
      * destruct (eqb_spec a a0); subst.
        -- right. apply IHl1.
           intro HC. apply Hnotcomp. constructor; auto.
        -- constructor; auto.
Qed.

Lemma is_prefix_comparable {A : Type} (l1 l2 : list A) :
  comparable l1 l2 <-> is_prefix l1 l2 \/ is_prefix l2 l1.
Proof.
  split.
  - intro Hcomp.
    induction Hcomp; try solve [repeat constructor].
    destruct IHHcomp; solve [repeat constructor; auto].
  - intros [Hpre | Hpre]; induction Hpre; constructor; auto.
Qed.

Lemma incomparable_refl {A : Type} `{EqType A} (l : list A) :
  ~ incomparable l l.
Proof.
  intro HC; apply incomparable_not_comparable in HC.
  apply HC, is_prefix_comparable; left; reflexivity.
Qed.

Instance Symmetric_comparable {A : Type} : Symmetric (@comparable A).
Proof. intros x y; induction 1; constructor; auto. Qed.

Instance Symmetric_incomparable {A : Type} `{EqType A} : Symmetric (@incomparable A).
Proof.
  intros x y H0.
  eapply incomparable_not_comparable.
  eapply incomparable_not_comparable in H0.
  intro HC; apply H0; symmetry; auto.
Qed.

Lemma incomparable_app_l {A : Type} (l1 l1' l2 l2' : list A) :
  incomparable l1 l1' ->
  incomparable (l1 ++ l2) (l1' ++ l2').
Proof.
  intro H.
  revert l2 l2'.
  induction H; intros l2 l2'.
  - constructor; auto.
  - simpl; right; auto.
Qed.

Lemma incomparable_app_r {A : Type} (l1 l2 l2' : list A) :
  incomparable l2 l2' ->
  incomparable (l1 ++ l2) (l1 ++ l2').
Proof.
  revert l2 l2'.
  induction l1; simpl; intros l2 l2' H; auto.
  right; auto.
Qed.

Lemma incomparable_app_l' {A : Type} (l l1 l2 : list A) :
  incomparable l l1 ->
  incomparable l (l1 ++ l2).
Proof.
  intro H.
  replace l with (l ++ []) by apply app_nil_r.
  apply incomparable_app_l; auto.
Qed.

Inductive lists_eq_or_incomparable {A : Type} : list (list A) -> list (list A) -> Prop :=
| leoi_nil_l : forall ls, lists_eq_or_incomparable nil ls
| leoi_nil_r : forall ls, lists_eq_or_incomparable ls nil
| leoi_cons_eq : forall l ls1 ls2,
    lists_eq_or_incomparable ls1 ls2 ->
    lists_eq_or_incomparable (l :: ls1) (l :: ls2)
| leoi_cons_incomparable : forall l1 l2 ls1 ls2,
    incomparable l1 l2 ->
    lists_eq_or_incomparable ls1 ls2 ->
    lists_eq_or_incomparable (l1 :: ls1) (l2 :: ls2).

Inductive lists_incomparable {A : Type} : list (list A) -> list (list A) -> Prop :=
| lists_incomparable_head : forall l1 l2 ls1 ls2,
    incomparable l1 l2 ->
    lists_incomparable (l1 :: ls1) (l2 :: ls2)
| lists_incomparable_tail : forall l ls1 ls2,
    lists_incomparable ls1 ls2 ->
    lists_incomparable (l :: ls1) (l :: ls2).

Lemma lists_incomparable_app_l {A : Type} (a b c d : list (list A)) :
  lists_incomparable a c ->
  lists_incomparable (a ++ b) (c ++ d).
Proof.
  intro H; revert b d; induction H; intros b d.
  - constructor; auto.
  - right; auto.
Qed.

Lemma incomparable_concat {A : Type} `{EqType A} (l1 l2 : list A) (ls1 ls2 : list (list A)) :
  lists_eq_or_incomparable ls1 ls2 ->
  incomparable l1 l2 ->
  (forall l, In l ls1 -> incomparable l l2) ->
  (forall l, In l ls2 -> incomparable l l1) ->
  incomparable (concat ls1 ++ l1) (concat ls2 ++ l2).
Proof.
  intro H0.
  revert l1 l2.
  induction H0; simpl; intros l1' l2' H0' H1' H2; auto.
  - destruct ls; auto; simpl; rewrite <- app_assoc.
    apply incomparable_app_l'.
    symmetry; apply H2; left; reflexivity.
  - destruct ls; auto; simpl; rewrite <- app_assoc.
    symmetry; apply incomparable_app_l'; symmetry; apply H1'; left; reflexivity.
  - rewrite <- 2!app_assoc.
    apply incomparable_app_r.
    apply IHlists_eq_or_incomparable; auto.
  - rewrite <- 2!app_assoc.
    apply incomparable_app_l; auto.
Qed.

Lemma lists_incomparable_concat {A : Type} (ls1 ls2 : list (list A)) :
  lists_incomparable ls1 ls2 ->
  incomparable (concat ls1) (concat ls2).
Proof.
  intro H0; induction H0.
  - apply incomparable_app_l; auto.
  - apply incomparable_app_r; auto.
Qed.

Definition interval_disjoint (a b : interval) : Prop := incomparable a b.

Inductive disjoint : meas -> meas -> Prop :=
| disjoint_empty_1 : forall U,
    disjoint U meas_empty
| disjoint_empty_2 : forall U,
    disjoint meas_empty U
| disjoint_interval : forall a b,
    interval_disjoint a b ->
    disjoint (meas_interval a) (meas_interval b)
| disjoint_union : forall f g,
    (forall i j, disjoint (f i) (g j)) ->
    disjoint (meas_union f) (meas_union g).

Inductive partial_sumP (R : nat -> Q -> Prop) : nat -> Q -> Prop :=
| partial_sumP_O : forall q,
    R O q ->
    partial_sumP R O q
| partial_sumP_S : forall n p q s,
    partial_sumP R n q ->
    R (S n) p ->
    s == p + q ->
    partial_sumP R (S n) s.

Definition f_relation {A B : Type} (f : A -> B) (R : A -> B -> Prop) :=
  forall x, R x (f x).

Lemma fold_right_Qplus_app (l1 l2 : list Q) :
  fold_right Qplus 0 (l1 ++ l2) ==
  fold_right Qplus 0 l1 + fold_right Qplus 0 l2.
Proof. induction l1; simpl; lra. Qed.

(** The Borel measure of a measurable set. *)
Inductive measure : meas -> Q -> Prop :=
| measure_empty : forall m,
    m == 0 ->
    measure meas_empty m
| measure_interval : forall i m,
    m == interval_measure i ->
    measure (meas_interval i) m
| measure_union : forall f g m,
    (forall i j, i <> j -> disjoint (f i) (f j)) ->
    (forall i, measure (f i) (g i)) ->
    supremum m (partial_sum g) ->
    measure (meas_union f) m.

Fixpoint real_in_intervalb_aux (r : real) (i : interval) (n : nat) : bool :=
  match i with
  | [] => true
  | b :: bs => eqb (r n) b && real_in_intervalb_aux r bs (S n)
  end.

Definition real_in_intervalb (r : real) (i : interval) : bool :=
  real_in_intervalb_aux r i O.

Inductive real_in_interval_aux : real -> interval -> nat -> Prop :=
| real_in_interval_nil : forall r n,
    real_in_interval_aux r [] n
| real_in_interval_cons : forall r bs n,
    real_in_interval_aux r bs (S n) ->
    real_in_interval_aux r (r n :: bs) n.

Definition real_in_interval (r : real) (i : interval) : Prop :=
  real_in_interval_aux r i O.

Lemma real_in_intervalb_aux_spec (r : real) (i : interval) (n : nat)
  : reflect (real_in_interval_aux r i n) (real_in_intervalb_aux r i n).
Proof.
  revert r n.
  induction i; intros r n; simpl.
  - repeat constructor.
  - destruct (Bool.eqb (r n) a) eqn:Heq; simpl.
    + apply eqb_prop in Heq; subst.
      destruct (IHi r (S n)).
      * repeat constructor; auto.
      * constructor; intro HC; inversion HC; subst; congruence.
    + apply eqb_false_iff in Heq.
      constructor; intro HC; inversion HC; subst; congruence.
Qed.

Lemma real_in_intervalb_spec (r : real) (i : interval)
  : reflect (real_in_interval r i) (real_in_intervalb r i).
Proof. apply real_in_intervalb_aux_spec. Qed.

Lemma bool_dec (x : bool) :
  x = true \/ ~ x = true.
Proof. destruct x; auto. Qed.

Lemma bool_sumbool (x : bool) :
  {x = true} + {~ x = true}.
Proof. destruct x; auto. Defined.

Fixpoint real_in_measb (U : meas) (r : real) : bool :=
  match U with
  | meas_empty => false
  | meas_interval i => real_in_intervalb r i
  | meas_union f =>
    if strong_LPO (fun n => bool_sumbool (real_in_measb (f n) r))
    then true else false
  end.

Inductive real_in_meas : meas -> real -> Prop :=
| real_in_meas_interval : forall r i,
    real_in_interval r i ->
    real_in_meas (meas_interval i) r
| real_in_meas_union : forall r f,
    (exists n, real_in_meas (f n) r) ->
    real_in_meas (meas_union f) r.

Lemma real_in_measb_spec (U : meas) (r : real)
  : reflect (real_in_meas U r) (real_in_measb U r).
Proof.
  induction U; simpl.
  - constructor; intro HC; inversion HC.
  - destruct (real_in_intervalb_spec r i); constructor.
    + constructor; auto.
    + intro HC. apply n.
      inversion HC; subst; auto.
  - destruct (strong_LPO (* (fun n : nat => real_in_measb (m n) r = true) *)
                (fun n : nat => bool_sumbool (real_in_measb (m n) r))).
    + constructor; constructor.
      destruct e as [n Hn].
      exists n. destruct (H n); auto; congruence.
    + constructor.
      intro HC. inversion HC; subst.
      destruct H1 as [x H2].
      apply n; exists x; destruct (H x); auto.
Qed.

Lemma comparable_prefix {A : Type} (f : nat -> A) (n m : nat) :
  comparable (prefix f n) (prefix f m).
Proof.
  apply is_prefix_comparable.
  destruct (Nat.le_decidable n m);
    solve [constructor; apply prefix_is_prefix; lia].
Qed.

Inductive nth_element {A : Type} : nat -> list A -> A -> Prop :=
| nth_element_O : forall x xs,
    nth_element O (x :: xs) x
| nth_element_S : forall x xs y n,
    nth_element n xs y ->
    nth_element (S n) (x :: xs) y.

Lemma lt_length_nth_element {A : Type} (f : nat -> A) (l : list A) (x : A) :
  l <> nil ->
  (forall i, (i < length (x :: l))%nat -> nth_element i (x :: l) (f i)) ->
  forall i, (i < length l)%nat ->
       nth_element i l (f (S i)).
Proof.
  intros Hneq Hnth i Hlt.
  destruct l; try congruence.
  assert (Hlt': (S i < length (x :: a :: l))%nat).
  { simpl in *; lia. }
  specialize (Hnth (S i) Hlt').
  inversion Hnth; subst; auto.
Qed.

Lemma real_in_interval_aux_asdf(r : real) (bs : list bool) (n : nat) :
  (forall i, (i < length bs)%nat -> nth_element i bs (r (i + n)%nat)) ->
  real_in_interval_aux r bs n.
Proof.
  revert n.
  induction bs; intros n Hnth.
  - constructor.
  - simpl in Hnth.
    assert (a = r n).
    { specialize (Hnth O (Nat.lt_0_succ _)).
      inversion Hnth; subst.
      rewrite plus_0_l; reflexivity. }
    subst; constructor.
    destruct bs. constructor.
    apply IHbs.
    intros i Hlt.
    rewrite Nat.add_succ_r.
    set (g := drop r n).
    assert (forall i, g i = r (i + n)%nat).
    { intro m. unfold g. unfold drop; auto. }
    assert (nth_element i (b :: bs) (g (S i))).
    { apply lt_length_nth_element with (x := r n); auto.
      intro HC; congruence. }
    auto.
Qed.

Lemma lt_length_nth_element_app {A : Type} (i : nat) (l1 l2 : list A) (x : A) :
  (i < length l1)%nat ->
  nth_element i l1 x ->
  nth_element i (l1 ++ l2) x.
Proof.
  revert i l2 x.
  induction l1; intros i l2 x Hlt Hnth.
  - inversion Hlt.
  - destruct i; inversion Hnth; subst; constructor.
    apply IHl1; auto; simpl in Hlt; lia.
Qed.

Lemma le_length_nth_element_app {A : Type} (i : nat) (l1 l2 : list A) (x : A) :
  (length l1 <= i)%nat ->
  nth_element (i - length l1) l2 x ->
  nth_element i (l1 ++ l2) x.
Proof.
  revert l2 i x.
  induction l1; simpl; intros l2 i x Hlt Hnth.
  - rewrite Nat.sub_0_r in Hnth; auto.
  - destruct i. lia.
    constructor.
    apply IHl1. lia.
    apply Hnth.
Qed.

Lemma nth_element_slice (r : real) (n m i : nat) :
  (i < length (slice r n m))%nat ->
  nth_element i (slice r n m) (r (i + n)%nat).
Proof.
  revert n i. induction m; simpl; intros n i Hlt.
  - inversion Hlt.
  - unfold slice in *. simpl in *.
    destruct (Nat.ltb_spec0 i m).
    + apply lt_length_nth_element_app. rewrite length_prefix; auto.
      apply IHm. rewrite length_prefix; auto.
    + assert (i = m).
      { rewrite app_length in Hlt.
        rewrite length_prefix in Hlt. simpl in Hlt.
        lia. }
      subst.
      apply le_length_nth_element_app.
      rewrite length_prefix; lia.
      rewrite length_prefix.
      rewrite Nat.sub_diag.
      constructor.
Qed.

Lemma real_in_interval_aux_slice (r : real) (n m : nat) :
  real_in_interval_aux r (slice r n m) n.
Proof.
  apply real_in_interval_aux_asdf.
  apply nth_element_slice.
Qed.

Lemma real_in_interval_prefix (r : real) (n : nat) :
  real_in_interval r (prefix r n).
Proof.
  rewrite <- slice_O.
  apply real_in_interval_aux_slice.
Qed.

Lemma length_slice {A : Type} (f : nat -> A) (n m : nat) :
  length (slice f n m) = m.
Proof.
  induction m; auto.
  unfold slice in *. simpl.
  rewrite app_length.
  rewrite IHm; simpl; lia.
Qed.

Lemma slice_cons {A : Type} (f : nat -> A) (i n : nat) :
  slice f i (S n) = f i :: slice f (S i) n.
Proof.
  revert i.
  induction n; simpl; intro i.
  - reflexivity.
  - unfold slice in *; simpl in *.
    rewrite (IHn i); unfold drop; simpl.
    rewrite plus_n_Sm; reflexivity.
Qed.

Lemma real_in_interval_aux_slice_length (r : real) (bs : interval) (i : nat) :
  real_in_interval_aux r bs i ->
  slice r i (length bs) = bs.
Proof.
  revert i.
  induction bs; simpl; intros i Hin.
  - reflexivity.
  - inversion Hin; subst.
    apply IHbs in H3.
    rewrite <- H3.
    rewrite length_slice.
    apply slice_cons.
Qed.

Lemma real_in_interval_exists_prefix (r : real) (bs : interval) :
  real_in_interval r bs ->
  prefix r (length bs) = bs.
Proof.
  intro Hin.
  apply real_in_interval_aux_slice_length in Hin.
  rewrite slice_O in Hin; auto.
Qed.

Fixpoint count_Q (bs : list bool) : Q :=
  match bs with
  | [] => 0
  | b :: bs' => (if b then 1 else 0) + count_Q bs'
  end.

(** Relational version of count_Q'. *)
Inductive count_QR {A : Type} (P : A -> Prop) : list A -> Q -> Prop :=
| count_QR_nil : forall p,
    p == 0 ->
    count_QR P [] p
| count_QR_cons_false : forall x xs p,
    ~ P x ->
    count_QR P xs p ->
    count_QR P (x :: xs) p
| count_QR_cons_true : forall x xs p q,
    P x ->
    count_QR P xs p ->
    q == p + 1 ->
    count_QR P (x :: xs) q.

Instance Proper_count_QR {A : Type} (P : A -> Prop)
  : Proper (eq ==> Qeq ==> iff) (count_QR P).
Proof.
  intros ? l ? p q Heq; subst.
  split; intro H.
  - induction H; subst.
    + constructor. rewrite <- Heq; auto.
    + constructor; auto.
    + eapply count_QR_cons_true; eauto.
      rewrite <- Heq; auto.
  - induction H; subst.
    + constructor. rewrite Heq; auto.
    + constructor; auto.
    + eapply count_QR_cons_true; eauto.
      rewrite Heq; auto.
Qed.

Fixpoint count_Q' {A : Type} (f : A -> bool) (xs : list A) : Q :=
  match xs with
  | [] => 0
  | x :: xs' => (if f x then 1 else 0) + count_Q' f xs'
  end.

Lemma count_Q'_spec {A : Type} (f : A -> bool) (xs : list A) :
  count_Q' f xs = count_Q (map f xs).
Proof.
  induction xs; simpl; auto.
  rewrite IHxs; auto.
Qed.

Lemma count_Q'_app {A : Type} (f : A -> bool) (l1 l2 : list A) :
  count_Q' f (l1 ++ l2) == count_Q' f l1 + count_Q' f l2.
Proof. induction l1; simpl; lra. Qed.

Lemma count_Q'_rel_eq {A B : Type}
      (f : A -> bool) (g : B -> bool) (xs : list A) (ys : list B) :
  list_rel (fun x y => f x = g y) xs ys ->
  count_Q' f xs = count_Q' g ys.
Proof.
  induction 1; simpl.
  - reflexivity.
  - rewrite H, IHlist_rel; reflexivity.
Qed.

Lemma count_Q'_spec' {A : Type} (P : A -> Prop) (f : A -> bool) (xs : list A) :
  (forall x, reflect (P x) (f x)) ->
  count_QR P xs (count_Q' f xs).
Proof.
  intro Hreflect.
  induction xs; simpl.
  - constructor; reflexivity.
  - specialize (Hreflect a).
    destruct Hreflect.
    + eapply count_QR_cons_true; eauto; field.
    + constructor. congruence.
      rewrite Qplus_0_l; auto.
Qed.

Definition rel_freq {A : Type} (f : A -> bool) (l : list A) : Q :=
  match l with
  | [] => 0
  | _ => count_Q' f l / (Z.of_nat (length l) # 1)
  end.

Lemma rel_freq_eq {A B : Type} (P : A -> bool) (Q : B -> bool) (f : nat -> A) (g : nat -> B) (n : nat) :
  (forall i, P (f i) = Q (g i)) ->
  rel_freq P (prefix f n) == rel_freq Q (prefix g n).
Proof.
  intro Heq.
  destruct n; simpl; try lra.
  simpl; unfold rel_freq.
  destruct (prefix f n ++ [f n]) eqn:Hf.
  - apply app_eq_nil in Hf; destruct Hf; congruence.
  - destruct (prefix g n ++ [g n]) eqn:Hg.
    + apply app_eq_nil in Hg; destruct Hg; congruence.
    + rewrite <- Hf, <- Hg. simpl. f_equal.
      * rewrite 2!app_length.
        rewrite 2!length_prefix; simpl.
        rewrite 2!count_Q'_app.
        simpl. rewrite Heq.
        erewrite count_Q'_rel_eq. reflexivity.
        apply list_rel_prefix; auto.
Qed.

Definition rel_freq' (U : meas) (rs : list real) : Q :=
  rel_freq (real_in_measb U) rs.

(** Relational version of rel_freq using count_QR. Then prove
    equivalence of the two versions. *)
Inductive rel_freqR : meas -> list real -> Q -> Prop :=
| rel_freqR_nil : forall U q,
    q == 0 ->
    rel_freqR U [] q
| rel_freqR_cons : forall U r rs a b,
    count_QR (real_in_meas U) (r :: rs) a ->
    b == a / (Z.of_nat (length (r :: rs)) # 1) ->
    rel_freqR U (r :: rs) b.

Lemma rel_freq_spec (U : meas) (rs : list real) :
  rel_freqR U rs (rel_freq' U rs).
Proof.
  destruct rs; simpl.
  - constructor; reflexivity.
  - econstructor; auto; try reflexivity.
    destruct (real_in_measb_spec U r).
    eapply count_QR_cons_true; auto.
    2: { rewrite Qplus_comm; reflexivity. }
    + apply count_Q'_spec'; intro x; apply real_in_measb_spec.
    + constructor; auto; rewrite Qplus_0_l.
      apply count_Q'_spec'; intro x; apply real_in_measb_spec.
Qed.

Lemma count_QR_deterministic {A : Type} (P : A -> Prop) (l : list A) (p q : Q) :
  count_QR P l p ->
  count_QR P l q ->
  p == q.
Proof.
  revert p q.
  induction l; intros p q H0 H1.
  - inversion H0; inversion H1; subst; lra.
  - inversion H0; inversion H1; subst; try congruence.
    + apply IHl; auto.
    + assert (Heq: p0 == p1).
      { apply IHl; auto. }
      lra.
Qed.

Lemma rel_freqR_deterministic (U : meas) (rs : list real) (p q : Q) :
  rel_freqR U rs p ->
  rel_freqR U rs q ->
  p == q.
Proof.
  induction rs; intros H0 H1.
  - inversion H0; inversion H1; subst; lra.
  - inversion H0; inversion H1; subst.
    rewrite H6, H12. field_simplify_eq.
    + eapply count_QR_deterministic; eauto.
    + simpl; apply Q_neq_0; lia.
Qed.

(* (** Characterization of uniformity of a sequence of real numbers in *)
(*     the unit interval. *) *)
(* Definition uniform (reals : nat -> real) : Prop := *)
(*   forall U : meas, *)
(*   forall m : Q, *)
(*     measure U m -> *)
(*     forall eps : Q, *)
(*       0 < eps -> *)
(*       exists n, Qabs (m - rel_freq' U (prefix reals n)) < eps. *)

(* (** Textbook definition that refers only to intervals. *) *)
(* Definition uniform' (reals : nat -> real) : Prop := *)
(*   forall I : interval, *)
(*   forall eps : Q, *)
(*     0 < eps -> *)
(*     exists n, Qabs (interval_measure I - *)
(*                rel_freq (fun r => real_in_intervalb r I) (prefix reals n)) < eps. *)

(* Lemma uniform'_uniform (reals : nat -> real) : *)
(*   uniform' reals -> uniform reals. *)
(* Proof. *)
(*   unfold uniform, uniform'. *)
(*   intros H U. *)
(*   revert H. revert reals. *)
(*   induction U; intros reals H0 q Hq eps Hlt. *)
(*   - inversion Hq; subst; exists O; rewrite H; simpl; auto. *)
(*   - inversion Hq; subst. *)
(*     specialize (H0 i eps Hlt). *)
(*     destruct H0 as [n H0]. *)
(*     exists n; rewrite H1; apply H0. *)
(*   - inversion Hq; subst. *)
(*     pose proof H0 as H'. *)
(*     eapply H in H'. *)
(*     2: { apply H3. } *)
(*     2: { apply Hlt. } *)
(*     (* TODO: somehow reduce to binary union case and then go by induction? *)     *)
(*     unfold rel_freq. *)
(*     unfold real_in_measb. *)
(* Admitted. *)

(** Characterization of uniformity of a sequence of real numbers in
    the unit interval (C-u.d.-1 where C is the class of countable
    unions of intervals). *)
Definition uniform (reals : nat -> real) : Prop :=
  forall U : meas,
  forall m : Q,
    measure U m ->
    forall eps : Q,
      0 < eps ->
      exists n0, forall n,
          (n0 <= n)%nat ->
          Qabs (m - rel_freq' U (prefix reals n)) < eps.

(** Textbook definition that refers only to intervals (uniform
    distribution modulo 1). *)
Definition uniform' (reals : nat -> real) : Prop :=
  forall I : interval,
  forall eps : Q,
    0 < eps ->
    exists n0, forall n,
        (n0 <= n)%nat ->
        Qabs (interval_measure I -
              rel_freq (fun r => real_in_intervalb r I) (prefix reals n)) < eps.

Lemma count_Q'_false s :
  count_Q' (fun _ : real => false) s == 0.
Proof. induction s; simpl; lra. Qed.

Lemma rel_freq'_meas_empty s :
  rel_freq' meas_empty s == 0.
Proof.
  unfold rel_freq', rel_freq.
  destruct s; try lra.
  rewrite count_Q'_false; reflexivity.
Qed.

Lemma uniform'_uniform (reals : nat -> real) :
  uniform' reals -> uniform reals.
Proof.
  unfold uniform, uniform'.
  intros H U.
  revert H. revert reals.
  induction U; intros reals H0 q Hq eps Hlt.
  - inversion Hq; subst; exists O; intros n Hle; rewrite H.
    rewrite rel_freq'_meas_empty; simpl; auto.
  - inversion Hq; subst.
    specialize (H0 i eps Hlt).
    destruct H0 as [n0 H0].
    exists n0; intros n Hle; rewrite H1; apply H0; auto.
  - inversion Hq; subst.
    pose proof H0 as H'.
    eapply H in H'.
    2: { apply H3. }
    2: { apply Hlt. }

    (* TODO: somehow reduce to binary union case and then go by induction? *)
    unfold rel_freq.
    unfold real_in_measb.
Admitted.

(* Definition uniform' (reals : nat -> real) : Prop := *)
(*   forall U : meas, *)
(*   forall m : Q, *)
(*     measure U m -> *)
(*     forall eps : Q, *)
(*       0 < eps -> *)
(*       exists n, forall freq, *)
(*           rel_freqR U (prefix reals n) freq -> *)
(*           Qabs (m - freq) < eps. *)

(* Lemma uniform_equiv (reals : nat -> real) : *)
(*   uniform reals <-> uniform' reals. *)
(* Proof. *)
(*   unfold uniform, uniform'. *)
(*   split; intro H. *)
(*   - intros U m Hm eps Heps. *)
(*     specialize (H U m Hm eps Heps). *)
(*     destruct H as [n H]. *)
(*     exists n. intros freq Hfreq. *)
(*     assert (Heq: freq == rel_freq' U (prefix reals n)). *)
(*     { eapply rel_freqR_deterministic; eauto. *)
(*       apply rel_freq_spec. } *)
(*     rewrite Heq; auto. *)
(*   - intros U m Hm eps Heps. *)
(*     specialize (H U m Hm eps Heps). *)
(*     destruct H as [n H]. *)
(*     specialize (H (rel_freq' U (prefix reals n)) *)
(*                   (rel_freq_spec U (prefix reals n))). *)
(*     exists n; auto. *)
(* Qed. *)

Fixpoint positive_binary (p : positive) : list bool :=
  match p with
  | xI p' => true :: positive_binary p'
  | xO p' => false :: positive_binary p'
  | xH => [true]
  end.

Definition N_binary (n : N) : list bool :=
  match n with
  | N0 => []
  | Npos p => positive_binary p
  end.

Definition nat_binary (n : nat) : list bool :=
  N_binary (N.of_nat n).

Eval compute in (nat_binary 4).

Fixpoint strip_falses (bs : list bool) : list bool :=
  match bs with
  | [] => []
  | x :: xs =>
    match strip_falses xs with
    | [] =>
      if x then [x] else []
    | xs' => x :: xs'
    end
  end.

(** The natural numbers aren't actually in one-to-one correspondence
with bit sequences, unless you only consider bit sequences with no
leading zeros. So, we append a 1 to each bit sequence before sending
it to nat. *)

(** TODO: fix? *)
Fixpoint binary_positive (bs : list bool) : positive :=
  match bs with
  | [] => xH (* invalid case *)
  | b :: [] => xH (* Assume b is true *)
  | b :: bs =>
    (if b then xI else xO) (binary_positive bs)
  end.

Definition binary_N_aux (bs : list bool) : N :=
  match bs with
  | [] => N0
  | _ => Npos (binary_positive bs)
  end.

Definition binary_N (bs : list bool) : N :=
  binary_N_aux (strip_falses bs).

Definition binary_nat (bs : list bool) : nat :=
  N.to_nat (binary_N bs).

Lemma strip_falses_idempotent (bs : list bool) :
  strip_falses (strip_falses bs) = strip_falses bs.
Proof.
  induction bs; auto; simpl.
  destruct (strip_falses bs); destruct a;
    auto; simpl in *; rewrite IHbs; auto.
Qed.

Lemma binary_N_strip_falses (bs : list bool) :
  binary_N (strip_falses bs) = binary_N bs.
Proof.
  unfold binary_N; rewrite strip_falses_idempotent; reflexivity.
Qed.

Lemma binary_nat_strip_falses (bs : list bool) :
  binary_nat (strip_falses bs) = binary_nat bs.
Proof.
  unfold binary_nat; rewrite binary_N_strip_falses; reflexivity.
Qed.

Inductive no_leading_falses : list bool -> Prop :=
| no_leading_falses_nil :
    no_leading_falses []
| no_leading_falses_cons_false : forall b bs,
    no_leading_falses (b :: bs) ->
    no_leading_falses (false :: b :: bs)
| no_leading_falses_cons_true : forall bs,
    no_leading_falses bs ->
    no_leading_falses (true :: bs).

Lemma no_leading_falses_app (l1 l2 : list bool) :
  l2 <> nil ->
  no_leading_falses l2 ->
  no_leading_falses (l1 ++ l2).
Proof.
  revert l2.
  induction l1; simpl; intros l2 Hneq Hno; auto.
  destruct l1; simpl in *.
  + destruct l2; try congruence.
    destruct a; constructor; auto.
  + destruct a; constructor; auto.
Qed.

Lemma no_leading_falses_strip_falses (bs : list bool) :
  no_leading_falses (strip_falses bs).
Proof.
  induction bs; simpl.
  - constructor.
  - destruct (strip_falses bs); destruct a; constructor; auto.
Qed.

Lemma no_leading_falses_strip_falses_noop (bs : list bool) :
  no_leading_falses bs ->
  strip_falses bs = bs.
Proof.
  induction 1; auto.
  - simpl in *; rewrite IHno_leading_falses; auto.
  - simpl. rewrite IHno_leading_falses.
    destruct bs; auto.
Qed.

Lemma positive_binary_non_nil (p : positive) :
  positive_binary p <> nil.
Proof. induction p; simpl; intro HC; congruence. Qed.

Lemma no_leading_falses_positive_binary (p : positive) :
  no_leading_falses (positive_binary p).
Proof.
  induction p; simpl.
  - constructor; auto.
  - destruct (positive_binary p) eqn:Hp.
    + exfalso; eapply positive_binary_non_nil; eauto.
    + constructor; auto.
  - repeat constructor.
Qed.

Lemma binary_N_aux_positive_binary (p : positive) :
  binary_N_aux (positive_binary p) = N.pos p.
Proof.
  induction p; simpl.
  - destruct (positive_binary p); simpl in *; lia.
  - destruct (positive_binary p); simpl in *; lia.
  - reflexivity.
Qed.

Lemma binary_N_N_binary (n : N) :
  binary_N (N_binary n) = n.
Proof.
  destruct n; auto.
  unfold N_binary, binary_N.
  rewrite no_leading_falses_strip_falses_noop.
  - apply binary_N_aux_positive_binary.
  - apply no_leading_falses_positive_binary.
Qed.

Lemma N_binary_binary_N (bs : list bool) :
  no_leading_falses bs ->
  N_binary (binary_N bs) = bs.
Proof.
  intro Hno; unfold binary_N.
  rewrite no_leading_falses_strip_falses_noop; auto.
  induction Hno; simpl; auto.
  - f_equal; auto.
  - destruct bs; auto;simpl in *; f_equal; auto.
Qed.

Lemma binary_nat_nat_binary (n : nat) :
  binary_nat (nat_binary n) = n.
Proof.
  unfold binary_nat, nat_binary.
  rewrite binary_N_N_binary.
  apply Nnat.Nat2N.id.
Qed.

Lemma nat_binary_binary_nat (bs : list bool) :
  no_leading_falses bs ->
  nat_binary (binary_nat bs) = bs.
Proof.
  unfold binary_nat, nat_binary.
  rewrite Nnat.N2Nat.id.
  apply N_binary_binary_N.
Qed.

(** Every bit sequence with no leading falses exists in the
    enumeration [nat_binary] (i.e., it's a surjective mapping onto the
    set of bit sequences with no leading falses). *)
Lemma nat_binary_surjective (bs : list bool) :
  no_leading_falses bs ->
  exists n, nat_binary n = bs.
Proof.
  exists (binary_nat bs); apply nat_binary_binary_nat; auto.
Qed.

(** Every bit sequence occurs at most once in [nat_binary] (i.e. it's
    an injective mapping). *)
Lemma nat_binary_injective (n m : nat) :
  nat_binary n = nat_binary m -> n = m.
Proof.
  intro Heq.
  assert (H: binary_nat (nat_binary n) = binary_nat (nat_binary m)).
  { rewrite Heq; reflexivity. }
  rewrite 2!binary_nat_nat_binary in H; auto.
Qed.

(** Real numbers r1 and r2 are equal up to the nth position, but
    differ at that position. *)
Definition real_neq_at_n (r1 r2 : real) (n : nat) : Prop :=
  prefix r1 n = prefix r2 n /\ r1 n <> r2 n.

Definition real_lt_at_n (r1 r2 : real) (n : nat) : Prop :=
  prefix r1 n = prefix r2 n /\ r1 n = false /\ r2 n = true.

Lemma list_eq_dec (A : Type) (l1 l2 : list A) :
  (forall x y : A, {x = y} + {x <> y}) ->
  {l1 = l2} + {l1 <> l2}.
Proof.
  revert l2.
  induction l1; intros l2 Hdec.
  - destruct l2.
    + left; auto.
    + right; congruence.
  - destruct l2.
    + right; congruence.
    + destruct (Hdec a a0); subst.
      * destruct (IHl1 l2 Hdec); subst.
        -- left; auto.
        -- right; congruence.
      * right; congruence.
Qed.

Lemma real_neq_at_n_dec (r1 r2 : real) :
  forall n, {real_neq_at_n r1 r2 n} + {~ real_neq_at_n r1 r2 n}.
Proof.
  intro n. unfold real_neq_at_n.
  destruct (list_eq_dec (prefix r1 n) (prefix r2 n) (Bool.bool_dec)).
  - rewrite e; clear e.
    destruct (Bool.bool_dec (r1 n) (r2 n)); firstorder.
  - firstorder.
Qed.

Lemma real_lt_at_n_dec (r1 r2 : real) :
  forall n, {real_lt_at_n r1 r2 n} + {~ real_lt_at_n r1 r2 n}.
Proof.
  intro n. unfold real_lt_at_n.
  destruct (list_eq_dec (prefix r1 n) (prefix r2 n) (Bool.bool_dec)).
  - rewrite e; clear e; destruct (r1 n); destruct (r2 n); intuition.
  - intuition.
Qed.

Definition real_eq_at_n (r1 r2 : real) (n : nat) : Prop :=
  r1 n = r2 n.

Lemma real_eq_at_n_dec (r1 r2 : real) (n : nat) :
  {real_eq_at_n r1 r2 n} + {~ real_eq_at_n r1 r2 n}.
Proof. destruct (Bool.bool_dec (r1 n) (r2 n)); firstorder. Qed.

Definition real_eqb (r1 r2 : real) : bool :=
  match strong_LPO (* (real_neq_at_n r1 r2) *)
                   (real_neq_at_n_dec r1 r2) with
  | left _ => false
  | right _ => true
  end.

Definition real_ltb (r1 r2 : real) : bool :=
  match strong_LPO (* (real_lt_at_n r1 r2) *)
                   (real_lt_at_n_dec r1 r2) with
  | left _ => true
  | right _ => false
  end.

Definition real_leb (r1 r2 : real) : bool :=
  real_eqb r1 r2 || real_ltb r1 r2.

Lemma not_exists_forall_not (A : Type) (P : A -> Prop) :
  not (exists x, P x) -> forall x, ~ P x.
Proof.
  intros Hnot x.
  intro HP. apply Hnot. exists x; auto.
Qed.

Lemma interval_measure_nonnegative (bs : interval) :
  0 <= interval_measure bs.
Proof.
  unfold interval_measure.
  assert (0 < Qpow 2 (length bs)).
  { apply Qpow_positive; lra. }
  apply Qle_shift_div_l; auto; lra.
Qed.

Lemma interval_measure_nonzero (bs : interval) :
  ~ (interval_measure bs == 0).
Proof.
  unfold interval_measure.
  intro HC.
  assert (H: 0 == 0 / Qpow 2 (length bs)).
  { rewrite Qdiv_0_num; reflexivity. }
  rewrite H in HC; clear H.
  assert (1 == 0).
  { eapply Qdiv_num_inversion; eauto; apply Qpow_nonzero; lra. }
  lra.
Qed.

Lemma interval_measure_positive (bs : interval) :
  0 < interval_measure bs.
Proof.
  generalize (interval_measure_nonnegative bs), (@interval_measure_nonzero bs); lra.
Qed.


Require Import Take CSet.

Lemma in_take_list X `{OrderedType X} (l: list X) (n: nat) (x:X) :
InA _eq x (take n l) -> InA _eq x l.
Proof.
revert n.
induction l; destruct n; simpl; eauto; intros G.
- inv G.
- inv G.
  + constructor; eauto.
  + apply InA_cons_tl. eauto.
Qed.

Lemma take_dupFree_list X `{OrderedType X} ( l : list X ) (n : nat) :
NoDupA _eq l -> NoDupA _eq (take n l).
Proof.
intro noDup. revert n.
induction noDup; destruct n; simpl; eauto using NoDupA.
econstructor; eauto.
- intros no. apply in_take_list in no. contradiction.
Qed.

Lemma take_dupFree X `{OrderedType X} ( s : set X ) (n:nat) :
NoDupA _eq (take n (elements s)).
Proof.
apply take_dupFree_list. apply elements_3w.
Qed.

Lemma take_list_incl X `{OrderedType X} (n : nat) (L:list X) :
        of_list (take n L) ⊆ of_list L.
Proof.
  general induction L; destruct n; simpl; eauto with cset.
Qed.

Lemma take_set_incl X `{OrderedType X} (n : nat) (s : set X) :
        of_list (take n (elements s)) ⊆ s.
Proof.
  rewrite take_list_incl.
  hnf; intros. eapply elements_iff. cset_tac.
Qed.

Lemma take_of_list_cardinal X `{OrderedType X} n (l : list X)
: cardinal (of_list (take n l)) <= n.
Proof.
revert n. induction l; intro n.
- rewrite take_nil. simpl. rewrite empty_cardinal. omega.
- destruct n; simpl.
  + rewrite empty_cardinal. omega.
  + rewrite add_cardinal. rewrite IHl. omega.
Qed.

Set Implicit Arguments.

Definition set_take (X:Type) `{OrderedType X} (k:nat) (s:⦃X⦄)
  := of_list (take k (elements s))
.

Definition set_take_prefer (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄)
  := of_list (take k (elements t ++ elements (s \ t)))
.

Definition set_take_avoid (X:Type) `{OrderedType X} (k:nat) (s t : ⦃X⦄)
  := of_list (take k (elements (s \ t) ++ elements (s ∩ t)))
.

Lemma set_take_incl (X:Type) `{OrderedType X} (k:nat) (s:⦃X⦄)
  : set_take k s ⊆ s
.
Proof.
  apply take_set_incl.
Qed.

Lemma set_take_prefer_incl (X:Type) `{OrderedType X} k (s t:⦃X⦄)
  : set_take_prefer k s t ⊆ s ∪ t
.
Proof.
  decide (k < cardinal t); unfold set_take_prefer; try rewrite <-elements_length in *;
    [rewrite take_app_le|rewrite take_app_ge]; [|omega| |omega].
  - rewrite take_set_incl. cset_tac.
  - rewrite of_list_app.
    apply union_incl_split; [rewrite of_list_elements|rewrite take_set_incl]; cset_tac.
Qed.

Lemma set_take_eq (X:Type) `{OrderedType X} k (s :⦃X⦄) :
  cardinal s <= k -> set_take k s [=] s
.
Proof.
  intros card. unfold set_take. rewrite take_eq_ge.
  - rewrite of_list_elements. eauto.
  - rewrite elements_length. eauto.
Qed.

Lemma set_take_avoid_incl (X:Type) `{OrderedType X} k (s t:⦃X⦄)
  : set_take_avoid k s t ⊆ s
.
Proof.
  decide (k < cardinal (s \ t)); unfold set_take_avoid; try rewrite <-elements_length in *;
    [rewrite take_app_le|rewrite take_app_ge]; [|omega| |omega].
  - rewrite take_set_incl. cset_tac.
  - rewrite of_list_app.
    apply union_incl_split; [rewrite of_list_elements|rewrite take_set_incl]; cset_tac.
Qed.

Lemma set_take_prefer_card_incl (X:Type) `{OrderedType X} k (s t:⦃X⦄)
  : cardinal t <= k -> t ⊆ set_take_prefer k s t
.
Proof.
  intros card.
  unfold set_take_prefer; rewrite <-elements_length in card. rewrite take_app_ge; eauto.
  rewrite of_list_app, of_list_elements, union_comm. cset_tac.
Qed.

Lemma set_take_avoid_incl2 (X:Type) `{OrderedType X} k (s t:⦃X⦄)
  : k <= cardinal (s \ t) -> set_take_avoid k s t ⊆ s \ t
.
Proof.
  intros card.
  unfold set_take_avoid. rewrite <-elements_length in card. rewrite take_app_le; eauto.
  apply set_take_incl.
Qed.

Lemma set_take_prefer_eq (X:Type) `{OrderedType X} k (s t : ⦃X⦄)
  : cardinal s <= k -> t ⊆ s -> set_take_prefer k s t [=] s
.
Proof.
  intros card sub. apply incl_eq.
  - unfold set_take_prefer. rewrite take_app_ge.
    + rewrite of_list_app, of_list_elements. rewrite take_eq_ge.
      * rewrite of_list_elements. cset_tac.
      * rewrite !elements_length. rewrite cardinal_difference'; eauto. omega.
    + rewrite elements_length. unfold ">=". rewrite subset_cardinal;eauto.
  - setoid_rewrite <-union_subset_equal at 4; eauto. rewrite set_take_prefer_incl. cset_tac.
Qed.

Lemma set_take_avoid_disj (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  cardinal (s \ t) >= k
  -> disj (set_take_avoid k s t) t
.
Proof.
  intros card x inS inT. unfold set_take_avoid in inS.
  rewrite take_app_le in inS.
  - rewrite take_set_incl in inS. cset_tac.
  - rewrite elements_length. eauto.
Qed.

Lemma set_take_cardinal_eq (X:Type) `{OrderedType X} k (s : ⦃X⦄) :
  k <= cardinal s
  -> cardinal (set_take k s) = k
.
Proof.
  intros card. unfold set_take. rewrite card_in_of_list.
  - rewrite take_length_le; eauto. rewrite elements_length; eauto.
  - apply take_dupFree.
Qed.

Definition set_take_least_avoid (X:Type) `{OrderedType X} k (s t : ⦃X⦄) : ⦃X⦄
  :=
    s \ t ∪ set_take (k - cardinal (s \ t)) (s ∩ t)
.

Lemma set_take_least_avoid_incl (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  set_take_least_avoid k s t ⊆ s
.
Proof.
  unfold set_take_least_avoid. rewrite set_take_incl. cset_tac.
Qed.

Lemma incl_set_take_least_avoid (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  s \ t ⊆ set_take_least_avoid k s t
.
Proof.
  unfold set_take_least_avoid. cset_tac.
Qed.

Lemma set_take_least_avoid_eq (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  k <= cardinal (s \ t)
  -> set_take_least_avoid k s t [=] s \ t
.
Proof.
  intros card. unfold set_take_least_avoid.
  replace (k - cardinal (s \ t)) with 0 by omega. cbn. cset_tac.
Qed.

Lemma set_take_size (X:Type) `{OrderedType X} k (s : ⦃X⦄) :
  cardinal (set_take k s) <= k
.
Proof.
  unfold set_take. rewrite cardinal_of_list_nodup; [|apply take_dupFree]. decide (cardinal s <= k).
  - rewrite take_length_ge; rewrite elements_length; omega.
  - rewrite take_length_le; eauto. rewrite elements_length; omega.
Qed.

Lemma set_take_least_avoid_size (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  k <= cardinal s
  -> k <= cardinal (set_take_least_avoid k s t)
.
Proof.
  intros card. unfold set_take_least_avoid.
  rewrite union_cardinal.
  - unfold set_take. rewrite cardinal_of_list_nodup; [|apply take_dupFree]. rewrite take_length_le.
    + omega.
    + rewrite elements_length. apply Nat.le_sub_le_add_r. rewrite <-union_cardinal; [|cset_tac].
      rewrite <-subset_cardinal; eauto. cset_tac.
  - intros. rewrite set_take_incl. cset_tac.
Qed.

Lemma set_take_prefer_size (X:Type) `{OrderedType X} k (s t : ⦃X⦄) :
  cardinal (set_take_prefer k s t) <= k
.
Proof.
  unfold set_take_prefer. rewrite cardinal_of_list_nodup.
  - decide (length (elements t ++ elements (s \ t))  <= k).
    + rewrite take_length_ge; eauto.
    + rewrite take_length_le; eauto. omega.
  - apply take_dupFree_list. apply NoDupA_app; eauto.
    + apply elements_3w.
    + apply elements_3w.
    + intros. apply <-elements_iff in H0. apply <-elements_iff in H1. cset_tac.
Qed.


From Coq Require Import ssreflect.
From stdpp Require Import prelude.
From bunched.algebra Require Import bi from_monoid.

Section FromClosure.
  (** * Algebra carrier *)

  (** Given a BI algebra [P(M)] for a commutative monoid [M] .. *)
  Variable (M : Type) (o : M → M → M).
  Context `{!Equiv M, !Monoid M o}.
  Context `{!Equivalence (≡@{M})}.

  Infix "●" := (o) (at level 80, right associativity).

  Definition PM := PM M.
  Definition MkPM := MkPM M.
  Canonical Structure PM_alg := PM_alg M o.

  (** We start with a closed basis: a collection of principal closed
  sets, index by some type [Basis]. *)
  Variable (Basis : Type).
  Variable (basis : Basis → PM).

  (** Here are we are abusing the encoding a little bit;
    the assumption [X ⊆ basis(i)] is external, but we can
    quantifier over its proofs in the type theory. *)
  Program Definition cl (X : PM) : PM :=
    @MkPM (λ m, ∀ (i : Basis), ((X : PM_alg) ⊢ basis i)
                 → basis i m) _.
  Next Obligation.
    intros X i1 i2 HD. by setoid_rewrite HD.
  Qed.

  Lemma cl_unit X : X ⊢ cl (X : PM_alg).
  Proof.
    intros x Hx. simpl. intros i Hi.
    by apply (Hi x).
  Qed.

  Lemma cl_mono (X Y : PM) : (X ⊢@{PM_alg} Y) → (cl X ⊢@{PM_alg} cl Y).
  Proof.
    intros HX x. simpl. intros H1 i HY.
    eapply H1. by rewrite HX.
  Qed.

  Lemma cl_idemp (X : PM) : cl (cl X) ≡ cl X.
  Proof.
    split; last first.
    { eapply (cl_unit (cl X)). }
    simpl. intros m Hm i Hi.
    eapply (Hm i). intros m' Hm'.
    by eapply (Hm' i).
  Qed.

  Global Instance cl_proper : Proper ((≡) ==> (≡)) cl.
  Proof.
    intros X Y HXY.
    split; eapply (cl_mono _ _); by rewrite HXY.
  Qed.

  Class Is_closed (X : PM) := closed_eq_cl : X ≡ cl X.

  (** Carrier of the algebra are closed sets. *)
  Record C :=
    { CPred :> PM ; CPred_closed : Is_closed CPred }.

  Global Instance C_equiv : Equiv C := (PM_equiv M : Equiv PM).

  Definition C_entails (X Y : C) : Prop := PM_entails M (X : PM) (Y : PM).
  Local Infix "⊢" := C_entails.

  Global Instance ElemOf_C : ElemOf M C := λ a X, (X : PM) a.

  Global Instance ElemOf_C_Proper :
    Proper ((≡) ==> (≡) ==> (≡)) (∈@{C}).
  Proof.
    intros x1 x2 Hx X1 X2 HX.
    rewrite /elem_of /ElemOf_C.
    rewrite Hx. split; apply HX.
  Qed.

  Global Instance ElemOf_C_Proper_1 :
    Proper ((≡) ==> (≡) ==> (impl)) (∈@{C}).
  Proof.
    intros x1 x2 Hx X1 X2 HX.
    rewrite /elem_of /ElemOf_C.
    rewrite Hx.
    unfold impl. apply HX.
  Qed.

  Global Instance ElemOf_C_Proper_2 :
    Proper ((≡) ==> (≡) ==> (flip impl)) (∈@{C}).
  Proof.
    intros x1 x2 Hx X1 X2 HX.
    rewrite /elem_of /ElemOf_C.
    rewrite Hx.
    unfold impl. simpl. apply HX.
  Qed.

  Global Existing Instance CPred_closed.

  Global Instance Is_closed_cl (X : PM) : Is_closed (cl X).
  Proof.
    rewrite /Is_closed. by rewrite cl_idemp.
  Qed.

  Global Instance CPred_proper (X : C) : Proper ((≡) ==> (↔)) (X : PM).
  Proof.
    intros D1 D2 HD.
    by apply PMPred_proper.
  Qed.

  Global Instance C_equiv_equivalence : Equivalence (≡@{C}).
  Proof.
    rewrite /equiv /C_equiv /PM_equiv.
    repeat split; repeat intro; naive_solver.
  Qed.

  Local Instance C_equiv_rr : RewriteRelation (≡@{C}) := {}.

  Global Instance C_entail_proper : Proper ((≡) ==> (≡) ==> (↔)) C_entails.
  Proof.
    intros X1 X2 HX Y1 Y2 HY. unfold C_entails.
    split.
    - intros H1 m HX2.
      by eapply HY, H1, HX.
    - intros H1 m HX1.
      by eapply HY, H1, HX.
  Qed.

  Global Instance Is_closed_proper : Proper ((≡) ==> (↔)) Is_closed.
  Proof.
    intros X Y HXY. unfold Is_closed.
    by rewrite HXY.
  Qed.

  (** ** Additional operations *)

  (** Specializing [cl : PM → PM] to [PM → C] *)
  Program Definition cl' (X : PM) : C :=
    {| CPred := cl X |}.

  (** The interior operation *)
  Definition PM_int (X : PM) : PM :=
    (∃ (Z : C), ⌜(Z : PM) ⊢@{PM_alg} X⌝ ∧ (Z: PM))%I.
  Definition int (X : PM) : PM := cl (PM_int X).
  Program Definition int' (X : PM) : C :=
    {| CPred := int X |}.

  (** * Properties of the closure operator and closed sets *)
  Lemma Is_closed_inc (X : PM) :
    ((cl X : PM_alg) ⊢@{PM_alg} X) → Is_closed X.
  Proof.
    intros H1. unfold Is_closed.
    split.
    - eapply cl_unit.
    - eapply H1.
  Qed.

  Global Instance Is_closed_basis (i : Basis) : Is_closed (basis i).
  Proof.
    apply Is_closed_inc.
    intros m Hcl. simpl. eapply Hcl. eauto.
  Qed.

  Definition basis' i : C :=
    {| CPred := basis i |}.

  Lemma cl_adj (X : PM) (Y : PM) `{!Is_closed Y} :
    (X ⊢@{PM_alg} Y) → cl X ⊢@{PM_alg} Y.
  Proof.
    rewrite (@closed_eq_cl Y).
    rewrite -{2}(cl_idemp Y).
    apply cl_mono.
  Qed.

  Lemma cl'_adj (X : PM) (Y : C) :
    (X ⊢@{PM_alg} (Y : PM)) → cl' X ⊢ Y.
  Proof.
    intros H1. apply cl_adj.
    { apply _. }
    apply H1.
  Qed.

  (** Alternative descriptions of the closure operator, internally in
  the language of the BI algebra *)
  Lemma cl_alt_eq (X : PM) :
    (cl X : PM) ≡
      (∀ Z : { Y : C | X ⊢@{PM_alg} (Y : PM) }, `Z : PM)%I.
  Proof.
    split.
    - simpl. intros m H1.
      rewrite /bi_forall/PM_forall /=.
      intros [[Y HY] HXY]. simpl.
      eapply HY. intros i Hi.
      eapply H1. rewrite -Hi. eapply HXY.
    - simpl. intros m H1 ϕ HX.
      apply (H1 (basis' ϕ ↾ HX)).
  Qed.

  Lemma cl_alt_eq_2 (X : PM) :
    (cl X : PM) ≡
      (∀ Y : C, (⌜X ⊢@{PM_alg} (Y : PM)⌝) → Y : PM)%I.
  Proof.
    rewrite cl_alt_eq.
    apply bi.equiv_entails. split.
    - rewrite /bi_forall /bi_impl /= /bi_forall.
      intros m H1 Y HXY.
      apply (H1 (Y ↾ HXY)).
    - rewrite /bi_forall /bi_impl /= /bi_forall.
      intros m H1 [Y HXY]. simpl.
      apply H1, HXY.
  Qed.

  (** * Closure strength and the BI operations *)
  Variable impl : C → C → C.
  Hypothesis impl_proper : Proper ((≡) ==> (≡) ==> (≡)) impl.
  Hypothesis (is_heyting_impl : ∀ (X Y Z : C),
        ((X : PM) ⊢@{PM_alg} (impl Y Z : PM)) ↔
          ((X : PM) ∧ (Y : PM) ⊢@{PM_alg} (Z : PM))%I).
  (** This hypothesis is equivalent to [cl] being strong *)
  Hypothesis
    (wand_closed : ∀ (X : PM) (Y : C),
        Is_closed (X -∗ (Y : PM))%I).

  Local Instance wand_closed' :
    ∀ (X : PM) (Y : PM), Is_closed Y →
        Is_closed (X -∗ (Y : PM))%I.
  Proof.
    intros X Y HY.
    set (Y' := {| CPred := Y |} : C).
    eapply (wand_closed X Y').
  Qed.

  Lemma cl_strong (X Y : PM) :
    ((cl X) ∗ Y ⊢@{PM_alg} cl (X ∗ Y))%I.
  Proof.
    eapply bi.wand_elim_l'.
    apply cl_adj; first apply _.
    apply bi.wand_intro_r.
    eapply cl_unit.
  Qed.

  (** Universal quantification and conjunciton *)
  Global Instance PM_forall_closed (A : Type) (CC : A → PM) :
    (∀ x : A, Is_closed (CC x)) →
    Is_closed (PM_forall M A CC).
  Proof.
    intros HCC.
    apply Is_closed_inc.
    eapply bi.forall_intro=>a.
    rewrite cl_alt_eq_2.
    rewrite (bi.forall_elim ({| CPred := CC a |})).
    intros m H1.
    rewrite /bi_impl /= in H1.
    apply H1.
    rewrite /bi_pure /=.
    clear. by rewrite (bi.forall_elim a).
  Qed.

  Definition C_forall (A : Type) (CC : A → C) : C :=
    {| CPred := (∀ x : A, (CC x : PM))%I |}.

  Global Instance PM_and_closed (X Y : PM) :
    Is_closed X →
    Is_closed Y →
    Is_closed (PM_and M X Y).
  Proof.
    intros HX HY.
    apply Is_closed_inc.
    intros m Hm. split.
    + apply HX. intros i H'. eapply Hm.
      rewrite -H'. intros ?. simpl. naive_solver.
    + apply HY. intros i H'. eapply Hm.
      rewrite -H'. intros ?. simpl. naive_solver.
  Qed.

  Definition C_and (X Y : C) : C :=  {| CPred := ((X : PM) ∧ (Y : PM))%I |}.

  (** Disjunction, ex quantification, and multiplication *)
  Definition C_or (X Y : C) : C := cl' (PM_or M (X : PM) (Y : PM)).

  Definition C_exists (A : Type) (CC : A → C) : C := cl' (∃ x : A, CC x : PM)%I.

  Definition C_emp : C := cl' (PM_emp M o).

  Definition C_sep (X Y : C) : C := cl' (PM_sep M o (X : PM) (Y : PM)).

  (** Implications *)
  Definition C_impl (X : C) (Y : C) : C :=
    {| CPred := impl X Y |}.

  Definition C_wand (X : PM) (Y : C) : C :=
    {| CPred := PM_wand M o X (Y : PM) |}.

  (** Embedding Coq propositions *)
  Definition C_pure (ϕ : Prop) : C := cl' (PM_pure M ϕ).

  Local Notation "'emp'" := C_emp.
  Local Infix "∗" := C_sep.
  Local Infix "-∗" := C_wand.
  Local Infix "→" := C_impl.
  Local Infix "∧" := C_and.
  Local Infix "∨" := C_or.

  (** ** BI laws *)
  Global Instance c_entails_preorder : PreOrder C_entails.
  Proof. split; compute; naive_solver. Qed.

  Lemma impl_intro_r (P Q R : C) : (P ∧ Q ⊢ R) → P ⊢ Q → R.
  Proof. apply is_heyting_impl. Qed.
  Lemma impl_elim_l' (P Q R : C) : (P ⊢ Q → R) → P ∧ Q ⊢ R.
  Proof. apply is_heyting_impl. Qed.
  Lemma or_intro_l (P Q : C) : P ⊢ P ∨ Q.
  Proof.
    intros m HP. apply (cl_unit _ m).
    naive_solver.
  Qed.
  Lemma or_intro_r (P Q : C) : Q ⊢ P ∨ Q.
  Proof.
    intros m HP. apply (cl_unit _ m).
    naive_solver.
  Qed.
  Lemma or_elim (P Q R : C) :
    (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R.
  Proof.
    intros H1 H2.
    apply cl'_adj=>m [?|?]; eauto.
  Qed.
  Lemma sep_mono (P P' Q Q' : C) :
    (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'.
  Proof.
    intros H1 H2 m HP i Hi.
    apply (HP i). clear HP m.
    intros m. destruct 1 as (m1 & m2 & Hm1 & Hm2 & ->).
    eapply (Hi _). do 2 eexists. split; eauto.
  Qed.
  Lemma wand_intro_r (P Q R : C) : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R.
  Proof.
    intros HH m1 HP.
    intros m2 HQ. eapply HH.
    eapply (cl_unit _ _).
    do 2 eexists. repeat split; eauto.
  Qed.
  Lemma wand_elim_l' (P Q R : C) : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R.
  Proof.
    destruct R as [R HR].
    intros HH m HPQ. simpl.
    apply HR. intros i Hi. eapply HPQ.
    clear m HPQ. intros m (m1 & m2 & H1 & H2 & ->).
    apply (Hi _). by apply HH.
  Qed.
  Lemma emp_sep_1 (P : C) : P ⊢ emp ∗ P.
  Proof.
    intros m HP. eapply (cl_unit _ _).
    exists monoid_unit, m. rewrite left_id.
    repeat split; eauto.
    intros i Hi. eapply (Hi _). simpl. reflexivity.
  Qed.
  Lemma emp_sep_2 (P : C) : emp ∗ P ⊢ P.
  Proof.
    apply wand_elim_l'.
    eapply cl'_adj. eapply bi.wand_intro_r.
    apply bi.emp_sep_2.
  Qed.
  Lemma sep_comm' (P Q : C) : P ∗ Q ⊢ Q ∗ P.
  Proof. apply cl_mono. apply bi.sep_comm'. Qed.
  Lemma sep_assoc' (P Q R : C) : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R).
  Proof.
    apply wand_elim_l'.
    apply cl'_adj.
    intros m (D1 & D2 & HD1 & HD2 & ->).
    intros D3 HD3. apply (cl_unit _ _).
    exists D1, (D2 ● D3).
    rewrite (assoc _ D1). repeat split; eauto.
    apply (cl_unit _ _). do 2 eexists; repeat split; eauto.
  Qed.
  Lemma exists_intro {A : Type} (Ψ : A → C) (a : A) :
    Ψ a ⊢ C_exists A Ψ.
  Proof.
    intros m HΨ.
    apply (cl_unit _ _). by exists a.
  Qed.
  Lemma exists_elim {A : Type} (Ψ : A → C) Q :
    (∀ a : A, Ψ a ⊢ Q) → C_exists A Ψ ⊢ Q.
  Proof.
    intros H1 m. apply cl'_adj.
    by apply bi.exist_elim.
  Qed.

  (** [C] satisfies all the BI algebra laws *)
  Lemma C_bi_mixin :
    BiMixin (PROP:=C)
      C_entails C_emp C_pure C_and C_or
      C_impl C_forall C_exists C_sep C_wand.
  Proof.
    split.
    - apply _.
    - apply _.
    - naive_solver.
    - intros A1 A2 HA. compute.
      naive_solver.
    - intros [X1 ?] [X2 ?] [HX1 HX2] [Y1 ?] [Y2 ?] [HY1 HY2].
      split; intro m ; compute in * ; naive_solver.
    - intros X1 X2 HX Y1 Y2 HY; try apply _.
      apply cl_proper.
      split; intro m ; vm_compute in * ; naive_solver.
    - apply impl_proper.
    - intros A P1 P2 HP.
      split; intro m ; vm_compute in * ; naive_solver.
    - intros A P1 P2 HP.
      apply cl_proper.
      split; intro m ; vm_compute in * ; naive_solver.
    - intros X1 X2 HX Y1 Y2 HY; try apply _.
      apply cl_proper.
      split; intro m ; vm_compute in * ; naive_solver.
    - intros X1 X2 HX Y1 Y2 HY; try apply _.
      split; intro m ; vm_compute in * ; naive_solver.
    - (* "Pure" proposition introduction *)
      intros i X Hi m. simpl.
      intros HX j Hs. by apply (Hs _).
    - (* Pure proposition elimination *)
      intros i X Hi.
      apply cl'_adj.
      intros m HHi. apply Hi; eauto.
      intros j Hj. by apply (Hj _).
    - compute; intros; naive_solver.
    - compute; intros; naive_solver.
    - compute; intros; naive_solver.
    - compute; intros; naive_solver.
    - compute; intros; naive_solver.
    - apply or_elim.
    - apply impl_intro_r.
    - apply impl_elim_l'.
    - intros. by apply bi.forall_intro.
    - intros A Ψ a m Hm.
      apply (Hm a).
    - intros. by apply exists_intro.
    - intros. by apply exists_elim.
    - apply sep_mono.
    - apply emp_sep_1.
    - apply emp_sep_2.
    - apply sep_comm'.
    - apply sep_assoc'.
    - apply wand_intro_r.
    - apply wand_elim_l'.
  Qed.

  Canonical Structure C_alg : bi :=
    {| bi_bi_mixin := C_bi_mixin; |}.

  (** * Other properties *)

  (** Description of implication in C in terms of the implication in P[M]. *)
  Lemma impl_from_int (X Y : C) :
    ((X → Y) : C) ≡ int' ((X : PM) → (Y : PM))%I.
  Proof.
    rewrite /bi_impl /=.
    rewrite bi.impl_alt_eq.
    apply bi.equiv_entails. split.
    - apply cl_adj; first apply _.
      apply bi.exist_elim=>R.
      apply is_heyting_impl.
      apply cl_adj; first apply _.
      apply bi.pure_elim'=>HR.
      assert ((C_pure True : PM) ≡ (True : PM)%I) as Htrue.
      { apply bi.equiv_entails; split.
        - apply bi.True_intro.
        - apply (cl_unit _). }
      rewrite -Htrue.
      apply is_heyting_impl.
      rewrite Htrue.
      etrans; last apply (cl_unit _).
      unfold PM_int.
      apply (bi.exist_intro' _ _ R).
      apply bi.and_mono_l. apply bi.pure_intro.
      by apply bi.impl_intro_r.
    - apply cl_adj; first apply _.
      unfold PM_int.
      apply bi.exist_elim=>R.
      etrans; last apply cl_unit.
      apply (bi.exist_intro' _ _ R).
      apply bi.and_mono_l. apply bi.pure_elim'=>HR.
      etrans; last apply cl_unit.
      apply bi.pure_intro.
      by apply bi.impl_elim_l' in HR.
  Qed.

  Lemma cl_sep (X Y : PM) :
    cl' (PM_sep _ o X Y) ≡ C_sep (cl' X) (cl' Y).
  Proof.
    rewrite /C_sep.
    split.
    { apply cl_mono. f_equiv; apply cl_unit. }
    cut (cl' (PM_sep M o (cl X) (cl Y)) ⊢ cl' (PM_sep M o X Y)).
    { intros H1 m. apply (H1 m). }
    eapply cl'_adj.
    eapply bi.wand_elim_l'.
    apply (cl'_adj X (cl' Y -∗ cl' (PM_sep M o X Y))).
    apply bi.wand_intro_l.
    apply bi.wand_elim_l'.
    simpl.
    apply cl_adj.
    { apply _. }
    apply bi.wand_intro_l. apply cl_unit.
  Qed.

End FromClosure.

Arguments Is_closed {M} {o} {_} {_} {_} {_} basis X.
Arguments cl_unit {_} {_} {_} {_} {_} {_} basis X.