Require Import Coq.Reals.Rbase.
Require Import Coq.Reals.Rfunctions.
Require Import Coq.Reals.RiemannInt.
Require Import Lra Omega.
Require Import List.
Require Import Morphisms EquivDec.

Require Import Utils.
Import ListNotations.

(* Declare Scope prob. *)

Section ev.
  Definition event T := T -> Prop.

  Definition event_sub {T} (A B:event T) := forall x, A x -> B x.
  Definition event_equiv {T} (A B:event T) := forall x, A x <-> B x.

  Global Instance event_equiv_equiv {T} : Equivalence (@event_equiv T).
  Proof.
    firstorder.
  Qed.

  Global Instance event_equiv_sub {T} : subrelation event_equiv (@event_sub T).
  Proof.
    firstorder.
  Qed.

  Global Instance event_sub_pre {T} : PreOrder (@event_sub T).
  Proof.
    firstorder.
  Qed.

  Global Instance event_sub_part {T} : PartialOrder event_equiv (@event_sub T).
  Proof.
    firstorder.
  Qed.

  Definition Ω {T} : event T   (* \Omega *)
    := fun x: T => True.

  Definition event_none {T} : event T
    := fun x: T => False.

  Definition event_union {T} (A B:event T) : event T
    := fun x:T => A x \/ B x.

  Definition event_inter {T} (A B:event T) : event T
    := fun x:T => A x /\ B x.

  Definition event_complement {T} (A:event T) : event T
    := fun x:T => not (A x).

  Definition event_diff {T} (A B:event T) : event T
    := fun x:T => A x /\ not (B x).

  Definition event_lem {T} (A:event T) : Prop
    := forall x, A x \/ ~ A x.
End ev.

Definition event_disjoint {T} (A B:event T) : Prop
  := forall x, A x -> B x -> False.

Notation "∅" := event_none : prob. (* \emptyset *)
Notation "a ∪ b" := (event_union a b) (at level 50) : prob. (* \cup *)
Notation "a ∩ b" := (event_inter a b) (at level 50) : prob. (* \cap *)
Notation "¬ a" := (event_complement a) (at level 20) : prob. (* \neg *)
Notation "a \ b" := (event_diff a b) (at level 50) : prob.
Notation "a ≤ b" := (event_sub a b) (at level 70) : prob. (* \leq *)

Local Open Scope prob.

Global Instance event_union_proper {T} :
  Proper (event_equiv ==> event_equiv ==> event_equiv) (@event_union T).
Proof.
  firstorder.
Qed.

Global Instance event_inter_proper {T} :
  Proper (event_equiv ==> event_equiv ==> event_equiv) (@event_inter T).
Proof.
  firstorder.
Qed.

Global Instance event_complement_proper {T} :
  Proper (event_equiv ==> event_equiv) (@event_complement T).
Proof.
  firstorder.
Qed.

Global Instance event_diff_proper {T} :
  Proper (event_equiv ==> event_equiv ==> event_equiv) (@event_diff T).
Proof.
  firstorder.
Qed.

Global Instance event_union_sub_proper {T} :
  Proper (event_sub ==> event_sub ==> event_sub) (@event_union T).
Proof.
  firstorder.
Qed.

Global Instance event_inter_sub_proper {T} :
  Proper (event_sub ==> event_sub ==> event_sub) (@event_inter T).
Proof.
  firstorder.
Qed.

Global Instance event_complement_sub_proper {T} :
  Proper (event_sub --> event_sub) (@event_complement T).
Proof.
  firstorder.
Qed.

Global Instance event_diff_sub_proper {T} :
  Proper (event_sub ==> event_sub --> event_sub) (@event_diff T).
Proof.
  firstorder.
Qed.

Global Instance event_disjoint_proper {T} :
  Proper (event_sub --> event_sub --> Basics.impl) (@event_disjoint T).
Proof.
  firstorder.
Qed.

Lemma event_diff_derived {T} (A B:T->Prop) : A \ B === A ∩ ¬B.
Proof.
  firstorder.
Qed.

Lemma event_disjoint_inter {T} (A B:event T) :
  event_disjoint A B <-> A ∩ B === ∅.
Proof.
  firstorder.
Qed.

Lemma event_disjoint_diff {T} (A B:event T) : event_disjoint A (B \ A).
Proof.
  firstorder.
Qed.

Hint Resolve event_disjoint_diff : prob.

Lemma event_disjoint_complement {T} (A:event T) : event_disjoint A (¬ A).
Proof.
  firstorder.
Qed.

Hint Resolve event_disjoint_complement : prob.

Lemma event_sub_true {T} (A:event T) : A ≤ Ω.
Proof.
  firstorder.
Qed.

Lemma event_false_sub {T} (A:event T) : ∅ ≤ A.
Proof.
  firstorder.
Qed.

Hint Resolve @event_sub_true @event_false_sub : prob.

Lemma event_sub_union_l {T} (A B:event T) : A ≤ A ∪ B.
Proof.
  firstorder.
Qed.

Lemma event_sub_union_r {T} (A B:event T) : B ≤ A ∪ B.
Proof.
  firstorder.
Qed.

Hint Resolve @event_sub_union_l @event_sub_union_r : prob.

Lemma event_inter_sub_l {T} (A B:event T) : A ∩ B ≤ A.
Proof.
  firstorder.
Qed.

Lemma event_inter_sub_r {T} (A B:event T) : A ∩ B ≤ B.
Proof.
  firstorder.
Qed.

Hint Resolve @event_inter_sub_l @event_inter_sub_r : prob.

Lemma event_union_true_l {T} (A:event T) : Ω ∪ A === Ω.
Proof.
  firstorder.
Qed.

Lemma event_union_true_r {T} (A:event T) : A ∪ Ω === Ω.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_union_true_l @event_union_true_r : prob.

Lemma event_union_false_l {T} (A:event T) : ∅ ∪ A === A.
Proof.
  firstorder.
Qed.

Lemma event_union_false_r {T} (A:event T) : A ∪ ∅ === A.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_union_false_l @event_union_false_r : prob.

Lemma event_union_complement {T} (A:event T) :
  event_lem A ->
  A ∪ ¬ A === Ω.
Proof.
  firstorder.
Qed.

Lemma event_inter_true_l {T} (A:event T) : Ω ∩ A === A.
Proof.
  firstorder.
Qed.

Lemma event_inter_true_r {T} (A:event T) : A ∩ Ω === A.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_inter_true_l @event_inter_true_r : prob.

Lemma event_inter_false_l {T} (A:event T) : ∅ ∩ A === ∅.
Proof.
  firstorder.
Qed.

Lemma event_inter_false_r {T} (A:event T) : A ∩ ∅ === ∅.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_inter_false_l @event_inter_false_r : prob.

Lemma event_inter_complement {T} (A:event T) :
  A ∩ ¬ A === ∅.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_inter_complement : prob.

Lemma event_diff_true_l {T} (A:event T) : Ω \ A === ¬ A.
Proof.
  firstorder.
Qed.

Lemma event_diff_true_r {T} (A:event T) : A \ Ω === ∅.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_diff_true_l @event_diff_true_r : prob.

Lemma event_diff_false_l {T} (A:event T) : ∅ \ A === ∅.
Proof.
  firstorder.
Qed.

Lemma event_diff_false_r {T} (A:event T) : A \ ∅ === A.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_diff_false_l @event_diff_false_r : prob.

Lemma event_diff_sub {T:Type} (x y:event T) : x \ y ≤ x.
Proof.
  firstorder.
Qed.

Hint Resolve event_diff_sub : prob.

Lemma event_union_comm {T} (A B:event T) : A ∪ B === B ∪ A.
Proof.
  firstorder.
Qed.

Lemma event_inter_comm {T} (A B:event T) : A ∩ B === B ∩ A.
Proof.
  firstorder.
Qed.

Lemma event_union_self {T} (A:event T) : A ∪ A === A.
Proof.
  firstorder.
Qed.

Lemma event_inter_self {T} (A:event T) : A ∩ A === A.
Proof.
  firstorder.
Qed.

Lemma event_diff_self {T} (A:event T) : A \ A === ∅.
Proof.
  firstorder.
Qed.

Lemma event_union_not_self {T} (A:event T) :
  event_lem A ->
  A ∪ ¬ A === Ω.
Proof.
  firstorder.
Qed.

Hint Rewrite @event_union_self @event_inter_self @event_diff_self : prob.

Lemma event_complement_swap {T} (A B:event T) :
      event_lem A ->
      event_lem B ->
      ¬ A === B <-> A === ¬ B.
Proof.
  firstorder.
Qed.

Lemma event_not_not {T} (A:event T) :
  event_lem A ->
  ¬ (¬ A) === A.
Proof.
  firstorder.
Qed.

Lemma event_not_all {T} :
  ¬ (@Ω T) === ∅.
Proof.
  firstorder.
Qed.

Lemma event_not_none {T} :
  ¬ ∅ === (@Ω T).
Proof.
  firstorder.
Qed.

Hint Rewrite @event_not_all @event_not_none : prob.

Lemma event_inter_not_self {T} (A B:event T) : A ∩ ¬ A === ∅.
Proof.
  firstorder.
Qed.

Lemma event_union_assoc {T} (A B C:event T) : A ∪ (B ∪ C) === (A ∪ B) ∪ C.
Proof.
  firstorder.
Qed.

Lemma event_inter_assoc {T} (A B C:event T) : A ∩ (B ∩ C) === (A ∩ B) ∩ C.
Proof.
  firstorder.
Qed.

Lemma event_union_inter_distr {T} (A B C:event T) : A ∪ (B ∩ C) === (A ∪ B) ∩ (A ∪ C).
Proof.
  firstorder.
Qed.

Lemma event_inter_union_distr {T} (A B C:event T) : A ∩ (B ∪ C) === (A ∩ B) ∪ (A ∩ C).
Proof.
  firstorder.
Qed.

Hint Rewrite @event_union_self @event_inter_self @event_inter_not_self : prob.

Lemma event_union_diff {T:Type} (A B:event T) :
  event_lem A ->
  A ∪ (B \ A) === A ∪ B.
Proof.
  intros.
  rewrite event_diff_derived.
  rewrite event_union_inter_distr.
  rewrite event_union_not_self by trivial.
  autorewrite with prob.
  reflexivity.
Qed.

Lemma event_union_sub_l {T:Type} (A B:event T) :
  B ≤ A -> A ∪ B === A.
Proof.
  firstorder.
Qed.

Lemma event_union_sub_r {T:Type} (A B:event T) :
  A ≤ B -> A ∪ B === B.
Proof.
  firstorder.
Qed.

Lemma event_union_diff_sub {T:Type} (A B:event T) :
  event_lem A ->
  A ≤ B -> A ∪ (B \ A) === B.
Proof.
  intros.
  rewrite event_union_diff by trivial.
  apply event_union_sub_r; trivial.
Qed.

(* Collections are *countable* sequences of subsets of the powerset of T. *)

Definition collection_is_pairwise_disjoint {T: Type} (collection: nat -> event T) :=
  forall n1 n2 : nat, n1 <> n2 ->
                      event_disjoint (collection n1) (collection n2).

(* Returns a new set prop (T->Prop) that returns true if t:T is in any of the sets within the collection. *)
Definition union_of_collection {T: Type} (collection: nat -> event T) : event T :=
  fun t:T => (exists n, (collection n) t).

Definition inter_of_collection {T: Type} (collection: nat -> event T) : event T :=
  fun t:T => (forall n, (collection n) t).

Lemma collection_is_pairwise_disjoint_sub {T:Type} (coll:nat -> event T) (f:event T -> event T):
  (forall a, f a ≤ a) ->
  collection_is_pairwise_disjoint coll ->
  collection_is_pairwise_disjoint (fun n => f (coll n)).
Proof.
  intros subs disj n1 n2 neq.
  specialize (disj _ _ neq).
  repeat rewrite subs; trivial.
Qed.

Lemma event_inter_countable_union_distr {T} (A:event T) (coll:nat->event T) :
  A ∩ union_of_collection coll === union_of_collection (fun n => A ∩ (coll n)).
Proof.
  firstorder.
Qed.

Class SigmaAlgebra (T:Type) :=
  {
    sa_sigma : event T -> Prop;

    (* alternative to assuming functional extensionality *)
    sa_proper :> Proper (event_equiv ==> iff) sa_sigma ;

    (* alternative to assuming LEM *)
    sa_dec (A:event T) : event_lem A;

    sa_countable_union (collection: nat -> event T) :
      (forall n, sa_sigma (collection n)) ->
      sa_sigma (union_of_collection collection);

    sa_complement (A:event T) :
      sa_sigma A -> sa_sigma (¬ A) ;

    sa_all : sa_sigma Ω

  }.

Hint Resolve sa_dec : prob.

(* restate some lemmas that rely on lem unconditionally *)
Lemma ps_event_union_complement {T} {s : SigmaAlgebra T} (A:event T) :
  A ∪ ¬ A === Ω.
Proof.
  apply event_union_complement.
  apply sa_dec.
Qed.

Lemma ps_event_union_not_self {T} {s : SigmaAlgebra T} (A:event T) :
  A ∪ ¬ A === Ω.
Proof.
  apply event_union_not_self.
  apply sa_dec.
Qed.

Lemma ps_event_union_diff {T:Type} {s : SigmaAlgebra T} (A B:event T) :
  A ∪ (B \ A) === A ∪ B.
Proof.
  apply event_union_diff.
  apply sa_dec.
Qed.

Lemma ps_event_union_diff_sub {T:Type} {s : SigmaAlgebra T} (A B:event T) :
  A ≤ B -> A ∪ (B \ A) === B.
Proof.
  apply event_union_diff_sub.
  apply sa_dec.
Qed.

Hint Resolve @ps_event_union_complement @ps_event_union_not_self 2ps_event_union_diff @ps_event_union_diff_sub : prob.

Lemma sa_notnot {T} {s: SigmaAlgebra T} (A:event T) : forall x, ~ ~ A x -> A x.
Proof.
  intros.
  destruct (sa_dec A x); intuition.
Qed.

Lemma sa_none {T} {s: SigmaAlgebra T} : sa_sigma (∅).
Proof.
  eapply sa_proper
  ; [ | eapply sa_complement; eapply sa_all].
  firstorder.
Qed.

Hint Resolve sa_all sa_none sa_complement : prob.

Lemma sa_countable_inter {T} {s: SigmaAlgebra T} (collection: nat -> event T) :
  (forall n, sa_sigma (collection n)) ->
  sa_sigma (inter_of_collection collection).
Proof.
  intros H.
  generalize (sa_countable_union (fun n => event_complement (collection n)))
  ; intros HH.
  cut_to HH.
  - unfold inter_of_collection, union_of_collection in *.
    apply sa_complement in HH.
    eapply sa_proper; [| eapply HH]; intros x.
    unfold event_complement in *.
    split; intros.
    + intros [n ncoll].
      intuition.
    + destruct (sa_dec (collection n) x); trivial.
      elim H0; eauto.
  - intros.
    apply sa_complement; auto.
Qed.

Definition list_collection {T} (l:list (event T)) (d:event T) : nat -> event T
  := fun n => nth n l d.

Definition list_union {T} (l:list (event T)) : event T
  := fun x => exists a, In a l /\ a x.

Definition list_inter {T}  (l:list (event T)) : event T
  := fun x => forall a, In a l -> a x.

Lemma event_inter_list_union_distr {T} (A:event T) (l: list (event T)) :
  A ∩ list_union l === list_union (map (event_inter A) l).
Proof.
  unfold list_union; intros.
  intros x; simpl.
  simpl; split; intros HH.
  - destruct HH as [ax [B [Bin Bx]]].
    exists (event_inter A B).
    split.
    + apply in_map_iff.
      eauto.
    + firstorder.
  - destruct HH as [Bi [Biin Bix]].
    apply in_map_iff in Biin.
    destruct Biin as [B [Bieq Bin]]; subst.
    firstorder.
Qed.

Lemma list_union_union {T} (l:list (event T)) :
  union_of_collection (list_collection l ∅) === list_union l.
Proof.
  unfold equiv, event_equiv, union_of_collection, list_collection, list_union.
  intros x.
  split; intros H.
  - destruct H as [n nnth].
    destruct (nth_in_or_default n l ∅).
    + eauto.
    + rewrite e in nnth.
      red in nnth; intuition.
  - destruct H as [a [inn ax]].
    eapply In_nth in inn.
    destruct inn as [n [_ nnth]].
    exists n.
    rewrite nnth.
    trivial.
Qed.

Lemma list_inter_inter {T} (l:list (event T)) :
  inter_of_collection (list_collection l Ω) === list_inter l.
Proof.
  unfold equiv, event_equiv, inter_of_collection, list_collection, list_inter.
  intros x.
  split; intros H.
  - intros a inn.
    eapply In_nth in inn.
    destruct inn as [n [_ nnth]].
    rewrite <- nnth.
    eauto.
  - intros n.
    destruct (nth_in_or_default n l Ω).
    + eapply H; eauto.
    + rewrite e; vm_compute; trivial.
Qed.

Lemma list_union_nil {T:Type} :
  @list_union T [] === ∅.
Proof.
  firstorder.
Qed.

Lemma list_union_cons {T} (x1 : event T) (l:list (event T)):
  list_union (x1::l) === x1 ∪ (list_union l).
Proof.
  unfold equiv, event_equiv, list_union, event_union; simpl; intros.
  split.
  - intros [?[??]].
    intuition (congruence || eauto).
  - intros [?|[??]]; intuition eauto.
Qed.

Hint Rewrite @list_union_nil @list_union_cons : prob.

Lemma list_union2 {T} (x1 x2 : event T) :
  list_union [x1 ; x2] === x1 ∪ x2.
Proof.
  autorewrite with prob.
  reflexivity.
Qed.

Lemma list_inter_nil {T:Type} :
  @list_inter T [] === Ω.
Proof.
  firstorder.
Qed.

Lemma list_inter_cons {T} (x1 : event T) (l:list (event T)):
  list_inter (x1::l) === x1 ∩ (list_inter l).
Proof.
  unfold equiv, event_equiv, list_union, event_inter; simpl; intros.
  split.
  - intros.
    generalize (H x1); simpl; intros HH.
    intuition.
    intros a inn.
    generalize (H a); simpl.
    intuition eauto.
  - intros [??] a; simpl.
    red in H0.
    intuition.
    + congruence.
    + eapply H0; eauto.
Qed.

Hint Rewrite @list_inter_nil @list_inter_cons : prob.

Lemma list_inter2 {T} (x1 x2 : event T) :
  list_inter [x1 ; x2] === x1 ∩ x2.
Proof.
  autorewrite with prob.
  reflexivity.
Qed.

Lemma list_collection_disjoint {T} (l:list (event T)) :
    ForallOrdPairs event_disjoint l ->
    collection_is_pairwise_disjoint (list_collection l ∅).
Proof.
  unfold collection_is_pairwise_disjoint, event_disjoint, event_none, list_collection.
  - induction l; simpl; intros.
    + simpl in H1.
      destruct n1; simpl in *; tauto.
    + inversion H; subst; clear H.
      specialize (IHl H6).
      simpl in *.
      destruct n1.
      * destruct n2; simpl; [tauto | ].
        { destruct (nth_in_or_default n2 l (fun _ : T => False)).
          - rewrite Forall_forall in H5.
            eapply H5; eauto.
          - rewrite e in H2; tauto.
        }
      * { destruct n2.
          - destruct (nth_in_or_default n1 l (fun _ : T => False)).
            + rewrite Forall_forall in H5.
              specialize (H5 _ i _ H2); tauto.
            + rewrite e in H1; tauto.
          - eauto.
        }
Qed.

Lemma list_collection_sigma {T} {s : SigmaAlgebra T} (l:list (event T)) (d:event T) :
  ((forall x : event T, In x l -> sa_sigma x) /\ sa_sigma d) <->
  (forall n : nat, sa_sigma (list_collection l d n)).
Proof.
  unfold list_collection.
  split; intros.
  - destruct H.
    destruct (nth_in_or_default n l d).
    + eauto.
    + rewrite e.
      trivial.
  - split; intros.
    + eapply In_nth in H0.
      destruct H0 as [n [_ nnth]].
      specialize (H n).
      rewrite nnth in H; trivial.
    + specialize (H (length l)).
      rewrite nth_overflow in H; auto.
Qed.

Lemma sa_list_union {T} {s: SigmaAlgebra T} (l:list (event T)) :
  (forall x, In x l -> sa_sigma x) ->
  sa_sigma (list_union l).
Proof.
  intros.
  rewrite <- list_union_union.
  apply sa_countable_union.
  apply list_collection_sigma.
  auto with prob.
Qed.

Lemma sa_list_inter {T} {s: SigmaAlgebra T} (l:list (event T)) :
  (forall x, In x l -> sa_sigma x) ->
  sa_sigma (list_inter l).
Proof.
  intros.
  rewrite <- list_inter_inter.
  apply sa_countable_inter.
  apply list_collection_sigma.
  auto with prob.
Qed.

Lemma sa_union {T} {s: SigmaAlgebra T} {A₁ A₂} :
  sa_sigma A₁ -> sa_sigma A₂ -> sa_sigma (A₁ ∪ A₂).
Proof.
  intros.
  rewrite <- list_union2.
  apply sa_list_union.
  simpl; intuition congruence.
Qed.

Lemma sa_inter {T} {s: SigmaAlgebra T} {A₁ A₂} :
  sa_sigma A₁ -> sa_sigma A₂ -> sa_sigma (A₁ ∩ A₂).
Proof.
  intros.
  rewrite <- list_inter2.
  apply sa_list_inter.
  simpl; intuition congruence.
Qed.

Hint Resolve sa_union sa_inter : prob.

Lemma sa_diff {T} {s: SigmaAlgebra T} {A₁ A₂} :
  sa_sigma A₁ -> sa_sigma A₂ -> sa_sigma (A₁ \ A₂).
Proof.
  intros.
  rewrite event_diff_derived.
  auto with prob.
Qed.

Hint Resolve sa_diff : prob.

(* Prop: the sum of probabilities for everything in the collection == R. *)
Definition sum_of_probs_equals {T:Type}
           (p : event T -> R)
           (collection: nat -> event T) (result: R) :=
  infinite_sum' (fun n:nat => p (collection n)) result.

Class ProbSpace {T:Type} (S:SigmaAlgebra T) :=
  {
    ps_P: event T -> R;
    ps_proper :> Proper (event_equiv ==> eq) ps_P ;

    ps_countable_disjoint_union (collection: nat -> event T) :
      (* Assume: collection is a subset of Sigma and its elements are pairwise disjoint. *)
      (forall n:nat, sa_sigma (collection n)) ->
      collection_is_pairwise_disjoint collection ->
      sum_of_probs_equals ps_P collection (ps_P (union_of_collection collection));

    ps_one : ps_P Ω = R1;

    ps_pos (A:event T): sa_sigma A -> (0 <= ps_P A)%R
  }.

Lemma ps_all {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) : ps_P Ω = R1.
Proof.
  apply ps_one.
Qed.

(* P numbers are as per https://www.stat.washington.edu/~nehemyl/files/UW_MATH-STAT394_axioms-proba.pdf *)
(* P1.1 *)
Lemma ps_none {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) : ps_P ∅ = R0.
Proof.
  generalize (ps_countable_disjoint_union
                (fun n => match n with
                          | 0 => Ω
                          | _ => ∅
                          end))
  ; intros HH.
  cut_to HH.
  - simpl in HH.
    red in HH.
    apply (infinite_sum'_split 1) in HH.
    simpl in HH.

    apply (infinite_sum'_ext (fun x : nat => ps_P match (x + 1)%nat with
                                                  | 0%nat => Ω
                                                  | S _ => ∅
                                                  end)
                             (fun x : nat => ps_P ∅)) in HH.
    + rewrite (@ps_proper _ _ _ (union_of_collection
                           (fun n : nat => match n with
                                           | 0%nat => Ω
                                           | S _ => ∅
                                           end)) (Ω)) in HH.
      * replace (ps_P (ProbSpace:=ps) Ω) with R1 in HH
          by (symmetry; apply ps_one).
        replace (R1 - (0 + R1))%R with R0 in HH by lra.
        eapply infinite_sum'_const1; eauto.
      * unfold event_equiv, Ω; intuition.
        red.
        exists 0%nat; trivial.
    + destruct x; simpl; trivial.
  - destruct n.
    + apply sa_all.
    + apply sa_none.
  - unfold collection_is_pairwise_disjoint.
    destruct n1; destruct n2; unfold Ω, event_none, event_disjoint; try tauto.
Qed.

Hint Rewrite @ps_none @ps_all : prob.

Local Open Scope R.

(* P1.2 *)
Lemma ps_list_disjoint_union {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (l: list (event T)) :
  (* Assume: collection is a subset of Sigma and its elements are pairwise disjoint. *)
  (forall x : event T, In x l -> sa_sigma x) ->
  ForallOrdPairs event_disjoint l ->
  ps_P (list_union l) = fold_right Rplus 0 (map ps_P l).
Proof.
  intros Hs Hd.
  generalize (ps_countable_disjoint_union (list_collection l ∅)); intros HH.
  cut_to HH.
  - unfold sum_of_probs_equals in HH.
    erewrite ps_proper in HH; [| eapply list_union_union ].
    apply (infinite_sum'_split (length l)) in HH.
    apply (infinite_sum'_ext  (fun x : nat => ps_P (list_collection l ∅ (x + length l)))
                              (fun x : nat => 0)) in HH.
    + apply infinite_sum'_const2 in HH.
      apply Rminus_diag_uniq in HH.
      rewrite HH.
      clear.
      unfold list_collection.
      rewrite sum_f_R0'_as_fold_right.
      rewrite (list_as_nthseq l ∅) at 2.
      rewrite map_map.
      rewrite fold_right_map; trivial.
    + intros.
      erewrite ps_proper; [eapply ps_none | ]; intros.
      unfold list_collection.
      rewrite nth_overflow; intuition.
  - apply list_collection_sigma.
    intuition.
  - apply list_collection_disjoint; trivial.
Qed.

Lemma ps_disjoint_union {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (x1 x2: event T) :
  (* Assume: collection is a subset of Sigma and its elements are pairwise disjoint. *)
  sa_sigma x1 ->
  sa_sigma x2 ->
  event_disjoint x1 x2 ->
  ps_P (x1 ∪ x2) = ps_P x1 + ps_P x2.
Proof.
  intros sa1 sa2 disj.
  rewrite <- list_union2.
  rewrite ps_list_disjoint_union; simpl.
  - lra.
  - intuition congruence.
  - repeat constructor; trivial.
Qed.

(* P1.3 *)
Lemma ps_sub {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A B: event T) :
  sa_sigma A ->
  sa_sigma B ->
  A ≤ B -> ps_P A <= ps_P B.
Proof.
  intros sa1 sa2 impl.
  generalize (ps_disjoint_union ps
                                A (B \ A)); intros HH.
  cut_to HH; [ | auto with prob.. ].
  rewrite event_union_diff_sub in HH by auto with prob.
  rewrite HH.
  generalize (ps_pos (B \ A)); intros.
  cut_to H; auto with prob.
  lra.
Qed.

(* C1.1 *)
Lemma ps_le1 {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A: event T)
  : sa_sigma A ->
    ps_P A <= R1.
Proof.
  intros.
  rewrite <- ps_one.
  apply ps_sub; auto with prob.
Qed.

(* P1.4 *)
Lemma ps_countable_total {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A:event T) (coll:nat -> event T) :
  sa_sigma A ->
  (forall n, sa_sigma (coll n)) ->
  collection_is_pairwise_disjoint coll ->
  union_of_collection coll === Ω ->
  infinite_sum' (fun i => ps_P (A ∩ (coll i))) (ps_P A).
Proof.
  intros saA saC disjC partC.
  rewrite <- (event_inter_true_r A).
  rewrite <- partC.
  rewrite event_inter_countable_union_distr.
  apply ps_countable_disjoint_union.
  - auto with prob.
  - apply collection_is_pairwise_disjoint_sub; auto with prob.
Qed.

Lemma ps_list_total {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A:event T) (l: list (event T)) :
  sa_sigma A ->
  Forall sa_sigma l ->
  ForallOrdPairs event_disjoint l ->
  list_union l === Ω ->
  ps_P A = fold_right Rplus 0 (map ps_P (map (event_inter A) l)).
Proof.
  intros.
  rewrite <- ps_list_disjoint_union.
  - rewrite <- event_inter_list_union_distr.
    rewrite H2.
    autorewrite with prob.
    trivial.
  - intros x xin.
    apply in_map_iff in xin.
    destruct xin as [? [??]]; subst.
    rewrite Forall_forall in H0.
    auto with prob.
  - apply ForallOrdPairs_impl; trivial.
    apply ForallPairs_ForallOrdPairs.
    firstorder.
Qed.

Lemma ps_total {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A B C:event T) :
  sa_sigma A ->
  sa_sigma B ->
  sa_sigma C ->
  event_disjoint B C ->
  B ∪ C === Ω ->
  ps_P A = ps_P (A ∩ B) + ps_P (A ∩ C).
Proof.
  intros.
  intros.
  rewrite (ps_list_total ps A [B;C]); trivial.
  - simpl; lra.
  - repeat constructor; trivial.
  - repeat constructor; trivial.
  - rewrite list_union2; trivial.
Qed.

(* P1.5 *)
Lemma ps_complement {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A: event T) :
  sa_sigma A ->
  ps_P (¬ A) = 1 - ps_P A.
Proof.
  intros sa1.
  generalize (ps_total ps Ω A (¬ A)); intros HH.
  cut_to HH; auto with prob.
  - rewrite ps_one in HH.
    autorewrite with prob in HH.
    lra.
Qed.

(* P1.6 *)
Lemma ps_union {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A B: event T) :
  sa_sigma A ->
  sa_sigma B ->
  ps_P (A ∪ B) = ps_P A + ps_P B - ps_P (A ∩ B).
Proof.
  intros sa1 sa2.
  rewrite <- event_union_diff by auto with prob.
  rewrite ps_disjoint_union by auto with prob.
  rewrite (ps_total ps B A (¬ A)) by auto with prob.
  rewrite event_diff_derived.
  rewrite (event_inter_comm A B).
  lra.
Qed.

(* P1.7 inclusion/exclusion identity should not be hard to prove,
   but is somewhat painful to state so it is omitted for now.
   We state and prove the case for n=3 for fun
 *)

Lemma ps_union3 {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) (A B C: event T) :
  sa_sigma A ->
  sa_sigma B ->
  sa_sigma C ->
  ps_P (A ∪ B ∪ C) =
  ps_P A + ps_P B + ps_P C
                    - ps_P (A ∩ B) - ps_P (A ∩ C) - ps_P (B ∩ C)
  + ps_P (A ∩ B ∩ C).
Proof.
  intros sa1 sa2 sa3.
  rewrite (ps_union ps (A ∪ B) C) by auto with prob.
  rewrite (ps_union ps A B) by auto with prob.
  rewrite (event_inter_comm (A ∪ B) C).
  rewrite event_inter_union_distr.
  rewrite (ps_union ps (C ∩ A) (C ∩ B)) by auto with prob.
  rewrite (event_inter_comm A C).
  rewrite (event_inter_comm B C).
  cut ((C ∩ A) ∩ (C ∩ B) === (A ∩ B) ∩ C).
  { intros eqq; rewrite eqq; lra. }
  rewrite event_inter_assoc.
  rewrite (event_inter_comm (C ∩ A) C).
  rewrite event_inter_assoc.
  autorewrite with prob.
  rewrite (event_inter_comm C A).
  rewrite <- event_inter_assoc.
  rewrite (event_inter_comm C B).
  rewrite event_inter_assoc.
  reflexivity.
Qed.

Lemma ps_boole_inequality {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S)
      (l: list (event T)) :
  Forall sa_sigma l ->
  ps_P (list_union l) <= fold_right Rplus 0 (map ps_P l).
Proof.
  intros.
  induction l; simpl.
  - autorewrite with prob.
    lra.
  - inversion H; clear H; subst.
    autorewrite with prob.
    rewrite ps_union; trivial.
    + specialize (IHl H3).
      generalize ( ps_pos (a ∩ list_union l)); intros.
      cut_to H.
      * lra.
      * rewrite Forall_forall in *.
        apply sa_inter; trivial.
        apply sa_list_union; auto.
    + apply sa_list_union.
      apply Forall_forall; trivial.
Qed.

Definition make_collection_disjoint {T:Type} (coll:nat->event T) : nat -> event T
  := fun x => coll x \ (union_of_collection (fun y =>
                                               if lt_dec y x
                                               then coll y
                                               else ∅)).

Lemma make_collection_disjoint_in {T:Type} (coll:nat->event T) (x:nat) (e:T) :
  make_collection_disjoint coll x e <->
  (coll x e /\ forall y, (y < x)%nat -> ~ coll y e).
Proof.
  split.
  - unfold make_collection_disjoint; intros HH.
    destruct HH as [H1 H2].
    split; trivial.
    intros y ylt cy.
    apply H2.
    exists y.
    destruct (lt_dec y x); intuition.
  - intros [ce fce].
    unfold make_collection_disjoint.
    split; trivial.
    unfold union_of_collection.
    intros [n Hn].
    destruct (lt_dec n x); trivial.
    eapply fce; eauto.
Qed.

(*
Require Import Arith Wf.

Lemma make_collection_disjoint_in_exists {T:Type} (coll:nat->event T) (x:nat) (e:T) :
  coll x e ->
  exists n : nat, make_collection_disjoint coll n e.
Proof.
  intros.
  unfold make_collection_disjoint.
  assert ((exists y, y < x /\ coll y e) \/ ~(exists y, y < x /\ coll y e) )%nat.

  revert H.
  induction x as [ x IHx ] using (well_founded_induction lt_wf).
  induction x; intros H.
  - exists 0%nat.
    simpl.
    compute.
    split; trivial.
    firstorder.
  -
*)

Lemma sa_make_collection_disjoint {T:Type} (sa:SigmaAlgebra T) (coll:nat->event T) :
  (forall n, sa_sigma (coll n)) ->
  (forall n : nat, sa_sigma (make_collection_disjoint coll n)).
Proof.
  unfold make_collection_disjoint; intros sas n.
  apply sa_diff; [eauto | ].
  apply sa_countable_union; intros.
  destruct (lt_dec n0 n)
  ; auto with prob.
Qed.

Lemma make_collection_disjoint_disjoint {T:Type} (coll:nat->event T) :
  collection_is_pairwise_disjoint (make_collection_disjoint coll).
Proof.
  intros x y xyneq e e1 e2.
  apply make_collection_disjoint_in in e1.
  apply make_collection_disjoint_in in e2.
  destruct e1 as [H11 H12].
  destruct e2 as [H21 H22].
  destruct (not_eq _ _ xyneq) as [xlt|ylt].
  - eapply H22; eauto.
  - eapply H12; eauto.
Qed.

Lemma union_of_make_collection_disjoint {T:Type} {sa:SigmaAlgebra T} (ps:ProbSpace sa) (coll:nat->event T) :
  (forall n : nat, sa_sigma (coll n)) ->
  sum_of_probs_equals ps_P  (make_collection_disjoint coll) (ps_P (union_of_collection  (make_collection_disjoint coll))).
Proof.
  intros.
  apply ps_countable_disjoint_union.
  - apply sa_make_collection_disjoint; trivial.
  - apply make_collection_disjoint_disjoint.
Qed.

Section RandomVariable.
  (* todo better type names. *)
  (* The preimage of the function X on codomain B. *)
  Definition preimage {Ts: Type} {Td: Type}
             (X: Ts -> Td)
             (B: event Td)
             := fun omega: Ts => B (X omega).

  (* A random variable is a mapping from a pobability space to a sigma algebra. *)
  Class RandomVariable {Ts:Type} {Td:Type}
        {doms: SigmaAlgebra Ts}
        (dom: ProbSpace doms)
        (cod: SigmaAlgebra Td) :=
    {
      (* the random variable. *)
      rv_X: Ts -> Td;

      (* for every element B in the sigma algebra,
           the preimage of rv_X on B is an event in the probability space *)
      rv_preimage: forall B: event Td, (sa_sigma (preimage rv_X B));
    }.

  Class RealValuedRandomVariable {Ts:Type}
        {doms: SigmaAlgebra Ts}
        (dom: ProbSpace doms)
        (cod: SigmaAlgebra R) :=
    {
      rrv: RandomVariable dom cod;

      rrv_is_real: forall r:R, sa_sigma (fun omega:Ts => (rv_X omega) <= r);
    }.

End RandomVariable.

Section lebesgueintegration.

  Class MeasurableFunction {Ts: Type} (dom: SigmaAlgebra Ts) :=
    {
      measure_mu: event Ts -> R;

      measure_none : measure_mu ∅ = R0 ;
      measure_ge_zero: forall A : event Ts, sa_sigma A -> 0 <= measure_mu A;

      measure_coutably_additive: forall collection: nat -> event Ts,
           (forall n : nat, sa_sigma (collection n)) ->
           collection_is_pairwise_disjoint collection ->
           sum_of_probs_equals measure_mu collection (measure_mu (union_of_collection collection))

    }.

  (* See https://en.wikipedia.org/wiki/Lebesgue_integration#Towards_a_formal_definition *)
  Definition F_star {dom:SigmaAlgebra R} (measure: MeasurableFunction dom) (f: R -> R) (t: R) :=
    measure_mu (fun (x: R) => (f x) > t).

  (* The integral $\int f d\mu defined in terms of the Riemann integral.
   * note that this definition assumes that f : R -> R+
   * Again, see https://en.wikipedia.org/wiki/Lebesgue_integration#Towards_a_formal_definition *)
  Definition Lebesgue_integrable_pos {dom: SigmaAlgebra R}
             (f : R -> R)
             (f_nonneg : forall x:R, f x > 0)
             (measure: MeasurableFunction dom)
             (a b : R) :=
    (Riemann_integrable (F_star measure f) a b).
End lebesgueintegration.

Instance ProbSpace_Measurable {T:Type} {sa: SigmaAlgebra T} (ps:ProbSpace sa) : MeasurableFunction sa
  := {
      measure_mu := ps_P ;
      measure_none := (ps_none ps) ;
      measure_ge_zero := ps_pos ;
      measure_coutably_additive := ps_countable_disjoint_union ;
    }.

Section zmBoundedVariance.
  (* TODO finish this definition *)
  Class ZeroMeanVoundedVariance (t: nat -> R) :=
    {
      has_zero_mean: Prop;
      has_bounded_variance: Prop;
    }.
End zmBoundedVariance.

Section prob.
  Local Open Scope R.
  Local Open Scope prob.

  Definition Pr {Ts:Type} {Td:Type}
             {doms: SigmaAlgebra Ts}
             {dom: ProbSpace doms}
             {cod: SigmaAlgebra Td}
             {rv:RandomVariable dom cod}
             (S:Td->Prop)
    := ps_P (fun x:Ts => S (rv_X x)).

  Context {Ts:Type} {Td:Type}
          {doms: SigmaAlgebra Ts}
          {dom: ProbSpace doms}
          {cod: SigmaAlgebra Td}
          {rv:RandomVariable dom cod}.

  Definition independent (A B:Td->Prop) :=
    Pr (A ∩ B) = (Pr A * Pr B).

  Notation "a ⊥ b" := (independent a b) (at level 50) : prob. (* \perp *)

  Lemma pr_all : Pr Ω = R1.
  Proof.
    unfold Pr; simpl.
    rewrite (ps_proper _ Ω) by firstorder.
    apply ps_all.
  Qed.

  Lemma pr_none : Pr ∅ = R0.
  Proof.
    unfold Pr; simpl.
    rewrite (ps_proper _ ∅) by firstorder.
    apply ps_none.
  Qed.

End prob.

Notation "∅" := event_none : prob. (* \emptyset *)
Notation "a ∪ b" := (event_union a b) (at level 50) : prob. (* \cup *)
Notation "a ∩ b" := (event_inter a b) (at level 50) : prob. (* \cap *)
Notation "¬ a" := (event_complement a) (at level 20) : prob. (* \neg *)
Notation "a \ b" := (event_diff a b) (at level 50) : prob.
Notation "a ≤ b" := (event_sub a b) (at level 70) : prob. (* \leq *)

Require Import Classical ClassicalFacts.

Section classic.

  Lemma make_collection_disjoint_union {T:Type} {S:SigmaAlgebra T} (coll:nat->event T) :
    union_of_collection coll
                        ===
                        union_of_collection (make_collection_disjoint coll).
  Proof.
    unfold union_of_collection.
    intros t.
    split; intros [n Hn].
    - generalize (excluded_middle_entails_unrestricted_minimization classic (fun n => coll n t))
      ; intros HH.
      specialize (HH _ Hn).
      destruct HH as [m mmin].
      exists m.
      destruct mmin.
      unfold make_collection_disjoint.
      split; trivial.
      unfold union_of_collection.
      intros [nn Hnn].
      destruct (lt_dec nn m); [ | tauto].
      specialize (H0 _ Hnn).
      omega.
    - apply make_collection_disjoint_in in Hn.
      exists n; tauto.
  Qed.

  Lemma ps_diff_le {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S) x y :
    sa_sigma x ->
    sa_sigma y ->
    ps_P (x \ y) <= ps_P x.
  Proof.
    intros.
    apply ps_sub; auto with prob.
  Qed.

  Lemma make_collection_disjoint_le {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S)
        (coll: nat -> event T) :
    (forall n, sa_sigma (coll n)) ->
    forall n, ps_P (make_collection_disjoint coll n) <= ps_P (coll n).
  Proof.
    intros sas n.
    unfold make_collection_disjoint.
    apply ps_diff_le; auto 2.
    apply sa_countable_union; intros nn.
    destruct (lt_dec nn n); auto with prob.
  Qed.

  Theorem ps_countable_boole_inequality {T:Type} {S:SigmaAlgebra T} (ps:ProbSpace S)
        (coll: nat -> event T) sum :
    (forall n, sa_sigma (coll n)) ->
    infinite_sum' (fun n => ps_P (coll n)) sum ->
    ps_P (union_of_collection coll) <= sum.
  Proof.
    intros sas.
    rewrite make_collection_disjoint_union.
    generalize (union_of_make_collection_disjoint ps coll sas); intros.
    unfold sum_of_probs_equals in H.
    eapply infinite_sum'_le; eauto.
    intros n; simpl.
    apply make_collection_disjoint_le; trivial.
  Qed.

End classic.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * lset: finite sets represented as lists *)

(** This module is used quite intensively, as finite sets are
   pervasives (free variables, summations, partial derivatives...):

   We implement finite sets as simple lists, without any additional
   structure: this allows for very simple operations and
   specifications, without the need for keeping well-formedness
   hypotheses around.

   When a bit of efficiency is required, we use sorted listed without
   duplicates as a special case (but without ensuring that these lists
   are sorted: we managed to avoid such a need in our proofs).

   We declare these finite sets a sup-semilattice with bottom element,
   allowing us to use the lattice tactics and theorems in a
   transparent way. *)

Require Import lattice comparisons.
Require Export List. Export ListNotations.

Set Implicit Arguments.

(** * semi-lattice of finite sets as simple lists *)

(** two lists are equal when they contain the same elements,
   independently of their position or multiplicity *)

Canonical Structure lset_ops A := lattice.mk_ops (list A)
  (fun h k => forall a, In a h -> In a k)
  (fun h k => forall a, In a h <-> In a k)
  (@app A) (@app A) (assert_false id) (@nil A) (@nil A).

(** the fact that this makes a semi-lattice is almost trivial *)
Instance lset_laws A: lattice.laws BSL (lset_ops A).
Proof.
  constructor; simpl; try discriminate.
   firstorder.
   firstorder.
   setoid_rewrite in_app_iff. firstorder.
   firstorder.
Qed.

(** the [map] function on lists is actually a monotone function over the
   represented sets *)
Instance map_leq A B (f: A -> B): Proper (leq ==> leq) (map f).
Proof.
  intro h. induction h as [|a h IH]; intros k H. apply leq_bx.
  intros i [<-|I]. apply in_map. apply H. now left.
  apply IH. 2: assumption. intros ? ?. apply H. now right.
Qed.
Instance map_weq A B (f: A -> B): Proper (weq ==> weq) (map f) := op_leq_weq_1.

(** [map] is extensional *)
Instance map_compat A B: Proper (pwr eq ==> eq ==> eq) (@map A B).
Proof. intros f g H h k <-. apply map_ext, H. Qed.

(** belonging to a singleton *)
Lemma in_singleton A (x y: A): In x [y] <-> y=x.
Proof. simpl. tauto. Qed.

(** the following tactic replaces all occurrences of [cons] with
   degenerated concatenations, so that the [lattice] can subsequently
   handle them *)

Ltac fold_cons :=
  repeat match goal with
    | |- context[@cons ?A ?x ?q] => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q)
    | H: context[!cons ?A ?x ?q] |- _ => (constr_eq q (@nil A); fail 1) || change (x::q) with ([x]++q) in H
  end.

(** * sorted lists without duplicates *)

(** when the elements come with a [cmpType] structure, one can perform
   sorted lists operations *)

Section m.
 Context {A: cmpType}.

 (** sorted merge of sorted lists *)
 Fixpoint union (l1: list A) :=
   match l1 with
     | nil => fun l2 => l2
     | h1::t1 =>
       let fix union' l2 :=
         match l2 with
           | nil => l1
           | h2::t2 =>
             match cmp h1 h2 with
               | Eq => h1::union t1 t2
               | Lt => h1::union t1 l2
               | Gt => h2::union' t2
             end
         end
         in union'
   end.

 (** sorted insertion in a sorted list *)
 Fixpoint insert (i: A) l :=
   match l with
     | nil => i::nil
     | j::q =>
       match cmp i j with
         | Eq => l
         | Lt => i::l
         | Gt => j::insert i q
       end
   end.

 (** weak specification: [union] actually performs an union *)
 Lemma union_app: forall h k, union h k == h ++ k.
 Proof.
   induction h as [|x h IHh]; simpl union. reflexivity.
   induction k as [|y k IHk]. lattice. case cmp_spec.
   intros ->. fold_cons. rewrite IHh. lattice.
   intros _. fold_cons. rewrite IHh. lattice.
   intros _. fold_cons. rewrite IHk. lattice.
 Qed.

 (** and [insert] actually performs an insertion *)
 Lemma insert_union: forall i l, insert i l = union [i] l.
 Proof.
   induction l; simpl. reflexivity.
   case cmp_spec. congruence. reflexivity. now rewrite IHl.
 Qed.

 Lemma insert_app: forall i l, insert i l == [i] ++ l.
 Proof. intros. rewrite insert_union. apply union_app. Qed.

End m.

Module Fix.

Canonical Structure lset_ops A := lattice.mk_ops (list A)
  (fun h k => forall a, In a h -> In a k)
  (fun h k => forall a, In a h <-> In a k)
  (@app A) (@app A) (assert_false id) (@nil A) (@nil A).

End Fix.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Vector Theory implemented with DepList.
  author    : ZhengPu Shi
  date      : 2022.06

  remark    :
*)

Require Export VectorTheory.
Require Import DepList.MatrixTheoryDL.

Require Import VectorDef.
Import VectorNotations.

(* ######################################################################### *)
(** * Basic vector theory implemented with DepList *)

Module BasicVectorTheoryDL (E : ElementType).

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export BasicMatrixTheoryDL := BasicMatrixTheoryDL E.

  (* ==================================== *)
  (** ** Vector element type *)
  Export E.

  Infix "==" := (eqlistA Aeq) : list_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope vec_scope.

  (* ==================================== *)
  (** ** Vector type *)

  Definition vec n := mat n 1.

  (** matrix equality *)
  Definition veq {n} (v1 v2 : vec n) := meq v1 v2.
  Infix "==" := veq : vec_scope.

  (** meq is equivalence relation *)
  Lemma veq_equiv : forall n, Equivalence (veq (n:=n)).
  Proof.
    intros. apply meq_equiv.
  Qed.

  (** Get element of vector *)
  Definition vnth {n} (v : vec n) i : A := @mnth n 1 v i 0.

(*   Notation "v .[ i ]" := (vnth v i) (at level 30) : vec_scope. *)
  (* Notation "v . [ i ]" := (vnth i v) (at level 30). *)

  (** veq and mnth should satisfy this constraint *)
  Lemma veq_iff_vnth : forall {n : nat} (v1 v2 : vec n),
      (v1 == v2) <-> (forall i, i < n -> (vnth v1 i == vnth v2 i)%A).
  Proof.
    intros.
  Admitted.

  (* ==================================== *)
  (** ** Convert between list and vector *)
  Definition v2l {n} (v : vec n) : list A := hdc A0 (m2l v).
  (* Definition v2l' {n} (v : vec n) : list A := to_list (mcoli v F1). *)

  Definition l2v {n} (l : list A) : vec n := l2m (row2col l).

  Lemma v2l_length : forall {n} (v : vec n), length (v2l v) = n.
  Admitted.

  Lemma v2l_l2v_id : forall {n} (l : list A),
    length l = n -> (@v2l n (@l2v n l) == l)%list.
  Admitted.

  Lemma l2v_v2l_id : forall {n} (v : vec n), l2v (v2l v) == v.
  Admitted.

  (* ==================================== *)
  (** ** Convert between tuples and vector *)
  Definition t2v_2 (t : @T2 A) : vec 2 := let '(a,b) := t in [[a];[b]].
  Definition t2v_3 (t : @T3 A) : vec 3 := let '(a,b,c) := t in [[a];[b];[c]].
  Definition t2v_4 (t : @T4 A) : vec 4 := let '(a,b,c,d) := t in [[a];[b];[c];[d]].

  Definition v2t_2 (v : vec 2) : @T2 A := (
      hd (hd v),
      hd (hd (tl v))
    ).

  Definition v2t_3 (v : vec 3) : @T3 A := (
      hd (hd v),
      hd (hd (tl v)),
      hd (hd (tl (tl v)))
    ).

  Definition v2t_4 (v : vec 4) : @T4 A := (
      hd (hd v),
      hd (hd (tl v)),
      hd (hd (tl (tl v))),
      hd (hd (tl (tl (tl v))))
    ).

  Lemma v2t_t2v_id_2 : forall (t : A * A), v2t_2 (t2v_2 t) = t.
  Proof.
    intros. destruct t. simpl. unfold v2t_2. f_equal.
  Qed.

  Lemma t2v_v2t_id_2 : forall (v : vec 2), t2v_2 (v2t_2 v) == v.
  Proof.
    intros. cbn.
    repeat match goal with
           | v : vec (S _) |- _ =>
               destruct (vec_S v) as [? [? E]]; rewrite E; clear E; simpl
           | v : Matrix.vec (S _) |- _ =>
               destruct (vec_S v) as [? [? E]]; rewrite E; clear E; simpl
           | v : vec 0 |- _ => rewrite (vec_0 v)
           | v : Matrix.vec 0 |- _ => rewrite (vec_0 v)
           end.
  (*   easy. *)
    (* Qed. *)
  Admitted.

  (** mapping of a vector *)
  Definition vmap {n} (v : vec n) f : vec n := mmap f v.

  (** folding of a vector *)
(*   Definition vfold : forall {B : Type} {n} (v : vec n) (f : A -> B) (b : B), B. *)

  (** mapping of two matrices *)
  Definition vmap2 {n} (v1 v2 : vec n) f : vec n := mmap2 f v1 v2.

End BasicVectorTheoryDL.

(* ######################################################################### *)
(** * Ring vector theory implemented with DepList  *)

(** zero vector, vector addition, opposition, substraction, scalar multiplication,
    dot product *)
Module RingVectorTheoryDL (E : RingElementType) <: RingVectorTheory E.

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export RingMatrixTheoryDL := RingMatrixTheoryDL E.

  Export E.
  Include (BasicVectorTheoryDL E).

  (** ** Zero vector *)
  Definition vec0 {n} : vec n := mat0 n 1.

  (* (** Assert that a vector is an zero vector. *) *)
  (* Definition vzero {n} (v : vec n) : Prop := v = vec0. *)

  (* (** Assert that a vector is an non-zero vector. *) *)
  (* Definition vnonzero {n} (v : vec n) : Prop := ~(vzero v). *)

  (* (** vec0 is equal to mat0 with column 1 *) *)
  (* Lemma vec0_eq_mat0 : forall n, vec0 = mat0 n 1. *)
  (* Proof. *)
  (*   intros. easy. *)
  (* Qed. *)

  (* (** It is decidable that if a vector is zero vector. *) *)
  (* Lemma vzero_dec : forall {n} (v : vec n), {vzero v} + {vnonzero v}. *)
  (* Proof. *)
  (*   intros. apply meq_dec. *)
  (* Qed. *)

  (** *** Vector addition *)

  Definition vadd {n} (v1 v2 : vec n) : vec n := madd v1 v2.
  Infix "+" := vadd.

  (** v1 + v2 = v2 + v1 *)
  Lemma vadd_comm : forall {n} (v1 v2 : vec n), (v1 + v2) == (v2 + v1).
  Proof.
    intros. apply madd_comm.
  Qed.

  (** (v1 + v2) + v3 = v1 + (v2 + v3) *)
  Lemma vadd_assoc : forall {n} (v1 v2 v3 : vec n), (v1 + v2) + v3 == v1 + (v2 + v3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** vec0 + v = v *)
  Lemma vadd_0_l : forall {n} (v : vec n), vec0 + v == v.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** v + vec0 = v *)
  Lemma vadd_0_r : forall {n} (v : vec n), v + vec0 == v.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** *** Vector opposite *)

  Definition vopp {n} (v : vec n) : vec n := mopp v.
  Notation "- v" := (vopp v).

  (** v + (- v) = vec0 *)
  Lemma vadd_opp_r : forall {n} (v : vec n), v + (- v) == vec0.
  Proof.
    intros. apply madd_opp.
  Qed.

  (** v + (- v) = vec0 *)
  Lemma vadd_opp_l : forall {n} (v : vec n), (- v) + v == vec0.
  Proof.
    intros. rewrite vadd_comm. apply madd_opp.
  Qed.

  (** *** Vector subtraction *)

  Definition vsub {n} (v1 v2 : vec n) : vec n := v1 + (- v2).
  Infix "-" := vsub.

  (** *** Vector scalar multiplication *)

  Definition vcmul {n} a (v : vec n) : vec n := a c* v.
  Definition vmulc {n} (v : vec n) a : vec n := v *c a.

  (** v *c a = a c* v *)
  Lemma vmulc_eq_vcmul : forall {n} a (v : vec n), v *c a == a c* v.
  Proof.
    intros. apply mmulc_eq_mcmul.
  Qed.

  (** a c* (b c* v) = (a * b) c* v *)
  Lemma vcmul_assoc : forall {n} a b (v : vec n), a c* (b c* v) == (a * b) c* v.
  Proof.
    intros. apply mcmul_assoc.
  Qed.

  (** a c* (b c* v) = b c* (a c* v) *)
  Lemma vcmul_perm : forall {n} a b (v : vec n), a c* (b c* v) == b c* (a c* v).
  Proof.
    intros. apply mcmul_perm.
  Qed.

  (** (a + b) c* v = (a c* v) + (b c* v) *)
  Lemma vcmul_add_distr_l : forall {n} a b (v : vec n),
    (a + b)%A c* v == (a c* v) + (b c* v).
  Proof.
    intros. apply mcmul_add_distr_r.
  Qed.

  (** a c* (v1 + v2) = (a c* v1) + (a c* v2) *)
  Lemma vcmul_add_distr_r : forall {n} a (v1 v2 : vec n),
    a c* (v1 + v2) == (a c* v1) + (a c* v2).
  Proof.
    intros. unfold vadd. apply mcmul_add_distr_l.
  Qed.

  (** 1 c* v = v *)
  Lemma vcmul_1_l : forall {n} (v : vec n), A1 c* v == v.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** 0 c* v = vec0 *)
  Lemma vcmul_0_l : forall {n} (v : vec n), A0 c* v == vec0.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** *** Vector dot product *)

  (** dot production of two vectors.
      Here, we use matrix multiplication to do it, and it is a different way to
      general situation. *)
  Definition vdot {n : nat} (v1 v2 : vec n) :=
    scalar_of_mat (v1\T * v2)%mat.

End RingVectorTheoryDL.

(* ######################################################################### *)
(** * Decidable-field vector theory implemented with DepList  *)

Module DecidableFieldVectorTheoryDL (E : DecidableFieldElementType)
<: DecidableFieldVectorTheory E.

  (* ==================================== *)
  (** ** Also contain matrix theory *)
  Module Export DecidableFieldMatrixTheoryDL := DecidableFieldMatrixTheoryDL E.

  Export E.
  Include (RingVectorTheoryDL E).

  (** veq is decidable *)
  Lemma veq_dec : forall (n : nat), Decidable (veq (n:=n)).
  Proof. intros. apply meq_dec. Qed.

End DecidableFieldVectorTheoryDL.

(* ######################################################################### *)
(** * Test  *)
Module Test.

  Module Import VectorR := RingVectorTheoryDL RingElementTypeR.
  Import Reals.
  Open Scope R.

  Definition v1 := @l2v 3 [1;2;3].
  Definition v2 := @l2v 3 [4;5;6].
  Example vdot_ex1 : vdot v1 v2 = (4+10+18)%R.
  Proof.
    compute. ring.
  Qed.

End Test.

(** ** Others, later ... *)

(*
  (* ==================================== *)
  (** ** 2-dim vector operations *)

  (** Square of length of a 2D vector *)
  Definition vlen2 (v : vec 2) : A :=
    let '(x,y) := v2t_2 v in
      (x * x + y * y)%X.

  (* ==================================== *)
  (** ** 3-dim vector operations *)

  (** Square of length of a 3D vector *)
  Definition vlen3 (v : vec 3) : A :=
    let '(x,y,z) := v2t_3 v in
      (x * x + y * y + z * z)%X.

  (** dot product of a 3D vector *)
  Definition vdot3 (v0 v1 : vec 3) : A :=
    let '(a0,b0,c0) := v2t_3 v0 in
    let '(a1,b1,c1) := v2t_3 v1 in
      (a0 * a1 + b0 * b1 + c0 * c1)%X.

  (** v1 <> 0 -> v2 <> 0 -> v1 = k c* v2 -> k <> 0 *)
  Lemma vec_eq_vcmul_imply_coef_neq0 : forall {n} (v1 v2 : vec n) k,
    vnonzero v1 -> vnonzero v2 -> v1 = k c* v2 -> k <> A0.
  Proof.
    intros. intro. subst. apply vcmul_0_l in H. destruct H. easy.
  Qed.

  (* ==================================== *)
  (** ** Vector equility *)

  Lemma veq_dec : forall {n} (v1 v2 : vec n), {v1 = v2} + {v1 <> v2}.
  Proof.
    intros. apply meq_dec.
  Qed.

 *)


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(*i $Id: ConstructiveEpsilon.v 12112 2009-04-28 15:47:34Z herbelin $ i*)

(** This provides with a proof of the constructive form of definite
and indefinite descriptions for Sigma^0_1-formulas (hereafter called
"small" formulas), which infers the sigma-existence (i.e.,
[Type]-existence) of a witness to a decidable predicate over a
countable domain from the regular existence (i.e.,
[Prop]-existence). *)

(** Coq does not allow case analysis on sort [Prop] when the goal is in
not in [Prop]. Therefore, one cannot eliminate [exists n, P n] in order to
show [{n : nat | P n}]. However, one can perform a recursion on an
inductive predicate in sort [Prop] so that the returning type of the
recursion is in [Type]. This trick is described in Coq'Art book, Sect.
14.2.3 and 15.4. In particular, this trick is used in the proof of
[Fix_F] in the module Coq.Init.Wf. There, recursion is done on an
inductive predicate [Acc] and the resulting type is in [Type].

To find a witness of [P] constructively, we program the well-known
linear search algorithm that tries P on all natural numbers starting
from 0 and going up.  Such an algorithm needs a suitable termination
certificate.  We offer two ways for providing this termination
certificate: a direct one, based on an ad-hoc predicate called
[before_witness], and another one based on the predicate [Acc].
For the first one we provide explicit and short proof terms. *)

(** Based on ideas from Benjamin Werner and Jean-François Monin *)

(** Contributed by Yevgeniy Makarov and Jean-François Monin *)

(* -------------------------------------------------------------------- *)

(* Direct version *)

Section ConstructiveIndefiniteGroundDescription_Direct.

Variable P : nat -> Prop.

Hypothesis P_dec : forall n, {P n}+{~(P n)}.

(** The termination argument is [before_witness n], which says that
any number before any witness (not necessarily the [x] of [exists x :A, P x])
makes the search eventually stops. *)

Inductive before_witness (n:nat) : Prop :=
  | stop : P n -> before_witness n
  | next : before_witness (S n) -> before_witness n.

(* Computation of the initial termination certificate *)
Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 :=
  match n return (before_witness n -> before_witness 0) with
    | 0 => fun b => b
    | S n => fun b => O_witness n (next n b)
  end.

(* Inversion of [inv_before_witness n] in a way such that the result
is structurally smaller even in the [stop] case. *)
Definition inv_before_witness :
  forall n, before_witness n -> ~(P n) -> before_witness (S n) :=
  fun n b =>
    match b return ~ P n -> before_witness (S n) with
      | stop _ p => fun not_p => match (not_p p) with end
      | next _ b => fun _ => b
    end.

Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} :=
  match P_dec m with
    | left yes => exist (fun n => P n) m yes
    | right no => linear_search (S m) (inv_before_witness m b no)
  end.

Definition constructive_indefinite_ground_description_nat :
  (exists n, P n) -> {n:nat | P n} :=
  fun e => linear_search O (let (n, p) := e in O_witness n (stop n p)).

End ConstructiveIndefiniteGroundDescription_Direct.

(************************************************************************)

(* Version using the predicate [Acc] *)

Require Import Arith.

Section ConstructiveIndefiniteGroundDescription_Acc.

Variable P : nat -> Prop.

Hypothesis P_decidable : forall n : nat, {P n} + {~ P n}.

(** The predicate [Acc] delineates elements that are accessible via a
given relation [R]. An element is accessible if there are no infinite
[R]-descending chains starting from it.

To use [Fix_F], we define a relation R and prove that if [exists n, P n]
then 0 is accessible with respect to R. Then, by induction on the
definition of [Acc R 0], we show [{n : nat | P n}].

The relation [R] describes the connection between the two successive
numbers we try. Namely, [y] is [R]-less then [x] if we try [y] after
[x], i.e., [y = S x] and [P x] is false. Then the absence of an
infinite [R]-descending chain from 0 is equivalent to the termination
of our searching algorithm. *)

Let R (x y : nat) : Prop := x = S y /\ ~ P y.

Local Notation acc x := (Acc R x).

Lemma P_implies_acc : forall x : nat, P x -> acc x.
Proof.
intros x H. constructor.
intros y [_ not_Px]. absurd (P x); assumption.
Qed.

Lemma P_eventually_implies_acc : forall (x : nat) (n : nat), P (n + x) -> acc x.
Proof.
intros x n; generalize x; clear x; induction n as [|n IH]; simpl.
apply P_implies_acc.
intros x H. constructor. intros y [fxy _].
apply IH. rewrite fxy.
replace (n + S x) with (S (n + x)); auto with arith.
Defined.

Corollary P_eventually_implies_acc_ex : (exists n : nat, P n) -> acc 0.
Proof.
intros H; elim H. intros x Px. apply P_eventually_implies_acc with (n := x).
replace (x + 0) with x; auto with arith.
Defined.

(** In the following statement, we use the trick with recursion on
[Acc]. This is also where decidability of [P] is used. *)

Theorem acc_implies_P_eventually : acc 0 -> {n : nat | P n}.
Proof.
intros Acc_0. pattern 0. apply Fix_F with (R := R); [| assumption].
clear Acc_0; intros x IH.
destruct (P_decidable x) as [Px | not_Px].
exists x; simpl; assumption.
set (y := S x).
assert (Ryx : R y x). unfold R; split; auto.
destruct (IH y Ryx) as [n Hn].
exists n; assumption.
Defined.

Theorem constructive_indefinite_ground_description_nat_Acc :
  (exists n : nat, P n) -> {n : nat | P n}.
Proof.
intros H; apply acc_implies_P_eventually.
apply P_eventually_implies_acc_ex; assumption.
Defined.

End ConstructiveIndefiniteGroundDescription_Acc.

(************************************************************************)

Section ConstructiveGroundEpsilon_nat.

Variable P : nat -> Prop.

Hypothesis P_decidable : forall x : nat, {P x} + {~ P x}.

Definition constructive_ground_epsilon_nat (E : exists n : nat, P n) : nat
  := proj1_sig (constructive_indefinite_ground_description_nat P P_decidable E).

Definition constructive_ground_epsilon_spec_nat (E : (exists n, P n)) : P (constructive_ground_epsilon_nat E)
  := proj2_sig (constructive_indefinite_ground_description_nat P P_decidable E).

End ConstructiveGroundEpsilon_nat.

(************************************************************************)

Section ConstructiveGroundEpsilon.

(** For the current purpose, we say that a set [A] is countable if
there are functions [f : A -> nat] and [g : nat -> A] such that [g] is
a left inverse of [f]. *)

Variable A : Type.
Variable f : A -> nat.
Variable g : nat -> A.

Hypothesis gof_eq_id : forall x : A, g (f x) = x.

Variable P : A -> Prop.

Hypothesis P_decidable : forall x : A, {P x} + {~ P x}.

Definition P' (x : nat) : Prop := P (g x).

Lemma P'_decidable : forall n : nat, {P' n} + {~ P' n}.
Proof.
intro n; unfold P'; destruct (P_decidable (g n)); auto.
Defined.

Lemma constructive_indefinite_ground_description : (exists x : A, P x) -> {x : A | P x}.
Proof.
intro H. assert (H1 : exists n : nat, P' n).
destruct H as [x Hx]. exists (f x); unfold P'. rewrite gof_eq_id; assumption.
apply (constructive_indefinite_ground_description_nat P' P'_decidable)  in H1.
destruct H1 as [n Hn]. exists (g n); unfold P' in Hn; assumption.
Defined.

Lemma constructive_definite_ground_description : (exists! x : A, P x) -> {x : A | P x}.
Proof.
  intros; apply constructive_indefinite_ground_description; firstorder.
Defined.

Definition constructive_ground_epsilon (E : exists x : A, P x) : A
  := proj1_sig (constructive_indefinite_ground_description E).

Definition constructive_ground_epsilon_spec (E : (exists x, P x)) : P (constructive_ground_epsilon E)
  := proj2_sig (constructive_indefinite_ground_description E).

End ConstructiveGroundEpsilon.

(* begin hide *)
(* Compatibility: the qualificative "ground" was absent from the initial
names of the results in this file but this had introduced confusion
with the similarly named statement in Description.v *)
Notation constructive_indefinite_description_nat :=
  constructive_indefinite_ground_description_nat (only parsing).
Notation constructive_epsilon_spec_nat :=
  constructive_ground_epsilon_spec_nat (only parsing).
Notation constructive_epsilon_nat :=
  constructive_ground_epsilon_nat (only parsing).
Notation constructive_indefinite_description :=
  constructive_indefinite_ground_description (only parsing).
Notation constructive_definite_description :=
  constructive_definite_ground_description (only parsing).
Notation constructive_epsilon_spec :=
  constructive_ground_epsilon_spec (only parsing).
Notation constructive_epsilon :=
  constructive_ground_epsilon (only parsing).
(* end hide *)


From Coq Require Import List.
From Coq Require Import Lia.
From Coq Require Import PeanoNat.
Import Compare_dec.

From Classes Require Import Default.

Set Implicit Arguments.
(* for compatibility with coq master *)
Set Warnings "-undeclared-scope".
Set Warnings "-unsupported-attributes".

Set Default Proof Using "Type".

Section Array.
  Context (A:Type).
  Context {def: Default A}.
  Notation list := (list A).
  Implicit Types (l:list) (n:nat) (x:A).

  Fixpoint assign l n x' : list :=
    match l with
    | nil => nil
    | x::xs => match n with
              | 0 => x'::xs
              | S n => x::assign xs n x'
              end
    end.

  Hint Extern 3 (_ < _) => lia : core.
  Hint Extern 3 (_ >= _) => lia : core.

  (* there's no way to create a rewriting base other than adding a hint *)
  #[local] Hint Rewrite (@eq_refl False) using fail : solve_rewrite.

  Ltac simplify :=
    autorewrite with solve_rewrite in *.

  Ltac solver :=
    eauto; try lia; try congruence.

  Ltac finish_solve :=
    solve [ solver ].

  Ltac induct l :=
    induction l; simpl;
    intros n; intros;
    [ simplify; solver |
      try (destruct n; simpl in *;
           simplify;
           [ finish_solve | solver ]) ].

  Theorem length_assign l x' : forall n,
    length (assign l n x') = length l.
  Proof.
    induct l.
  Qed.

  Theorem assign_oob l x : forall n,
      n >= length l ->
      assign l n x = l.
  Proof.
    induct l.
    rewrite IHl by lia; auto.
  Qed.

  Theorem assign_assign_eq l x1 x2 : forall n,
      assign (assign l n x1) n x2 = assign l n x2.
  Proof.
    induct l.
  Qed.

  Theorem assign_assign_ne l x1 x2 : forall n1 n2,
      n1 <> n2 ->
      assign (assign l n1 x1) n2 x2 = assign (assign l n2 x2) n1 x1.
  Proof.
    induct l.
    destruct n, n2; simpl; try congruence.
    rewrite IHl by congruence; auto.
  Qed.

  Fixpoint index l n : option A :=
    match l with
    | nil => None
    | x::xs => match n with
              | 0 => Some x
              | S n => index xs n
              end
    end.

  Theorem index_assign_eq l : forall n x',
      n < length l ->
      index (assign l n x') n = Some x'.
  Proof.
    induct l.
  Qed.

  Theorem index_assign_ne l : forall n1 n2 x',
      n1 <> n2 ->
      index (assign l n2 x') n1 = index l n1.
  Proof.
    induct l.
    - generalize dependent n.
      induction n2; simpl; intros.
      + destruct n; solver.
      + destruct n; solver.
  Qed.

  Theorem index_oob l : forall n,
      n >= length l ->
      index l n = None.
  Proof.
    induct l.
  Qed.

  Theorem index_not_none l : forall n,
      n < length l ->
      index l n <> None.
  Proof.
    induct l.
  Qed.

  Theorem index_none_bound l n :
      index l n = None ->
      length l <= n.
  Proof.
    intros.
    destruct (lt_dec n (length l)); try lia.
    exfalso; apply index_not_none in H; auto.
  Qed.

  Theorem index_some_bound l n x :
    index l n = Some x ->
    n < length l.
  Proof.
    intros.
    destruct (lt_dec n (length l)); eauto.
    assert (index l n = None) by eauto using index_oob.
    congruence.
  Qed.

  Theorem index_inbounds_exists l n :
    n < length l ->
    exists v, index l n = Some v.
  Proof.
    intros.
    destruct_with_eqn (index l n); eauto.
    apply index_none_bound in Heqo; lia.
  Qed.

  Theorem index_ext_eq l1 l2 :
    (forall n, index l1 n = index l2 n) ->
    l1 = l2.
  Proof.
    generalize dependent l2.
    induction l1; intros l2; intros.
    - destruct l2; auto.
      specialize (H 0); simpl in *; congruence.
    - destruct l2.
      + specialize (H 0); simpl in *; congruence.
      + f_equal.
        specialize (H 0); simpl in *; congruence.
        apply IHl1; eauto; intros.
        specialize (H (S n)); simpl in *; auto.
  Qed.

  (* extensional equality for in-bounds addresses, with a separate proof lengths
  are equal *)
  Theorem index_bound_ext_eq l1 l2 :
    length l1 = length l2 ->
    (forall n, n < length l1 -> n < length l2 -> index l1 n = index l2 n) ->
    l1 = l2.
  Proof.
    intros.
    apply index_ext_eq; intros.
    destruct (lt_dec n (length l1)); auto.
    rewrite ?index_oob by auto; auto.
  Qed.

  Definition sel l n : A :=
    match index l n with
    | Some x => x
    | None => default
    end.

  Ltac index_to_sel H :=
    unfold sel; intros;
    try rewrite H; solve [ auto ].

  Theorem sel_assign_eq l : forall n x',
      n < length l ->
      sel (assign l n x') n = x'.
  Proof.
    index_to_sel index_assign_eq.
  Qed.

  Theorem sel_assign_ne l : forall n1 n2 x',
      n1 <> n2 ->
      sel (assign l n2 x') n1 = sel l n1.
  Proof.
    index_to_sel index_assign_ne.
  Qed.

  Theorem index_inbounds l n :
    n < length l ->
    index l n = Some (sel l n).
  Proof.
    unfold sel; intros.
    destruct_with_eqn (index l n); eauto.
    apply index_none_bound in Heqo; lia.
  Qed.

  Theorem sel_index_eq l1 n1 l2 n2 :
    index l1 n1 = index l2 n2 ->
    sel l1 n1 = sel l2 n2.
  Proof.
    index_to_sel H.
  Qed.

  Theorem index_sel_eq l1 n1 l2 n2 :
    n1 < length l1 ->
    n2 < length l2 ->
    sel l1 n1 = sel l2 n2 ->
    index l1 n1 = index l2 n2.
  Proof.
    intros.
    rewrite ?index_inbounds by auto; congruence.
  Qed.

  Theorem sel_ext_eq l1 l2 :
    length l1 = length l2 ->
    (forall n, n < length l1 -> n < length l2 -> sel l1 n = sel l2 n) ->
    l1 = l2.
  Proof.
    intros.
    apply index_bound_ext_eq; auto; intros.
    apply index_sel_eq; auto.
  Qed.

  Definition index_dec l n : {n < length l /\ index l n = Some (sel l n)}
                             + {length l <= n /\ index l n = None}.
  Proof.
    destruct (lt_dec n (length l)); [ left | right ];
      split; try lia;
      auto using index_inbounds, index_oob.
  Qed.

  Definition subslice l n m : list :=
    firstn m (skipn n l).

  Ltac solve_lengths :=
    autorewrite with length; auto; lia.

  Lemma skipn_nil n : skipn n (@nil A) = nil.
  Proof.
    destruct n; simpl; auto.
  Qed.

  Lemma skipn_length n : forall l, length (skipn n l) = length l - n.
  Proof.
    induction n; simpl; intros; auto.
    - lia.
    - destruct l; simpl; auto.
  Qed.

  #[local] Hint Rewrite firstn_nil skipn_nil : solve_rewrite.
  #[local] Hint Rewrite firstn_length_le using (solve_lengths) : length.
  #[local] Hint Rewrite skipn_length : length.

  Theorem subslice_nil n m :
    subslice nil n m = @nil A.
  Proof.
    unfold subslice.
    rewrite skipn_nil, firstn_nil; auto.
  Qed.

  Theorem length_subslice_general l n m :
    length (subslice l n m) = Nat.min m (length l - n).
  Proof.
    unfold subslice.
    rewrite firstn_length.
    rewrite skipn_length.
    auto.
  Qed.

  Theorem length_subslice l n m :
    n + m <= length l ->
    length (subslice l n m) = m.
  Proof.
    unfold subslice; intros.
    autorewrite with length; auto.
  Qed.

  Theorem length_subslice_oob l n m :
    n + m >= length l ->
    length (subslice l n m) = length l - n.
  Proof.
    rewrite length_subslice_general.
    intros.
    destruct (Nat.min_spec m (length l - n)); lia.
  Qed.

  Lemma index_firstn l : forall n i,
      i < n ->
      index (firstn n l) i = index l i.
  Proof.
    induct l.
    destruct i; auto.
  Qed.

  Lemma index_firstn_oob l : forall n i,
      i >= n ->
      index (firstn n l) i = None.
  Proof.
    induct l.
    destruct i; solver.
  Qed.

  Lemma index_skipn l : forall n i,
      index (skipn n l) i = index l (n + i).
  Proof.
    induct l.
  Qed.

  #[local] Hint Rewrite index_oob using lia : array.
  #[local] Hint Rewrite index_firstn using lia : array.
  #[local] Hint Rewrite index_firstn_oob using lia : array.
  #[local] Hint Rewrite index_skipn using lia : array.

  Theorem subslice_index_ok l : forall n m i,
      i < m ->
      index (subslice l n m) i = index l (n+i).
  Proof.
    unfold subslice; intros.
    autorewrite with array; auto.
  Qed.

  Theorem subslice_index_oob l : forall n m i,
      i >= m ->
      index (subslice l n m) i = None.
  Proof.
    unfold subslice; intros.
    autorewrite with array; auto.
  Qed.

  Theorem subslice_index_oob_l l : forall n m i,
      n+i >= length l ->
      index (subslice l n m) i = None.
  Proof.
    unfold subslice; intros.
    destruct (lt_dec i m);
      autorewrite with array; auto.
  Qed.

  Theorem subslice_sel_ok l : forall n m i,
      i < m ->
      sel (subslice l n m) i = sel l (n+i).
  Proof.
    index_to_sel subslice_index_ok.
  Qed.

  Theorem subslice_index_conv l : forall n m i,
      i >= n ->
      i+n < m ->
      index l i = index (subslice l n m) (i-n).
  Proof.
    intros.
    rewrite subslice_index_ok by lia.
    f_equal; lia.
  Qed.

  Theorem subslice_cons x xs n m :
    subslice (x::xs) (S n) m =
    subslice xs n m.
  Proof.
    unfold subslice; simpl.
    reflexivity.
  Qed.

  Theorem subslice_at0 l m :
    subslice l 0 m = firstn m l.
  Proof.
    unfold subslice; simpl; auto.
  Qed.

  Theorem firstn_oob l n :
    n >= length l ->
    firstn n l = l.
  Proof.
    generalize dependent l.
    induction n; simpl; intros.
    - destruct l; simpl in *; auto.
      exfalso; lia.
    - destruct l; simpl in *; auto.
      rewrite IHn by lia; auto.
  Qed.

  Theorem subslice_to_end l n m :
    n + m >= length l ->
    subslice l n m = skipn n l.
  Proof.
    unfold subslice; intros.
    rewrite firstn_oob; auto.
    rewrite skipn_length; lia.
  Qed.

  Theorem subslice_whole l m :
    m >= length l ->
    subslice l 0 m = l.
  Proof.
    intros.
    rewrite subslice_at0.
    rewrite firstn_oob; auto.
  Qed.

  Theorem subslice_one_more l : forall i n p,
    index l i = Some p ->
    S i + n <= length l ->
    subslice l i (S n) = p :: subslice l (S i) n.
  Proof.
    induction l; simpl; intros.
    - congruence.
    - rewrite subslice_cons.
      destruct i; simpl in *.
      + inversion H; subst; clear H.
        rewrite subslice_at0 by lia.
        rewrite subslice_at0 by (simpl; lia).
        simpl; auto.
      + rewrite <- IHl; eauto; try lia.
  Qed.

  Theorem index_app_fst l1 : forall l2 i,
    i < length l1 ->
    index (l1 ++ l2) i = index l1 i.
  Proof.
    induction l1; simpl; intros.
    - lia.
    - destruct i; simpl; auto.
  Qed.

  Theorem index_app_snd l1 : forall l2 i,
    i >= length l1 ->
    index (l1 ++ l2) i = index l2 (i - length l1).
  Proof.
    induction l1; simpl; intros.
    - f_equal; lia.
    - destruct i; simpl; try lia.
      apply IHl1; auto; lia.
  Qed.

  Theorem index_app_snd_off l1 : forall l2 i,
    index (l1 ++ l2) (length l1 + i) = index l2 i.
  Proof.
    intros.
    rewrite index_app_snd by lia.
    f_equal; lia.
  Qed.

  Theorem subslice_select_array l1 l2 l3 n m :
    n = length l1 ->
    m = length l2 ->
    subslice (l1 ++ l2 ++ l3) n m = l2.
  Proof.
    intros; subst.
    apply index_ext_eq; intros.
    destruct (lt_dec n (length l2)).
    rewrite subslice_index_ok by lia.
    rewrite index_app_snd_off.
    rewrite index_app_fst by lia.
    auto.

    rewrite subslice_index_oob by lia.
    rewrite index_oob by lia.
    auto.
  Qed.

  Theorem length_bounds l n :
    length l <= n ->
    length l >= n ->
    length l = n.
  Proof.
    lia.
  Qed.

End Array.

Module ArrayNotations.
  (* Declare Scope array_scope. *)
  Delimit Scope array_scope with array.
  Notation "l [ i  :=  v ]" := (assign l i v) (at level 10, left associativity) : array_scope.
  Notation "l [ i ]" := (index l i) (at level 11, no associativity) : array_scope.
  Notation "l [! i ]" := (sel l i) (at level 11, no associativity) : array_scope.
End ArrayNotations.

Arguments index_oob [A].
Arguments index_inbounds [A] {def}.

Local Ltac solve_bounds :=
  auto; lia.
Local Ltac solve_lengths :=
  autorewrite with length; solve_bounds.

#[export] Hint Rewrite length_assign : length.
#[export] Hint Rewrite length_subslice_oob using solve_lengths : length.

#[export] Hint Rewrite index_oob using solve_lengths : array.
#[export] Hint Rewrite index_assign_eq using solve_lengths : array.
#[export] Hint Rewrite index_assign_ne using solve_bounds : array.

#[export] Hint Rewrite sel_assign_eq using solve_lengths : array.
#[export] Hint Rewrite sel_assign_ne using solve_bounds : array.
#[export] Hint Rewrite assign_oob using solve_lengths : array.
#[export] Hint Rewrite assign_assign_eq : array.

#[export] Hint Rewrite index_app_fst using solve_lengths : array.
#[export] Hint Rewrite index_app_snd using solve_lengths : array.
#[export] Hint Rewrite index_app_snd_off : array.

#[export] Hint Rewrite subslice_index_ok using solve_bounds : array.
#[export] Hint Rewrite subslice_index_oob using solve_bounds : array.
#[export] Hint Rewrite subslice_index_oob_l using solve_lengths : array.
#[export] Hint Rewrite subslice_sel_ok using solve_bounds : array.
#[export] Hint Rewrite subslice_select_array using solve_lengths : array.

Ltac array := autorewrite with length array; auto.


Require Export P03.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros n X l. generalize dependent l. generalize dependent n.
  induction n.
  - destruct l.
    + reflexivity.
    + simpl. intros H. inversion H.
  - destruct l.
    + reflexivity.
    + simpl. intros H. apply IHn. inversion H. reflexivity.
Qed.


Require Import  ExtLib.Data.Monads.StateMonad ExtLib.Structures.Monads.
Require Import ZArith.

Class Monad (M : Type -> Type) := {
  pure {X} : X -> M X;
  bind {X Y} : M X -> (X -> M Y) -> M Y
  }.

Definition State S X := S -> S * X.

(* a function that takes an input and returns twice that input, *)
(*    while also incrementing a global counter *)

Definition counter : Type := nat.
Definition stateful_double : Z -> State counter Z := (* Z -> M Z *)
  fun input_val old_counter => (S old_counter, 2 * input_val)%Z.

Import MonadNotation.
Open Scope monad_scope.
Definition incr_counter : state nat unit :=
  curr <- get;;
  _ <- put (S curr);;
  ret tt.

Definition stateful_double' : Z -> state nat Z :=
  fun x =>
    _ <- incr_counter;;
    ret (2 * x)%Z.

(* adds the current counter val to an input val *)
Definition add_count : nat -> State counter nat :=
  fun input_val old_counter => (old_counter, input_val + old_counter).

Definition state_pure {S} {X} : X -> State S X.
Proof.
  unfold State.
  intros x s.
  exact (s, x).
Defined.

Definition state_bind {S} {X Y} : State S X ->
  (X -> State S Y) -> State S Y.
Proof.
  unfold State.
  intros mx f.
  intro s0.
  destruct (mx s0) as [s1 x].
  exact (f x s1).
Defined.

Compute state_bind (state_pure 7%Z) (stateful_double) 3.
Compute state_bind (state_pure 5%Z) (stateful_double) 0.

#[global]
Instance State_Monad (S : Type) : Monad (State S) := {
  pure := @state_pure S;
  bind := @state_bind S
  }.

Class Point (X : Type) :=
  { point : X }.

Definition pointy {X Y} `{Point X} (f : X -> Y) : Y :=
  f point.

#[global]
 Instance Point_nat : Point nat :=
  { point := 7 }.

Compute pointy S.


(* Copyright 2021 Pierre Courtieu
  This file is part of LibHyps. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it. *)

Require Import FSets.FMapList FSets.FMapFacts Arith ZArith
        LibHyps.LibHyps List.
Require Import Structures.OrderedTypeEx FSets.FSetList.

Inductive binop := Plus | Minus | Mult.

Inductive exp : Type :=
| Val : Z -> exp
| BinOp: binop -> exp -> exp -> exp.

Definition eval_op op :=
  match op with
     Plus => Z.add| Minus => Z.sub| Mult => Z.mul
  end.

Inductive Eval_exp: exp -> Z -> Prop:=
  EE_val: forall v, Eval_exp (Val v) v
| EE_binop: forall e1 e2 v1 v2 op f,
    Eval_exp e1 v1
    -> Eval_exp e2 v2
    -> eval_op op = f
    -> Eval_exp (BinOp op e1 e2) (f v1 v2).

(* optional customization *)
Ltac rename_depth ::= constr:(3).
Local Open Scope autonaming_scope.
Import ListNotations.
Ltac rename_hyp_eval n th :=
  match th with
    Eval_exp ?e ?v => name(`_EE` ++ e#n ++ v#n)
  | Val ?v => name(v#(S n))
  | BinOp ?o ?e1 ?e2 => name(o#(S 0) ++ e1#n ++ e2#n)
  | eval_op ?o ?v1 ?v2 => name(o#(S 0) ++ v1#n ++ v2#n)
  end.
Close Scope autonaming_scope.
Ltac rename_hyp ::= rename_hyp_eval.

Lemma determ_nolibhyp: forall e v v',
    Eval_exp e v ->
    Eval_exp e v' ->
    v = v'.
Proof.
  intros * h_EE_e_v.
  induction h_EE_e_v as
      [v | e1 e2 v1 v2 op f h_e_v1 IHh_v1 h_e_v2 IHh_v2 hop];
    intros h_EE_e_v'.
  - inversion h_EE_e_v'.
    auto.
  - inversion h_EE_e_v'.
    subst. (* H2 H4... need to fix the proof! *)
Admitted.

(* Same proof as above, no naming effort. *)
Lemma determ: forall e v v',
    Eval_exp e v ->
    Eval_exp e v' ->
    v = v'.
Proof.
  intros until 1 /ng.
  induction h_EE_e_v_; intros  /sng.
  - inversion h_EE_v_v'_.
    auto.
  - inversion h_EE_op_e1_e2_v'_ /sng.
    (* need to fix the proof! *)
Admitted.

(*** Local Variables: ***)
(*** eval: (company-coq-mode 1) ***)
(*** End: ***)


(*|
########################################################################
Is there a ``eapply``-like tactic that works on ``exists`` goals in Coq?
########################################################################

:Link: https://stackoverflow.com/q/34216180
|*)

(*|
Question
********

I have the following during a proof where the goal is an existential,
and the target property is one of the assumptions.

.. code-block::

    H : x ==> y
    ...
    ______________________________________(1/2)
    exists t : tm, x ==> t

I know I can do ``exists y. apply H.`` to prove the current goal, but
I am wondering if there is a more intelligent tactic that can use the
assumption directly to prove the existential goal here, like ``eapply
H``?

Since this is one unification away, it would be nice not having to
write the ``X`` part in ``exists X.``.

If such a tactic does not exist, how do I write one?
|*)

(*|
Answer
******

There exists such a tactic and it is called ``eexists``. It does
exactly what you seem to expect.

https://coq.inria.fr/distrib/current/refman/Reference-Manual010.html#hevea_tactic23

----

Example use:
|*)

Variable T : Type.
Variable R : T -> T -> Prop.

Theorem test : forall x y, R x y -> exists t, R x t.
Proof.
  intros. eexists. apply H.
Qed.

(*|
----

**Q:** Thanks. An extra question. Is there a way to avoid the ``apply
H`` part? I can imagine something like ``eassumption`` that tries
``apply`` on every assumption. I tried ``assumption`` and got ``Error:
No such assumption.``

**A:** ``eexists. eassumption.`` works perfectly for the above
example. ``eauto.`` works too, btw.
|*)


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma bij_card_eq (T T' : finType) (f : T -> T') :
  bijective f -> #|T| = #|T'|.
Proof.
Admitted.

Section bool_irrelevance.

Implicit Types b c : bool.

(** Let's define a projection function which projects any two
    proofs into one canonical proof: *)
Definition proj {b c} (pf : b = c) : b = c :=
  if b =P c is ReflectT pf'
  then pf'   (* the canonical proof *)
  else pf.   (* this is an impossible case, we could have used [False_rect] here *)

(** A key property of [proj] function *)
Lemma proj_constant {b c} :
  forall (pf1 pf2 : b = c), proj pf1 = proj pf2.
Proof.
Admitted.

(** Another key property of [proj]: it's invertible!
    (although we only need injectivity) *)

Definition join b c d (pf : b = c) : b = d -> c = d :=
  etrans (esym pf).

Definition proj_inv {b c} (pf : b = c) : b = c :=
  join (proj (erefl b)) pf.

Lemma trans_sym_eq b c :
  forall pf : b = c, join pf pf = erefl c.
Proof.
Admitted.

Lemma proj_cancL b c :
  cancel (@proj b c) (@proj_inv b c).
Proof.
Admitted.

Theorem bool_irrelevance b c :
  forall (pf1 pf2 : b = c), pf1 = pf2.
Proof.
Admitted.

(** Now let's put [bool_irrelevance] to work *)
Lemma UIP_refl b :
  forall (pf : b = b), pf = erefl b.
Proof.
Admitted.

(** The Altenkirch-Streicher K axiom for booleans.
    See also https://ncatlab.org/nlab/show/axiom+K+%28type+theory%29
*)
Lemma Streicher_K b (P : b = b -> Prop) :
  P (erefl b) -> forall pf : b = b, P pf.
Proof.
Admitted.

End bool_irrelevance.


Module Alt.

  Definition double (n:nat) := 2 * n.

End Alt.

Require Import Arith Lia.

Require Import Even.

Lemma alt_double_ok n : Nat.double n = Alt.double n.
Proof.
  unfold Alt.double, Nat.double.
  lia.
Qed.


Require Import Iron.Language.SystemF2Effect.Value.Relation.TyJudge.

(* Weakening Type Env in Type Judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall ke te se sp ix x t1 e1 t2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (insert ix t2 te) se sp (liftXX 1 ix x) t1 e1.
Proof.
 intros. gen ix ke se sp te t1 e1 t2.
 induction x using exp_mutind with
  (PV := fun v => forall ix ke se sp te t1 t2
      ,  TypeV ke te se sp v t1
      -> TypeV ke (insert ix t2 te) se sp (liftXV 1 ix v) t1)
  ; intros; inverts_type; simpl; eauto.

 - Case "VVar".
   nnat; lift_cases; burn.

 - Case "VLam".
   apply TvLam; eauto.
   rewrite insert_rewind. auto.

 - Case "VLAM".
   apply TvLAM.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess. eauto.

 - Case "XLet".
   apply TxLet; eauto.
   rewrite insert_rewind. eauto.

 - Case "XPrivate".
   eapply TxPrivate with (t := t) (e := e); eauto.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess. eauto.

 - Case "XExtend".
   eapply TxExtend; eauto.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess. eauto.
Qed.

(* We can push a new type onto the environment stack provided
   we lift references to existing types across the new one. *)
Lemma type_tyenv_weaken1
 :  forall ke te se sp x t1 e1 t2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (te :> t2) se sp (liftXX 1 0 x) t1 e1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 burn using type_tyenv_insert.
Qed.

(* We can push a new type into the enviroment of a type-of-value
   judgement provided we lift references to existing types across
   the new one *)
Lemma typev_tyenv_weaken1
 :  forall ke te se sp v t1 t2
 ,  TypeV  ke te se sp v t1
 -> TypeV  ke (te :> t2) se sp (liftXV 1 0 v) t1.
Proof.
 intros.
 have HX: (TypeX ke te se sp (XVal v) t1 (TBot KEffect)).
 eapply type_tyenv_weaken1 in HX.
 simpl in HX. inverts HX. eauto.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma type_tyenv_weaken_append
 :  forall ke te se sp te' x t1 e1
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (te >< te') se sp (liftXX (length te') 0 x) t1 e1.
Proof.
 intros.
 induction te'; simpl.
  - burn.

  - rrwrite (S (length te') = length te' + 1).
    rrwrite (length te' + 1 = 1 + length te').
    rewrite <- liftXX_plus.
    eapply type_tyenv_weaken1.
    burn.
Qed.


Require Import List util list_util Program Relations.
Require EquivDec.

Set Implicit Arguments.

Record DiGraph: Type := Build
  { Vertex: Type
  ; Vertex_eq_dec: EquivDec.EqDec Vertex eq
  ; vertices: ExhaustiveList Vertex
  ; edges: Vertex -> list Vertex
  ; edges_NoDup: forall v, NoDup (edges v)
  }.

Existing Instance Vertex_eq_dec.
Existing Instance vertices.

Hint Resolve edges_NoDup.
Hint Immediate edges_NoDup.

Implicit Arguments edges [d].

Definition flat_edge_list (g: DiGraph): list (Vertex g * Vertex g) :=
  flat_map (fun v => map (pair v) (edges v)) (vertices g).

Section reachability.

  Variable g: DiGraph.

  Definition edge: relation (Vertex g) := fun v w => In w (edges v).
  Let ved := Vertex_eq_dec g.

  Definition Edge := (Vertex g * Vertex g)%type.
  Definition Edge_eq_dec: forall (e e': Edge), decision (e=e')
    := pair_eq_dec ved ved.

  Variable start: list (Vertex g).
  Hypothesis NoDup_start: NoDup start.

  Definition reachable v: Prop := exists s, In s start /\ trans_refl_closure.R edge s v.

  Program Fixpoint unreachables_worker (unvisited: list (Vertex g))
    (tovisit: { l | NoDup l /\ incl l unvisited
      /\ (forall v, ~ In v unvisited -> forall w, In w unvisited -> edge v w -> In w l)
      /\ (forall v, ~ In v unvisited -> reachable v)
      /\ (forall v, In v l -> reachable v)}) {measure (length unvisited)}:
    { l | incl l (subtr ved unvisited tovisit)
      /\ (forall v, ~ In v l -> forall w, edge v w -> ~ In w l)
      /\ (forall v, ~ In v l -> reachable v) } :=
    match tovisit with
    | nil => unvisited
    | h :: t => @unreachables_worker (remove ved h unvisited)
      (t ++ intersection ved unvisited (subtr ved (edges h) (h :: t))) _
    end.

  Next Obligation. Proof with auto.
    (* the result in the nil case meets the result spec *)
    split. apply incl_refl.
    split...
    repeat intro.
    destruct (i0 v H w H1 H0).
  Qed.

  Next Obligation. Proof with simpl; auto.
    (* the invariant is maintained in the recursive call *)
    clear unreachables_worker.
    inversion_clear n.
    repeat split; intros.
            (* we don't introduce duplicates *)
            apply NoDup_app...
            repeat intro.
            destruct (intersection_In ved x _ _ H2).
            destruct (snd (In_remove ved (subtr ved (edges h) t) x h) H4).
            destruct (In_subtr _ _ _ _ H5)...
          (* the new tovisit is still included in the new unvisited *)
          apply incl_app.
            repeat intro.
            apply (fst (In_remove ved unvisited a h)).
            split... intro. subst...
          repeat intro.
          destruct (intersection_In ved a _ _ H1).
          apply (fst (In_remove ved unvisited a h)).
          split...
          destruct (In_remove ved (subtr ved (edges h) t) a h).
          firstorder.
        (* the new tovisit is still the border between visiteds and unvisiteds *)
        destruct (snd (In_remove ved _ _ _) H2).
        rewrite remove_eq_filter in H1.
        destruct (not_In_filter' ved _ _ unvisited H1).
          destruct (i0 v H6 w H4 H3)...
          firstorder.
        destruct (ved h v); [idtac | discriminate].
        unfold Equivalence.equiv in e. subst v.
        destruct (In_dec ved w t)...
        apply in_or_app...
      (* things not in the new unvisited are still reachable *)
      rewrite remove_eq_filter in H1.
      destruct (not_In_filter' ved v _ unvisited H1)...
      destruct (ved h v); [idtac | discriminate].
      firstorder.
    (* things in the new tovisit are still reachable *)
    destruct (in_app_or _ _ _ H1). apply r0...
    destruct (intersection_In _ _ _ _ H2).
    destruct (snd (In_remove ved (subtr ved (edges h) t) v h) H4).
    destruct (r0 h (in_eq _ _)). destruct H7.
    exists x. split...
    apply trans_refl_closure.step with h...
    unfold edge.
    destruct (In_subtr _ _ _ _ H5)...
  Qed.

  Next Obligation. Proof with simpl; auto.
    (* the length decreases in the recursive call *)
    apply remove_length_lt, i...
  Qed.

  Next Obligation. Proof with auto.
    (* the result in the recursive case meets the result spec *)
    destruct_call unreachables_worker.
    simpl proj1_sig in *.
    clear unreachables_worker.
    destruct a. destruct H0.
    split...
    (*subst tovisit.*)
    simpl.
    repeat intro.
    specialize (H a H2).
    destruct (In_subtr _ _ _ _ H).
    clear H.
    destruct (snd (In_remove ved unvisited a h) H3).
    apply (In_remove ved (subtr ved unvisited t) a h)...
    split... apply subtr_In...
  Qed.

  Program Definition unreachables:
    { l: list (Vertex g) | forall w, ~ In w l <-> reachable w }
     := @unreachables_worker (vertices g) start.

  Next Obligation. Proof with auto.
    (* the invariant holds at the start *)
    split...
    split. repeat intro...
    split. intros. elimtype False...
    split. intros. elimtype False...
    intros. exists v. split...
  Qed.

  Obligation Tactic := idtac.

  Next Obligation. Proof with auto.
    (* worker's result implies our desired result *)
    destruct (unreachables_worker (exist (fun l => NoDup l /\ incl l (vertices g) /\
       (forall v, ~ In v (vertices g) -> forall w0, In w0 (vertices g) -> edge v w0 -> In w0 l) /\
       (forall v, ~ In v (vertices g) -> reachable v) /\
       (forall v, In v l -> reachable v)) start unreachables_obligation_1)).
    simpl in *.
    destruct a. destruct H0.
    intro. split... repeat intro.
    destruct H2. destruct H2.
    destruct (trans_refl_closure.flip_inv (fun j => In j x) (fun j => In_dec ved j x) H4)...
      intro.
      apply (snd (In_subtr ved (vertices g) start _ (H _ H5)) H2).
    destruct H5. destruct H5. destruct H6.
    apply (H0 _ H5 _ H7)...
  Qed.

  Obligation Tactic := program_simpl.

  (* let's do it again, this time using James' method *)

  Inductive result_rel:
    forall (unvisited tovisit result: list (Vertex g)), Prop :=
      | result_nil unvisited: result_rel unvisited nil unvisited
      | result_cons unvisited h t r:
         result_rel (remove ved h unvisited)
         (t ++ intersection ved unvisited (subtr ved (edges h) (h :: t))) r ->
         result_rel unvisited (h :: t) r.

  Hint Constructors result_rel.

  Hint Unfold reachable.

  Lemma half_correct (unvisited tovisit r: list (Vertex g)):
    result_rel unvisited tovisit r ->
     (forall v, ~ In v unvisited -> reachable v)
     -> (forall v, In v tovisit -> reachable v)
     -> (forall v, ~ In v r -> reachable v).
      (* todo: is this soundness or completeness? i can't tell because
       of this complement stuff.. *)
  Proof with simpl; auto.
    intros P.
    induction P...
    repeat intro.
    apply IHP; intros...
      (* things not in the new unvisited are still reachable *)
      rewrite remove_eq_filter in H2.
      destruct (not_In_filter' ved _ _ unvisited H2)...
      destruct (ved h v0); [idtac | discriminate].
      clear H3. subst...
    (* things in the new tovisit are still reachable *)
    destruct (in_app_or _ _ _ H2). apply H0...
    destruct (intersection_In _ _ _ _ H3). clear H3.
    destruct (snd (In_remove ved (subtr ved (edges h) t) v0 h) H5).
    destruct (H0 h (in_eq _ _)). destruct H7.
    destruct (In_subtr _ _ _ _ H5).
    eauto.
  Qed.

  Lemma other_half (unvisited tovisit r: list (Vertex g)):
    result_rel unvisited tovisit r ->
    (forall v, ~ In v unvisited -> forall w,
      In w unvisited -> edge v w -> In w tovisit) ->
      (forall v, ~ In v r -> forall w, edge v w -> ~ In w r)
      /\ incl r (subtr ved unvisited tovisit).
  Proof with simpl; auto.
    intros P.
    induction P; intros.
      split.
        repeat intro.
        destruct (H _ H0 _ H2 H1).
      unfold incl...
    destruct IHP.
      intros.
      (* the new tovisit is still the border between visiteds and unvisiteds *)
      destruct (snd (In_remove ved _ _ _) H1).
      rewrite remove_eq_filter in H0.
      destruct (not_In_filter' ved _ _ unvisited H0).
        destruct (H _ H5 _ H3 H2)...
        firstorder.
      destruct (ved h v); [idtac | discriminate].
      clear H5. unfold Equivalence.equiv in e. subst v.
      destruct (In_dec ved w t)...
      apply in_or_app...
    split...
    repeat intro.
    destruct (In_subtr _ _ _ _ (H1 _ H2)).
    simpl.
    apply (fst (In_remove ved (subtr ved unvisited t) a h)).
    destruct (snd (In_remove ved unvisited a h) H3).
    split...
    apply subtr_In...
  Qed.
(*
  Program Fixpoint result_rel_exists (unvisited: list (Vertex g))
    (tovisit: { l | NoDup l /\ incl l unvisited })
     {measure (length unvisited)}:
       { r | result_rel unvisited tovisit r } :=
    match tovisit with
    | nil => unvisited
    | h :: t => result_rel_exists (remove ved h unvisited)
      (t ++ intersection ved unvisited (subtr ved (edges h) (h :: t)))
    end.

  Next Obligation. (* length decrease *)
    intros.
    apply remove_length_lt. destruct H.
    apply H0. auto.
  Qed.

  Next Obligation. Proof with auto. (* NoDup/incl for recursive call. *)
    destruct H. inversion_clear H.
    split.
      (* we don't introduce duplicates *)
      apply NoDup_app...
      repeat intro.
      destruct (intersection_In ved x _ _ H3).
      destruct (snd (In_remove ved (subtr ved (edges h) t) x h) H5).
      destruct (In_subtr _ _ _ _ H6)...
    (* the new tovisit is still included in the new unvisited *)
    apply incl_app.
      repeat intro.
      apply (fst (In_remove ved unvisited a h)).
      split... intro. subst...
    repeat intro.
    destruct (intersection_In ved a _ _ H).
    apply (fst (In_remove ved unvisited a h)).
    split...
    destruct (In_remove ved (subtr ved (edges h) t) a h).
    firstorder.
  Qed.

  Next Obligation. Proof with auto. (* recursive result meets the spec *)
    (* ugly trivial thing, really just a silly Program artifact. *)
    destruct (result_rel_exists
       (exist
          (fun unvisited' : list (Vertex g) =>
           length unvisited' < length unvisited) (remove ved h unvisited)
          (result_rel_exists_obligation_2 result_rel_exists
             (exist (fun l : list (Vertex g) => NoDup l /\ incl l unvisited)
                tovisit H) Heq_tovisit))
       (exist
          (fun l : list (Vertex g) =>
           NoDup l /\ incl l (remove ved h unvisited))
          (t ++
           intersection ved unvisited (remove ved h (subtr ved (edges h) t)))
          (result_rel_exists_obligation_3 result_rel_exists
             (exist (fun l : list (Vertex g) => NoDup l /\ incl l unvisited)
                tovisit H) Heq_tovisit))).
     simpl in *. subst...
  Qed.

  Program Definition unreachables':
    { l: list (Vertex g) | forall w, ~ In w l <-> reachable w }
    := @result_rel_exists (vertices g) start.

  Next Obligation. Proof with auto. split... repeat intro... Qed.

  Next Obligation. Proof with auto.
    destruct (result_rel_exists
       (exist (fun l : list (Vertex g) => NoDup l /\ incl l (vertices g))
          start unreachables'_obligation_1)).
    simpl in *.
    split.
      apply (half_correct r); intros...
        elimtype False...
      exists v. split...
    destruct (other_half r).
      intros. elimtype False...
    repeat intro.
    destruct H1. destruct H1.
    destruct (trans_refl_closure.flip_inv (fun j => In j x) (fun j => In_dec ved j x) H3)...
      intro.
      apply (snd (In_subtr ved (vertices g) start _ (H0 x0 H4)) H1).
    destruct H4. destruct H4. destruct H5.
    apply (H _ H4 _ H6)...
  Qed.

  (* This concludes James' approach. *)
*)

  Program Definition reachables:
    { l: list (Vertex g) | forall w, In w l <-> reachable w }
    := subtr ved (vertices g) unreachables.

  Obligation Tactic := idtac.

  Next Obligation. Proof with auto.
    destruct unreachables.
    intros.
    split; intro.
      destruct (In_subtr _ _ _ _ H).
      simpl in H1.
      apply (i w)...
    apply subtr_In...
    apply (i w)...
  Qed.

  Definition reachable_dec (v: Vertex g): decision (reachable v) :=
    let (x, i) := unreachables in
      match In_dec ved v x with
      | left i0 => right (fun H => snd (i v) H i0)
      | right n => left (fst (i v) n)
      end.

End reachability.

Implicit Arguments reachable [[g]].