Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Psatz.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import vars.
Require Import env.
Require Import tactics.
Require Import NatSets.
Require Import setfacts.

Import NatSet.F.

(* Type qualifiers. *)

Inductive qual : Type :=
| qbot (* untracked *)
| qset : nats(* free variables *) -> nats(* bound variables *) -> nats(* store locations *) -> qual
.

Definition just_fv (x : id) : qual := qset (singleton x) {}N {}N.
Definition just_bv (x : id) : qual := qset {}N (singleton x) {}N.
Definition just_loc (l : loc) : qual := qset {}N {}N (singleton l).

Definition qfvs (q: qual) : nats :=
  match q with
  | qbot => {}N
  | qset fvs _ _ => fvs
  end.

Definition qbvs (q: qual) : nats :=
  match q with
  | qbot => {}N
  | qset _ bvs _ => bvs
  end.

Definition qlocs (q: qual) : nats :=
  match q with
  | qbot => {}N
  | qset _ _ ls => ls
  end.

Definition qmemb (v : var + loc) (d : qual) : bool  :=
  match d with
  | qbot => false
  | qset vs bs ls => match v with
                    | inl (varF v) => mem v vs
                    | inl (varB v) => mem v bs
                    | inr l        => mem l ls
                    end
  end.

Definition qmem (v : var + loc) (d : qual) : Prop :=
  match d with
  | qbot => False
  | qset vs bs ls => match v with
                    | inl (varF v) => In v vs
                    | inl (varB v) => In v bs
                    | inr l        => In l ls
                    end
  end.

Definition subqual (d1 d2 : qual) : Prop :=
  match d1 , d2 with
  | qbot, _ => True
  | _, qbot => False
  | qset fs1 bs1 ls1 , qset fs2 bs2 ls2 => (Subset fs1 fs2) /\ (Subset bs1 bs2) /\ (Subset ls1 ls2)
  end.

Definition subqualb (d1 d2 : qual) : bool :=
  match d1, d2 with
  | qbot, _ => true
  | _, qbot => false
  | qset vs1 bs1 ls1, qset vs2 bs2 ls2 =>
    fold_right andb true [(subset vs1 vs2); (subset bs1 bs2); (subset ls1 ls2)]
  end.

Definition eqqual (d1 d2 : qual) : Prop :=
  match d1 , d2 with
  | qbot, qbot => True
  | qset fs1 bs1 ls1 , qset fs2 bs2 ls2 => (Equal fs1 fs2) /\ (Equal bs1 bs2) /\ (Equal ls1 ls2)
  | _, _ => False
  end.

Definition eqqualb (d1 d2 : qual): bool :=
  match d1 , d2 with
  | qbot, qbot => true
  | qset fs1 bs1 ls1 , qset fs2 bs2 ls2 => (equal fs1 fs2) && (equal bs1 bs2) && (equal ls1 ls2)
  | _, _ => false
  end.

(* Semilattice ops on qualifiers *)
Definition qlub (d1 d2 : qual) : qual :=
  match d1, d2 with
  | qbot, d2 => d2
  | d1, qbot => d1
  | qset vs1 bs1 ls1, qset vs2 bs2 ls2 => qset (union vs1 vs2) (union bs1 bs2) (union ls1 ls2)
  end.

Definition qglb (d1 d2 : qual) : qual :=
  match d1, d2 with
  | qbot, _ => qbot
  | _, qbot => qbot
  | qset vs1 bs1 ls1, qset vs2 bs2 ls2 => qset (inter vs1 vs2) (inter bs1 bs2) (inter ls1 ls2)
  end.

Definition qplus (d : qual) (x : id) : qual :=
  match d with
  | qbot => qbot
  | q => qlub d (just_fv x)
  end.

(* The cancelling union generalized to qualifiers as second arg *)
Definition qqplus (q1 q2 : qual) : qual :=
  match q1 with
  | qbot => qbot
  | q    => qlub q1 q2
  end.

(* The intersection as used by T-App *)
Definition qqcap (q1 q2 : qual) : qual :=
  match (q1, q2) with
  | (qbot, qbot) => qbot
  | (qbot, _) => (qset {}N {}N {}N)
  | (_, qbot) => (qset {}N {}N {}N)
  | (_, _) => qglb q1 q2
  end.

Definition ldom {A} (Σ : list A) := qset {}N {}N (dom Σ).
#[global] Hint Unfold ldom : core.

Module QualNotations.
  Declare Scope qualifiers.

  Notation "⊥" := qbot (at level 9) : qualifiers.
  Notation "∅" := (qset {}N {}N {}N) (at level 9) : qualifiers.

  Notation "l ∈ₗ d"  := (qmem (inr l) d) (at level 75) : qualifiers.
  Notation "v ∈ᵥ d"  := (qmem (inl v) d) (at level 75) : qualifiers.
  Notation "l ∈?ₗ d" := (qmemb (inr l) d) (at level 75) : qualifiers.
  Notation "v ∈?ᵥ d" := (qmemb (inl v) d) (at level 75) : qualifiers.

  Notation "$$ x " := (just_fv x) (at level 0, right associativity) : qualifiers.
  Notation "## x " := (just_bv x) (at level 0, right associativity) : qualifiers.
  Notation "&& l " := (just_loc l) (at level 0, right associativity) : qualifiers.

  Notation "d1 ⊑ d2" := (subqual d1 d2) (at level 75) : qualifiers.
  Notation "d1 ⊑? d2" := (subqualb d1 d2) (at level 75) : qualifiers.

  Notation "d1 ≡ d2" := (eqqual d1 d2) (at level 75) : qualifiers.
  Notation "d1 ≡? d2" := (eqqualb d1 d2) (at level 75) : qualifiers.

  Notation "d1 ⊔ d2" := (qlub d1 d2) (at level 70, right associativity) : qualifiers.
  Notation "d1 ⊓ d2" := (qglb d1 d2) (at level 65, right associativity) : qualifiers.

  Notation "d1 ⊕ x" := (qplus d1 x) (at level 70) : qualifiers.

  Notation "q1 ⋓ q2" := (qqplus q1 q2) (at level 70, right associativity) : qualifiers.
  Notation "q1 ⋒ q2" := (qqcap q1 q2) (at level 65, right associativity) : qualifiers.

End QualNotations.
Import QualNotations.
Local Open Scope qualifiers.

Require Import Coq.Bool.Bool.

Lemma qmem_reflect : forall {v d}, reflect (qmem v d) (qmemb v d).
  intros. destruct d.
  - simpl. constructor. intuition.
  - simpl. destruct v. destruct v.
    destruct (mem i t0) eqn:Hmem; try constructor; intuition.
    rewrite <- NatSetFacts.not_mem_iff in Hmem. auto.
    destruct (mem i t1) eqn:Hmem; try constructor; intuition.
    rewrite <- NatSetFacts.not_mem_iff in Hmem. auto.
    destruct (mem l t2) eqn:Hmem; try constructor; intuition.
    rewrite <- NatSetFacts.not_mem_iff in Hmem. auto.
Qed.

Lemma qmem_decidable : forall v d, {qmem v d} + {~ qmem v d}.
  intros. eapply reflect_dec. apply qmem_reflect.
Qed.

Lemma subqual_reflect : forall {d1 d2}, reflect (subqual d1 d2) (subqualb d1 d2).
Proof.
  intros.
  destruct (d1 ⊑? d2) eqn:Hsub; try constructor;
    destruct d1; destruct d2; simpl in *; intuition;
    repeat rewrite andb_true_iff in Hsub; intuition.
  repeat rewrite andb_false_iff in Hsub. intuition.
  apply subset_1 in H0. rewrite H0 in H1. discriminate.
  apply subset_1 in H. rewrite H in H3. discriminate.
  apply subset_1 in H2. rewrite H2 in H1. discriminate.
Qed.

Lemma subqual_decidable : forall d1 d2, {d1 ⊑ d2} + {~ d1 ⊑ d2}.
  intros. eapply reflect_dec. apply subqual_reflect.
Qed.

Lemma subqualb_true_iff : forall {d1 d2}, (d1 ⊑? d2) = true <-> d1 ⊑ d2.
  intuition. erewrite reflect_iff. eauto. apply subqual_reflect.
  erewrite <- reflect_iff; eauto. apply subqual_reflect.
Qed.

Lemma subqualb_false_iff : forall {d1 d2}, (d1 ⊑? d2) = false <-> ~ d1 ⊑ d2.
  intuition. rewrite <- subqualb_true_iff in H0. rewrite H in H0.
  discriminate. destruct (d1 ⊑? d2) eqn:Heq.
  rewrite subqualb_true_iff in Heq. contradiction.
  auto.
Qed.

Lemma eqqual_reflect : forall {d1 d2}, reflect (eqqual d1 d2) (eqqualb d1 d2).
Proof.
  intros. destruct d1; destruct d2; simpl; intuition.
  apply iff_reflect. split; intros; intuition.
  apply equal_1 in H0. apply equal_1 in H. apply equal_1 in H2. intuition.
  1-3: repeat rewrite andb_true_iff in H; intuition; fnsetdec.
Qed.

Lemma eqqual_decidable : forall d1 d2, {d1 ≡ d2} + {~ d1 ≡ d2}.
  intros. eapply reflect_dec. apply eqqual_reflect.
Qed.

(* Lifts the extensional equality of the underlying set impl to qualifiers *)
Lemma eq_if_eqqual : forall {d1 d2}, d1 ≡ d2 -> d1 = d2.
  intros. destruct d1; destruct d2; auto; inversion H. unfold eqqual in H. intuition.
  f_equal; apply NatSet.eq_if_Equal; auto.
Qed.

Lemma subqual_refl : forall {d1}, d1 ⊑ d1.
  intros. unfold subqual.
  destruct d1; intuition.
Qed.
#[global] Hint Resolve subqual_refl : core.

Lemma subqual_trans : forall {d1 d2 d3}, d1 ⊑ d2 -> d2 ⊑ d3 -> d1 ⊑ d3.
  intros. unfold subqual in *. destruct d1; auto.
  destruct d2; auto; intuition. destruct d3; auto. fnsetdec.
Qed.

Lemma subqual_antisymm : forall {d1 d2}, d1 ⊑ d2 -> d2 ⊑ d1 -> d1 ≡ d2.
  intros. unfold eqqual in *. unfold subqual in *.
  destruct d1; auto. destruct d2; auto. intuition.
Qed.

Lemma eqqual_refl : forall {d}, d ≡ d.
  intros. unfold eqqual. destruct d; auto. intuition.
Qed.
#[global] Hint Resolve eqqual_refl : core.

Lemma eqqual_sym : forall {d1 d2}, d1 ≡ d2 -> d2 ≡ d1.
  unfold eqqual. destruct d1; auto. destruct d2; auto. intuition.
Qed.

Lemma eqqual_trans : forall {d1 d2 d3}, d1 ≡ d2 -> d2 ≡ d3 -> d1 ≡ d3.
  unfold eqqual. destruct d1; auto; destruct d2; auto; destruct d3; auto;
                   intros; intuition; fnsetdec.
Qed.

Ltac qdec :=
  try apply eq_if_eqqual;
  try unfold qglb in *;
  try unfold qlub in *;
  try unfold eqqual in *;
  try unfold subqual in *;
  simpl;
  intuition;
  try apply NatSet.eq_if_Equal; NatSetDecide.fsetdec.

Lemma subqual_plus : forall {d1 d2}, d1 ⊑ d2 -> forall {x}, d1 ⊕ x ⊑ d2 ⊕ x.
  intros. destruct d1; auto; destruct d2; auto; simpl in *; intuition; fnsetdec.
Qed.

Lemma qplus_empty : forall {x}, ∅ ⊕ x = (just_fv x).
  intros. compute. repeat rewrite empty_union_left. auto.
Qed.

Lemma qmem_lub_or_commute: forall {vl d1 d2}, qmem vl (d1 ⊔ d2) <-> qmem vl d1 \/ qmem vl d2.
  destruct d1; auto; destruct d2; auto; simpl; intuition; destruct a; fnsetdec.
Qed.

Lemma qmem_glb_and_commute: forall {vl d1 d2}, qmem vl (d1 ⊓ d2) <-> qmem vl d1 /\ qmem vl d2.
  destruct d1; auto; destruct d2; auto; simpl; intuition; try fnsetdec; destruct a; fnsetdec.
Qed.

Lemma qlub_is_lub : forall {d1 d2},
    d1 ⊑ (d1 ⊔ d2) /\
    d2 ⊑ (d1 ⊔ d2) /\
    forall {d3}, d1 ⊑ d3 /\ d2 ⊑ d3 -> (d1 ⊔ d2) ⊑ d3.
  destruct d1; auto; destruct d2; auto; intuition; unfold subqual; auto;
    simpl; unfold qlub; intuition.
  destruct d3; intuition; unfold subqual in *; try fnsetdec.
Qed.

Lemma qglb_is_glb : forall {d1 d2},
    (d1 ⊓ d2) ⊑ d1 /\
    (d1 ⊓ d2) ⊑ d2 /\
      forall {d3}, d3 ⊑ d1 /\ d3 ⊑ d2 -> d3 ⊑ (d1 ⊓ d2).
  destruct d1; auto; destruct d2; auto; simpl; intuition.
  destruct d3; auto. unfold subqual.
  destruct H0. destruct H1. intuition; try fnsetdec.
Qed.

Lemma qlub_empty_right : forall {d}, d <> qbot -> (d ⊔ ∅) = d.
  intros. destruct d; qdec.
Qed.
#[global] Hint Resolve qlub_empty_right : core.

Lemma qglb_empty_right : forall {d}, d <> qbot -> (d ⊓ ∅) = ∅.
  intros. destruct d; qdec.
Qed.
#[global] Hint Resolve qglb_empty_right : core.

Lemma qglb_empty_left : forall {d}, d <> qbot -> (∅ ⊓ d) = ∅.
  intros. destruct d; qdec.
Qed.
#[global] Hint Resolve qglb_empty_left : core.

Lemma qlub_idem : forall {q}, (q ⊔ q) = q.
 intros. destruct q; qdec.
Qed.

Lemma qlub_assoc : forall {q1 q2 q3},
    (q1 ⊔ (q2 ⊔ q3)) = ((q1 ⊔ q2) ⊔ q3).
Proof.
  intros. destruct q1, q2, q3; simpl; qdec.
Qed.

Lemma qglb_qlub_dist : forall {d1 d2 d3}, (d1 ⊓ (d2 ⊔ d3)) = ((d1 ⊓ d2) ⊔ (d1 ⊓ d3)).
  destruct d1; destruct d2; destruct d3; qdec.
Qed.

Lemma qglb_commute : forall {d1 d2}, d1 ⊓ d2 = d2 ⊓ d1.
  intros. destruct d1; destruct d2; qdec.
Qed.

Lemma qlub_commute : forall {d1 d2}, (d1 ⊔ d2) = (d2 ⊔ d1).
  intros. destruct d1; destruct d2; qdec.
Qed.

Lemma qlub_empty_left : forall {d}, d <> qbot -> (∅ ⊔ d) = d.
  intros. rewrite qlub_commute. auto.
Qed.
#[global] Hint Resolve qlub_empty_left : core.

Lemma qqcap_commute:  forall {d1 d2}, d1 ⋒ d2 = d2 ⋒ d1.
Proof.
  intros. destruct d1, d2; qdec.
Qed.

Lemma qqplus_qbot_right_neutral : forall {d}, (d ⋓ qbot) = d.
  destruct d; simpl; intros; intuition.
Qed.
#[global] Hint Resolve qqplus_qbot_right_neutral : core.

Lemma qqplus_gt : forall {q1 q2}, q1 ⊑ (q1 ⋓ q2).
  destruct q1; destruct q2; simpl; intuition.
Qed.
#[global] Hint Resolve qqplus_gt : core.

Lemma subqual_qlub : forall {d1 d2 d}, d1 ⊑ d2 -> d1 ⊔ d ⊑ d2 ⊔ d.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma subqual_qglb : forall {d1 d2 d}, d1 ⊑ d2 -> d ⊓ d1 ⊑ d ⊓ d2.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma subqual_qglb_r : forall {d1 d2 d}, d1 ⊑ d2 -> d1 ⊓ d ⊑ d2 ⊓ d.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma subqual_qqplus : forall {d1 d2 d}, d1 ⊑ d2 -> d1 ⋓ d ⊑ d2 ⋓ d.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma subqual_qlub_l : forall {d1 d2 d}, d1 ⊑ d2 -> d ⊔ d1 ⊑ d ⊔ d2.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma subqual_qqplus_l : forall {d1 d2 d}, d1 ⊑ d2 -> d ⋓ d1 ⊑ d ⋓ d2.
  destruct d1; destruct d2; destruct d; qdec.
Qed.

Lemma qbot_smallest : forall {d}, qbot ⊑ d.
  intros. destruct d; simpl; qdec.
Qed.
#[global] Hint Resolve qbot_smallest : core.

Lemma empty_smallest_set : forall {d}, d <> qbot -> ∅ ⊑ d.
  intros. destruct d; simpl; qdec.
Qed.
#[global] Hint Resolve empty_smallest_set : core.

Lemma empty_superqual : forall {df}, df <> qbot -> df ⊑ ∅ -> df = ∅.
  intros. destruct df. simpl in *. intuition. qdec.
Qed.

Lemma qlub_qglb_dist_r:
  forall {d1 d2 d3 : qual}, ((d2 ⊓ d3) ⊔ d1) = ((d2 ⊔ d1) ⊓ (d3 ⊔ d1)).
  destruct d1; destruct d2; destruct d3; qdec.
Qed.

Lemma qlub_qglb_dist_l:
  forall {d1 d2 d3 : qual}, ((d2 ⊓ d3) ⊔ d1) = ((d2 ⊔ d1) ⊓ (d3 ⊔ d1)).
  destruct d1; destruct d2; destruct d3; simpl; qdec.
Qed.

Lemma qglb_qlub_dist_r:
  forall {d1 d2 d3 : qual}, ((d2 ⊔ d3) ⊓ d1) = ((d2 ⊓ d1) ⊔ (d3 ⊓ d1)).
  destruct d1; destruct d2; destruct d3; simpl; qdec.
Qed.

Lemma qglb_qlub_dist_l:
  forall {d1 d2 d3 : qual}, (d1 ⊓ (d2 ⊔ d3)) = ((d1 ⊓ d2) ⊔ (d1 ⊓ d3)).
  destruct d1; destruct d2; destruct d3; simpl; qdec.
Qed.

Lemma empty_neutral_set : forall {a b c}, ((qset a b c) ⊔ ∅) = (qset a b c).
Proof. intros. simpl. repeat rewrite empty_union_right. auto. Qed.

Lemma empty_smallest_set' : forall {l1 l2 l3}, ∅ ⊑ qset l1 l2 l3.
Proof.
  intros. simpl. intuition.
Qed.

Lemma qlub_swallow_l : forall {q1 q2}, q1 ⊑ q2 -> (q1 ⊔ q2) = q2.
  intros. destruct q1; destruct q2; simpl; auto; qdec.
Qed.

Lemma qlub_swallow_r : forall {q1 q2}, q1 ⊑ q2 -> (q2 ⊔ q1) = q2.
  intros. destruct q1; destruct q2; simpl; auto; qdec.
Qed.

Lemma qqplus_swallow_r : forall {q1 q2}, q1 ⊑ q2 -> (q2 ⋓ q1) = q2.
  intros. destruct q1; destruct q2; simpl; auto; qdec.
Qed.

Lemma qlub_bound : forall {q1 q2 q3}, q1 ⊑ q3 -> q2 ⊑ q3 -> q1 ⊔ q2 ⊑ q3.
  intros. destruct q1; destruct q2; destruct q3; qdec.
Qed.

Lemma qqplus_bound : forall {q1 q2 q3}, q1 ⊑ q3 -> q2 ⊑ q3 -> q1 ⋓ q2 ⊑ q3.
  intros. destruct q1; destruct q2; destruct q3; qdec.
Qed.

Lemma qglb_bound : forall {q1 q2 q3}, q3 ⊑ q1 -> q3 ⊑ q2 -> q3 ⊑ q1 ⊓ q2.
  intros. destruct q1; destruct q2; destruct q3; qdec.
Qed.

Lemma qqcap_bound : forall {q1 q2 q3}, q3 ⊑ q1 -> q3 ⊑ q2 -> q3 ⊑ q1 ⋒ q2.
  intros. destruct q1; destruct q2; destruct q3; qdec.
Qed.

Lemma subqual_bound : forall {q1 q2},
    q1 ⊑ q2 ->
    (bound (qfvs q1)) <= (bound (qfvs q2))
    /\ (bound (qbvs q1)) <= (bound (qbvs q2))
    /\ (bound (qlocs q1)) <= (bound (qlocs q2)).
  intros. destruct q1; destruct q2; simpl in *; intuition; apply subset_bound'; fnsetdec.
Qed.

Lemma subqual_plus_var_bound : forall {q1 x q2},
    q1 <> qbot ->
    q1 ⊕ x ⊑ q2 -> x < bound (qfvs q2).
  intros q1 x q2 Hq1 H. apply subqual_bound in H. intuition.
  destruct q1; intuition.
  simpl in *. apply bound_union in H0. intuition.
  rewrite bound_singleton in H3. lia.
Qed.

Lemma subqual_just_loc_bound : forall {l q},
    just_loc l ⊑ q -> l < bound (qlocs q).
  intros. apply subqual_bound in H. intuition. simpl in *.
  rewrite bound_singleton in H2. lia.
Qed.

Lemma subqual_just_fv_bound : forall {x q},
    just_fv x ⊑ q -> x < bound (qfvs q).
  intros. apply subqual_bound in H. intuition. simpl in *.
  rewrite bound_singleton in H0. lia.
Qed.

Lemma subqual_qplus : forall {q x}, q ⊑ q ⊕ x.
  intros. destruct q; simpl; intuition; fnsetdec.
Qed.
#[global] Hint Resolve subqual_qplus : core.

Lemma qset_empty_inv : forall {a b c}, qset a b c = ∅ <->  a [=] {}N /\ b [=] {}N /\ c [=] {}N.
  intros. split. intros.
  inversion H. intuition.
  intros. intuition. f_equal; fnsetdec.
Qed.

Lemma qlub_qbot_left : forall {d}, (qbot ⊔ d) = d.
Proof. intros. destruct d; simpl; auto. Qed.

Lemma glb_qbot : forall {d}, d ⊓ qbot = qbot.
Proof. intros. destruct d; simpl; auto. Qed.

Lemma qqcap_lub_empty_preserve : forall {d1 d2}, d1 ⋒ d2 ⊑ ∅ -> d1 ⋒ (d2 ⊔ ∅) ⊑ ∅.
Proof.
  intros. destruct d1; destruct d2; simpl in *; intuition; fnsetdec.
Qed.

Lemma qlub_empty : forall {d}, d ⊑ d ⊔ ∅.
Proof.
  intros. destruct d; simpl; auto. intuition; fnsetdec.
Qed.

Lemma qqplus_empty_right_neutral : forall {d}, d <> qbot -> (d ⋓ ∅) = d.
  destruct d; simpl; intros; intuition.
  repeat rewrite empty_union_right. auto.
Qed.

Lemma qbot_is_bottom : forall q, q ⊑ qbot -> q = qbot.
Proof.
  intros. destruct q; auto. simpl in H. inversion H.
Qed.

Lemma qqcap_sub_l : forall {q1 q2}, q1 <> qbot -> q1 ⋒ q2 ⊑ q1.
  intros. destruct q1 eqn:Hq1; destruct q2 eqn:Hq2; simpl; intuition.
Qed.

Lemma qqcap_sub_r : forall {q1 q2}, q1 <> qbot -> q2 ⋒ q1 ⊑ q1.
  intros. destruct q1; destruct q2; simpl; intuition.
Qed.

Lemma qqcap_qbot : forall d1 d2, d1 ⋒ d2 ⊑ qbot -> d1 = qbot /\ d2 = qbot.
Proof.
  intros. destruct d1; destruct d2; simpl; intuition; inversion H.
Qed.

Lemma qqcap_qbot' : forall d1 d2, d1 ⋒ d2 = qbot -> d1 = qbot /\ d2 = qbot.
Proof.
  intros. destruct d1; destruct d2; simpl; intuition; inversion H.
Qed.

Lemma qqcap_lub_empty_preserve' : forall {d1 d2 d3},
    d1 ⋒ d2 ⊑ ∅ -> d3 ⋒ d1 = ∅ -> d1 ⋒ (d2 ⋓ d3) ⊑ ∅.
Proof.
  intros. destruct d1; destruct d2; destruct d3; simpl in *; intuition; cbv in H0;
  apply qset_empty_inv in H0; intuition; fnsetdec.
Qed.

Lemma subqual_qqcap' :  forall {a b c d'}, qset a b c ⋒ d' ⊑ qset a b c.
  destruct d'.
  - simpl. intuition.
  - specialize @qglb_is_glb with (d1:=(qset a b c)) (d2:=(qset t0 t1 t2)). intuition.
Qed.

Lemma qual_less_than_empty : forall q, q ⊑ ∅ <-> q = qbot \/ q = ∅.
Proof.
  intros. split.
  - destruct q; simpl in *. left. auto. right.
    intuition. apply subset_of_empty in H0, H, H2. subst. auto.
  - destruct q; simpl in *; intros; auto.
    destruct H. discriminate H. inversion H. intuition; fnsetdec.
Qed.

Lemma just_fv_mem_iff : forall {x y}, $x ∈ᵥ just_fv y <-> x = y.
  intros. simpl. rewrite NatSetFacts.singleton_iff. intuition.
Qed.

Lemma qglb_bot_right : forall {d}, (d ⊓ qbot) = qbot.
  intros. destruct d; qdec.
Qed.
#[global] Hint Resolve qglb_bot_right : core.

Lemma qglb_bot_left : forall {d}, (qbot ⊓ d) = qbot.
  intros. destruct d; qdec.
Qed.
#[global] Hint Resolve qglb_bot_left : core.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.

Implicit Arguments old.

Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Definition key  := Z.

Definition value  := Z.

Inductive color  :=
  | Red : color
  | Black : color .

Inductive tree  :=
  | Leaf : tree
  | Node : color -> tree -> Z -> Z -> tree -> tree .

Set Implicit Arguments.
Fixpoint memt(t:tree) (k:Z) (v:Z) {struct t}: Prop :=
  match t with
  | Leaf => False
  | (Node _ l kqt vqt r) => ((k = kqt) /\ (v = vqt)) \/ ((memt l k v) \/
      (memt r k v))
  end.
Unset Implicit Arguments.

Axiom memt_color : forall (l:tree) (r:tree) (k:Z) (kqt:Z) (v:Z) (vqt:Z)
  (c:color) (cqt:color), (memt (Node c l k v r) kqt vqt) -> (memt (Node cqt l
  k v r) kqt vqt).

Definition lt_tree(x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt t
  k v) -> (k <  x)%Z.

Definition gt_tree(x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt t
  k v) -> (x <  k)%Z.

Set Implicit Arguments.
Fixpoint bst(t:tree) {struct t}: Prop :=
  match t with
  | Leaf => True
  | (Node _ l k v r) => (bst l) /\ ((bst r) /\ ((lt_tree k l) /\ (gt_tree k
      r)))
  end.
Unset Implicit Arguments.

Axiom bst_Leaf : (bst Leaf).

Definition is_not_red(t:tree): Prop :=
  match t with
  | (Node Red _ _ _ _) => False
  | (Leaf|(Node Black _ _ _ _)) => True
  end.

Set Implicit Arguments.
Fixpoint rbtree(n:Z) (t:tree) {struct t}: Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ ((rbtree n r) /\ ((is_not_red l) /\
      (is_not_red r)))
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.
Unset Implicit Arguments.

Axiom rbtree_Leaf : (rbtree 0%Z Leaf).

Axiom rbtree_Node1 : forall (k:Z) (v:Z), (rbtree 0%Z (Node Red Leaf k v
  Leaf)).

Definition almost_rbtree(n:Z) (t:tree): Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ (rbtree n r)
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem WP_parameter_add : forall (t:tree), forall (k:Z), forall (v:Z),
  ((bst t) /\ exists n:Z, (rbtree n t)) -> (((bst t) /\ exists n:Z, (rbtree n
  t)) -> forall (result:tree), ((bst result) /\ ((forall (n:Z), (rbtree n
  t) ->
  (match result with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ (rbtree n r)
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end /\
  (match t with
  | (Node Red _ _ _ _) => False
  | (Leaf|(Node Black _ _ _ _)) => True
  end -> (rbtree n result)))) /\ ((memt result k v) /\ forall (kqt:Z)
  (vqt:Z), ((memt result kqt vqt) \/ (((kqt = k) -> (vqt = v)) /\
  ((~ (kqt = k)) -> (memt t kqt vqt)))) -> ((memt result kqt vqt) /\
  (((kqt = k) /\ (vqt = v)) \/ ((~ (kqt = k)) /\ (memt t kqt vqt))))))) ->
  match result with
  | (Node _ l kqt vqt r) => exists n:Z, (rbtree n (Node Black l kqt vqt r))
  | Leaf => True
  end).
(* YOU MAY EDIT THE PROOF BELOW *)
intuition.
destruct result; auto.
destruct H2 as (n, h). clear H3.
generalize (H0 n h); clear H0.
intros.
destruct c; intuition.
(* c = Red *)
exists (n+1)%Z; intuition.
simpl rbtree. replace (n+1-1)%Z with n by omega.
intuition.
(* c = Black *)
exists n; intuition.
simpl rbtree.
intuition.
Qed.
(* DO NOT EDIT BELOW *)


Require Import Commons.

Section Lists.

Context {X : eqType}.

Definition weak_cons (x : X) := bind (fun (xs : list X) => Some (x :: xs)).

Definition weak_app (xs : seq X) ys :=
match ys with
 | Some ys => Some (xs ++ ys)
 | None => None
end.

Notation "x :~: xs" := (weak_cons x xs) (at level 60, right associativity) : seq_scope.
Notation "x :++: xs" := (weak_app x xs) (at level 56, left associativity) : seq_scope.
Open Scope seq_scope.

Lemma cons_wcons (x : X) l : Some (x :: l) = x :~: Some l.
Proof. done. Qed.

Lemma wcons_none x o: x :~: o = None -> o = None.
Proof. by move: o => []. Qed.

Lemma wcons_some x o o1: x :~: o = Some o1 -> exists o2, o = Some o2 /\ o1 = x :: o2.
Proof. by move: o => [a [<-]|] //; eauto. Qed.

Lemma weak_app_0s: forall xs, [::] :++: xs = xs.
Proof. by move=> [xs|]. Qed.

(* Insert list operation and its properties *)
Fixpoint ins (i : nat) (es : seq X) (xs : seq X) :=
 match i with
   0 => Some (es ++ xs)
   | S i' =>
     match xs with
       | x' :: xs' => x' :~: ins i' es xs'
       | _ => None
     end
 end.

Definition oins (i : nat) (es : seq X) :=
  bind (ins i es).

Lemma oins_some n es xs: ins n es xs = oins n es (Some xs).
Proof. done. Qed.

Lemma ins_notnil: forall xs (i : nat) y (ys : seq X),
  ~ ins i (y :: ys) xs = Some (Nil _).
Proof. by move=> [|x xs] [|n] y ys //= /wcons_some; case => _ [] //. Qed.

Lemma ins_none' (es : seq X) k xs: ins (size xs + k.+1) es xs = None.
Proof. move: xs. by elim => [|x xs] //= ->. Qed.

Lemma ins_noneP k xs es: reflect (ins k es xs = None) (size xs < k).
elim: xs k => [|x xs IHx] [|k] /=; rewrite ?cats0; try by constructor.
case A0: (_ < k.+1); first by move: A0; rewrite ltnS => /IHx -> /=; constructor.
case A1: ins; first by constructor. move /IHx in A1.
by move: A0 A1; rewrite ltnS => ->. Qed.

(* Seems unnecessary, should we remove? *)
Lemma ins_some: forall xs es ys i,
  ins i es xs = Some ys -> size ys = size xs + size es /\ size xs >= i.
Proof. split. elim: xs es ys i H => [|x xs IHxs] es ys.
 + by case => [] //= [] <-; rewrite cats0 add0n.
 + case => [] /=.
   * by case => <-; rewrite size_cat /= addnC.
   * by move => n /wcons_some [] ? [] /IHxs A0 ->; rewrite /= A0.
 move: H. move/orP: (leq_total i (size xs)) => [] //; rewrite leq_eqVlt => /orP [].
 + by move /eqP -> => //.
 + by case: (ins_noneP i xs es) => // ->. Qed.

Lemma ins_id xs ys i:
 ins i [::] xs = Some ys -> xs = ys.
Proof.
by elim: i xs ys => [|i Hi] [|x xs] ys // [] //= /wcons_some [ys'] [] /Hi ->. Qed.

Lemma oins_Swcons (x : X) (es : seq X): forall xs i,
  oins (i.+1) es (x :~: xs) = x :~: oins i es xs.
Proof. by case => [] [] //=. Qed.

(* Remove list opertaion and its properties*)

Fixpoint rm
 i (es : seq X) (xs : seq X) :=
 match xs, es with
 | _, [::] => Some xs
 | [::], _ => None
 | x' :: xs', e' :: es' =>
   match i with
     | 0 => if x' == e' then rm 0 es' xs' else None
     | i'.+1 => x' :~: (rm i' es xs')
   end
 end.

Definition orm (index : nat) (elements : seq X) :=
 bind (rm index elements).

Lemma orm_some n es xs: rm n es xs = orm n es (Some xs).
Proof. done. Qed.

Lemma rm_id k xs: rm k [::] xs = Some xs.
Proof. by case: xs => [|x xs] /=. Qed.

Lemma rm_len i es xs rs:
  size es > 0 -> rm i es xs = Some rs -> exists k, size xs = i + (size es) + k /\ size rs = i + k.
Proof. elim: i es xs rs => [|i IHi] es xs rs H.
move {H}. elim: es xs rs => [|e es IHes] xs rs //=.
 + rewrite rm_id => [] [] ->. by exists (size rs).
 + case: xs => [|??] //=. case: eqP => // _ /IHes [k'] [].
   rewrite ?add0n => -> ->. by exists k'.
 + move: es H => [|??] //.
   case: xs => [|??] // /IHi => A /= /wcons_some [?] [] /A [k'] [] -> B -> /=.
   rewrite B ?addnS ?addSn. by exists k'.
Qed.

Corollary orm_id k xs : orm k [::] xs = xs.
Proof. by case : xs => [xs|] /=; rewrite ?rm_id. Qed.

Lemma orm_0wcons x es xs:
  orm 0 (x :: es) (x :~: xs) = orm 0 es xs.
Proof. by case: xs => //= => xs; rewrite eq_refl; case: xs => //=. Qed.

Lemma rm_0app: forall xs1 xs2 es,
  rm 0 (xs1 ++ es) (xs1 ++ xs2) = rm 0 es xs2.
Proof. by elim => [|x1 xs1 IHxs1] xs2 es //=; rewrite eq_refl IHxs1. Qed.

Lemma rm_Scons xs x k es:
  rm k.+1 es (x :: xs) = x :~: (rm k es xs).
Proof. case: es xs => [] //= [] //=. Qed.

Lemma orm_Swcons xs x k es:
  orm (k .+1) es (x :~: xs) = x :~: (orm k es xs).
Proof. elim: es xs => [|e es IHs] [[]|] //=.  Qed.

Lemma rm_addnapp xs ys k es:
  rm (k + size(ys)) es (ys ++ xs) = ys :++: (rm k es xs).
Proof. elim: ys xs es => [|y ys IHys] xs es //=.
  + by rewrite addn0 weak_app_0s.
  + move: es => [|e es] //=; first by rewrite ?rm_id.
    by rewrite addnS IHys; case: rm => [mr|]. Qed.

Lemma rm_none0 k xs e es: size xs <= k -> rm k (e :: es) xs = None.
Proof. by elim: xs k => [k //=|x xs IHl [|k] //= /IHl ->]. Qed.

Lemma rm_none1 {k xs es}: size es > 0 -> size xs < (size es) + k -> rm k es xs = None.
Proof. elim: xs k es => [|x xs IHxs] [|k] [|e es] // Heq /=; case: (x == e) => //;
rewrite ?addn0 ?addnS; try move=> /(IHxs _ _ Heq) -> // /(ltn_trans _ (ltnSn _)).
case Hes: (size es == 0); first by move/eqP: Hes ->. move /neq0_lt0n in Hes.
by rewrite -(addn0 (size es)) => /(IHxs _ _ Hes). Qed.

Lemma rm_eq (l1 l2 l3 : seq X): rm 0 l2 l1 = Some l3 -> l2 ++ l3 = l1.
elim: l2 l1 => [|a2 l2 IHl] [|a1 l1] //=; try by case => <-.
 + case A0: (a1 == a2) => // /IHl. by move: A0 => /eqP -> ->. Qed.

(* nth element operation and its properties *)
Fixpoint nth index xs : option X :=
 match xs, index with
   nil, _ => None
   | x :: xs, 0 => Some x
   | x :: xs, S i => nth i xs
 end.

Lemma nth_noneP i xs: reflect (nth i xs = None) (size xs <= i).
elim: xs i => [|x xs IHx] [|i] /=; try by constructor. apply IHx. Qed.

Lemma nth_nil_none (i : nat) (xs : seq X): nth i [::] = None.
Proof. move: (leq0n i). by rewrite -[0]/(size (@nil X)) => /nth_noneP. Qed.

Lemma nth_app_next xs1 xs2 k: nth (size xs1 + k) (xs1 ++ xs2) = nth k xs2.
Proof. elim: xs1 k xs2 => [|x1 xs1 IHxs1] k xs2 //=. Qed.

(* replace operation for lists and its properties *)

Fixpoint rplc (n : nat) (e : option X) (xs : seq X) :=
match n, xs with
 | 0, x :: xs' => bind (fun e' => Some (e' :: xs')) e
 | S n', x :: xs' => x :~: rplc n' e xs'
 | _, _ => None
end.

Definition orplc (index : nat) (e : option X) := bind (rplc index e).

Lemma orplc_some n e xs: rplc n e xs = orplc n e (Some xs).
Proof. done. Qed.

Lemma orplc_ind (x : X) l e i: orplc (S i) e (x :~: l)  = x :~: (orplc i e l).
Proof. by case l. Qed.

Lemma rplc_0 xs i (e : option X): rplc i e xs = Some [::] -> False.
Proof. by move: xs i e => [|??] [|?] [?|] //=; case: rplc. Qed.

Lemma rplc_0none i e: rplc i e [::] = None.
Proof. by case: i e => [|i] [e|]. Qed.

Lemma rplc_noneP1 (e : X) {k} {xs}: reflect (rplc k (Some e) xs = None) (size xs <= k).
elim: xs k => [|x xs IHx] [|k] /=; try by constructor. rewrite ltnS.
by case: (rplc k (Some e) xs) (IHx k) => [a|]; case leq => [] [] //; constructor. Qed.

Lemma rplc_none_none k xs: rplc k None xs = None.
Proof. by elim: xs k => [|x xs Hxs] [|k] //=; rewrite Hxs. Qed.

Lemma rplc_lenle k xs (e : option X): size xs <= k -> rplc k e xs = None.
case: e => [a /(rplc_noneP1 a) //|] ?. by rewrite rplc_none_none. Qed.

Lemma rplc_none_case k xs (e : option X): rplc k e xs = None <-> e = None \/ size xs <= k.
Proof. case: e => [a|]; rewrite ?rplc_none_none; split;
 try move=> []; try move /rplc_noneP1; try done; by [right| left]. Qed.

Lemma rplc_some k xs (e : option X) y: rplc k e xs = Some y
-> k < size xs /\ (exists e',  e = Some e').
Proof. case: e => [e'|]; last by rewrite rplc_none_none.
case Hsz: (k < size xs); last by move: Hsz => /negbT; rewrite -leqNgt =>
/(rplc_lenle _ _ (Some e')) ->. by split => //; exists e'. Qed.

Lemma rplc_Scons xs i (x : X) y: rplc (i.+1) y (x :: xs) = x :~: (rplc i y xs).
Proof. done. Qed.

Lemma orplc_0wcons xs (x : X) y: orplc 0 (Some y) (x :~: xs) = y :~: xs.
Proof. by case: xs. Qed.

Lemma rplc_addn_app xs1 xs2 k e:
  rplc (size xs1 + k) e (xs1 ++ xs2) = xs1 :++: rplc k e xs2.
Proof. case: e => [e|]; last by rewrite ?rplc_none_none.
 by elim: xs1 => [|x1 xs1 IHxs1]; rewrite ?cat0s ?add0n //= ?IHxs1 //=; case: rplc. Qed.

Lemma orplc_Swcons xs i (x : X) y: orplc (i.+1) y (x :~: xs) = x :~: (orplc i y xs).
Proof. case: xs; done. Qed.

Lemma rplc_some_len (xs ys : seq X) i e: rplc i e xs = Some ys -> size xs = size ys.
Proof. case: e => [e|]; rewrite ?rplc_none_none //;
 elim: i xs ys => [|i IHi] [|x xs] //= ys; first by move=> //= [] <-.
 by move /wcons_some => [xs'] [] /IHi -> ->. Qed.

Lemma orplc_none i l: orplc i None l = None.
elim: i l => [|n IHn] [[|a l]|] //=. by move: (IHn (Some l)) => /= ->. Qed.

(* replace and nth propertice *)
Lemma rplc_nth_id (xs ys: seq X) i: rplc i (nth i xs) xs = Some ys -> xs = ys.
Proof. elim: i xs ys => [|i Hi] [|x xs] ys //= []; first by move ->.
  by move /wcons_some => [xs'] [] /Hi -> ->. Qed.

Lemma rplc_nth_id' i xs y: nth i xs = Some y -> rplc i (nth i xs) xs = Some xs.
Proof. by elim: i y xs => [|i IHi] y [|x xs] //= /IHi ->. Qed.

(* cut operation and its properties *)
Fixpoint cut {X} (l : seq.seq X ) sc rc :=
match sc, rc, l with
 | S sc', _, x :: xs => x :: (cut xs sc' rc)
 | 0, S rc', x :: xs => (cut xs sc rc')
 | _, _, _ => l
end.

Lemma cut_id {xs : seq X} {n}: cut xs n 0 = xs.
Proof. by elim: xs n => [|x xs IHxs] [|n] //=; rewrite IHxs. Qed.

Lemma cut_empty_eq {Y : Type}: forall n k, cut (@nil Y) n k = @nil Y.
Proof. by move=> [|n] [|k]. Qed.

Lemma cut_nil {Y : Type}: forall xs, cut xs 0 (size xs) = @nil Y.
Proof. by elim. Qed.

(* insert/insert commutation *)
Lemma ins_insC': forall xs i k (e1s e2s : seq X), (i + k) <= size xs ->
oins (size e1s + (i + k)) e2s (ins i e1s xs) = oins i e1s (ins (i + k) e2s xs)
/\ exists os, oins i e1s (ins (i + k) e2s xs) = Some os.
Proof. move=> xs i. elim: i xs => [|i IHi] xs k e1s e2s. rewrite add0n /=.
 + elim: e1s => [|e1 e1s IHx] Hsz /=. rewrite add0n.
   case Hins: (ins k) => [a|] /=; split => //; first by exists a.
   by move: Hins Hsz => /ins_noneP; rewrite ltnNge; case leq.
 + move: (Hsz) => /IHx => [] [] IHx' IHx''.
   case Hins: (ins k) => [a|] /=; split => //; try by rewrite IHx' Hins /=.
   by exists (e1 :: e1s ++ a).
   by move: Hins Hsz => /ins_noneP; rewrite ltnNge; case leq.
 + case: xs => [|x xs] //=. rewrite addSn addnS => /IHi /= A.
   move: (A e1s e2s) => []. rewrite ?oins_Swcons => -> [os] ->.
   split => //=. by exists (x :: os).
Qed.

Theorem ins_insC: forall xs i k (e1s e2s : seq X), i <= k -> k <= size xs ->
oins (size e1s + k) e2s (ins i e1s xs) = oins i e1s (ins k e2s xs)
/\ exists os, oins i e1s (ins k e2s xs) = Some os.
Proof. move=> xs i k e1s e2s /le_ex [j] <-. exact: ins_insC'. Qed.

(* remove/remove commutation *)
Lemma rm_rmC': forall xs i k (e1s e2s : seq X) rrm1 rrm2,
rm ((size e2s) + i + k) e1s xs = Some rrm1 ->
rm i e2s xs = Some rrm2 ->
orm i e2s (rm ((size e2s) + i + k) e1s xs) = orm (i + k) e1s (rm i e2s xs)
/\ exists os, orm (i + k) e1s (rm i e2s xs) = Some os.
Proof. move=> xs i. elim: i xs => [|i IHi] xs k e1s e2s rrm1 rrm2.
 + rewrite add0n /=. elim: e2s xs e1s rrm1 rrm2 => [|e2 e2s IHe2s] [|x?] [|??] rrm1 rrm2; try by eauto.
   rewrite /= ?add0n. case: k => [|k]; rewrite orm_id => ->; by eauto.
   rewrite /= orm_id => _ ->; by eauto.
   simpl. case H: (x == e2) =>// /wcons_some [rrm1'] [] /IHe2s A _ /A [].
   move/eqP: H => ->. rewrite orm_0wcons => ->. by eauto.
 + rewrite addnS ?addSn //=.
   move: xs e1s => [|x xs] [|e1 e1s] //=; rewrite ?orm_id //=;
   try (move=> _ ->; by eauto).
   move=> /wcons_some [rrm1'] [] /IHi A _.
   case: e2s A => [|e2 e2s] A; [move: (rm_id i xs)| move=> /wcons_some [rrm2'] []];
   move=> /A; rewrite ?orm_id ?rm_id ?cons_wcons ?orm_Swcons => [] []-> [os] -> /=; by eauto.
Qed.

Theorem rm_rmC: forall xs i k (e1s e2s : seq X) rrm1 rrm2,
i <= k ->
rm ((size e2s) + k) e1s xs = Some rrm1 ->
rm i e2s xs = Some rrm2 ->
orm i e2s (rm ((size e2s) + k) e1s xs) = orm k e1s (rm i e2s xs)
/\ exists os, orm k e1s (rm i e2s xs) = Some os.
Proof. move=> xs i k e1s e2s rrm1 rrm2 /le_ex [j] <-. rewrite addnA.
move=> /rm_rmC' A /A []. by eauto.
Qed.

(* remove/insert commutation *)
Lemma rm_insC_bef': forall xs i k eis ers rins rrm,
oins ((size ers) + i + k) eis xs = Some rins ->
orm i ers xs = Some rrm ->
orm i ers (oins ((size ers) + i + k) eis xs) = oins (i+k) eis (orm i ers xs)
/\ exists os, oins (i+k) eis (orm i ers xs) = Some os.
Proof. case => [] // xs i. elim: i xs => [|i IHi] xs k eis ers. rewrite addn0 add0n /=.
 + elim: ers xs eis => [xs eis|er ers IHers [|x?] eis//=] rins rrm => /=.
   rewrite add0n orm_id rm_id; split => //. by exists rins; rewrite /= H.
   case H: (x == er).
  - move/eqP: H; move=> -> //= /wcons_some [rins'] [] /IHers A _ /A [].
    by rewrite orm_0wcons => ->.
  - by case: ins => [res|].
 + move=> rins rrm; rewrite addnS addSn //=.
   move: xs => [|x xs] //=. move: ers => [|er ers].
  - rewrite orm_id /= => ->. split => //. by exists  rins.
   rewrite addSn orm_Swcons oins_Swcons oins_some => /wcons_some [rins'] [] /IHi A _
   /wcons_some [rrm'] []. rewrite orm_some => /A [] -> [os] -> /=; split => //. by exists (x :: os). Qed.

Theorem rm_insC_bef xs i k eis ers rins rrm:
i <= k ->
oins ((size ers) + k) eis xs = Some rins ->
orm i ers xs = Some rrm ->
orm i ers (oins ((size ers) + k) eis xs) = oins k eis (orm i ers xs)
/\ exists os, oins k eis (orm i ers xs) = Some os.
Proof. move=> /le_ex [?] <-. by rewrite addnA => /rm_insC_bef' A /A. Qed.

Lemma rm_insC_aft': forall i xs k eis ers rins rrm,
ins i eis xs = Some rins -> rm (i + k) ers xs = Some rrm ->
 orm ((size eis) + (i + k)) ers (ins i eis xs) = oins i eis (rm (i + k) ers xs)
  /\ exists os, oins i eis (rm (i + k) ers xs) = Some os.
Proof.
by elim => [|i IHi] xs k eis ers rins rrm //=;
 [rewrite add0n /= {1}addnC rm_addnapp; case: rm => [mr|]|
  move: xs ers => [|??] [|??] //=;
  [case H: ins => [?|] //|
   rewrite ?addSn addnS orm_Swcons oins_Swcons =>
   /wcons_some [?] [] /IHi A ? /wcons_some [?] [] /A [] <- [?] ->]];
   split => //=; eauto. Qed.

Lemma rm_insC_aft xs i k eis ers rins rrm:
i <= k -> ins i eis xs = Some rins -> rm k ers xs = Some rrm ->
 orm ((size eis) + k) ers (ins i eis xs) = oins i eis (rm k ers xs)
  /\ exists os, oins i eis (rm k ers xs) = Some os.
Proof. by move=> /le_ex [?] <- /rm_insC_aft' A /A [] ->. Qed.

Lemma rm_insC_in': forall i k xs eis ers ers' xs',
ins k eis ers = Some ers' -> ins (i+k) eis xs = Some xs' ->
  rm i ers xs = rm i ers' xs'.
Proof. elim => [|i Hi].
 +  elim => [|k Hk] [|x?] eis [|er?] ?? //=;
  try (by move=> [] <- [] <-; rewrite rm_0app).
  * move => /wcons_some [?] [] => H1 -> /wcons_some [?] [] => H2 -> /=.
    case: (x == er) H1 H2 => //. by apply /Hk.
 + by move => ? [|??] ? [|??] ? ? //= H1 /wcons_some [?] [H2 ->];
   rewrite rm_Scons -(Hi _ _ _ _ _ _ H1 H2) // ?rm_id. Qed.

Theorem rm_insC_in i k xs eis ers ers' xs':
i <= k -> ins (k - i) eis ers = Some ers' ->
 ins k eis xs = Some xs' ->
  rm i ers xs = rm i ers' xs'.
Proof. move=> /le_ex [s] <-;
rewrite addnC -addnBA // subnn addn0 addnC => *.
by apply (rm_insC_in' _ s _ eis). Qed.

(* replace/replace commutation *)
Lemma rplc_rplcC_neq': forall l i k t1 t2,
orplc (S (i + k)) t2 (orplc i t1 l) = orplc i t1 (orplc ((S i + k)) t2 l).
Proof. case => //. elim => [|x xs IHx]; intros. by rewrite /orplc /= rplc_0none.
case: t1 t2 => [t1|] [t2|]; try by rewrite ?orplc_none.
case: i => [/=|i]; first by case: rplc => [].
by rewrite ?addSn ?orplc_ind IHx. Qed.

Theorem rplc_rplcC_neq: forall l i k t1 t2, i == k = false ->
orplc k t2 (orplc i t1 l) = orplc i t1 (orplc k t2 l).
Proof. intros. case Hik: (i < k).
 + by move: Hik => /le_ex [j] <-; rewrite addSn rplc_rplcC_neq'.
 + case Hik': (k < i).
  - by move: Hik' => /le_ex [j] <-; rewrite addSn rplc_rplcC_neq'.
  - by move: Hik => /negbT; rewrite -leqNgt; move: Hik' => /negbT; rewrite -leqNgt => A B;
    have H': (i <= k <= i); rewrite ?B ?A //; move: H'; rewrite -eqn_leq H.
Qed.

Lemma rplc_rplcC_eq: forall xs i e1 e2,
orplc i e2 (orplc i (Some e1) xs) = orplc i e2 xs.
Proof. case=> [xs|] // i; elim: i xs => [|i IHi] xs e1 e2; first by case: xs.
 by case: xs IHi => [|x xs] IHi //=; rewrite orplc_Swcons IHi.
Qed.

(* replace/insert commutation *)

Lemma rplc_insC_aft': forall xs i k e1 e2s, i + k < size xs ->
orplc (size e2s + (i + k)) (Some e1) (ins i e2s xs) = oins i e2s (rplc (i + k) (Some e1) xs)
/\ exists os, oins i e2s (rplc (i + k) (Some e1) xs) = Some os.
Proof. move=> xs i. elim: i xs => [|i IHi] xs k e1 e2s.
 + rewrite add0n /= rplc_addn_app; case Hrplc: rplc => [rplc_r|] /=;
   first by (split => //; by exists (e2s ++ rplc_r)). move: Hrplc => /rplc_noneP1. by rewrite ltnNge; case leq.
 + rewrite ?addSn ?addnS. case: xs => [|x xs] //=.
   rewrite ?orplc_Swcons oins_Swcons => /IHi A. move: (A e1 e2s) => [] <- [os] ->.
   split=> //. by exists (x :: os).
Qed.

Theorem rplc_insC_aft: forall xs i k e1 e2s, i <= k -> k < size xs ->
orplc (size e2s + k) (Some e1) (ins i e2s xs) = oins i e2s (rplc k (Some e1) xs)
/\ exists os, oins i e2s (rplc k (Some e1) xs) = Some os.
Proof. move=> ??? e1 e2s /le_ex [?] <- /rplc_insC_aft' A. move: (A e1 e2s) => [] -> [os] ->.
 split=> //. by eauto.
Qed.

Lemma rplc_insC_bef': forall xs i k e1 e2s, i + (S k) <= size xs ->
orplc i (Some e1) (ins (S (i + k)) e2s xs) = oins (S (i + k)) e2s  (rplc i (Some e1) xs)
/\ exists os, orplc i (Some e1) (ins (S (i + k)) e2s xs) = Some os.
Proof. move=>  xs i. elim: i xs => [|i IHi].
 + case=> [|x xs] k e1 e2s; rewrite add0n ?rplc_none_none //=; case Hins: ins => [ins_r|] //=.
  - split => //. by exists (e1 :: ins_r).
  - by move: Hins => /ins_noneP; rewrite ltnNge add0n -ltnS; case (_ <= _).
 + case=> [|x xs] k e1 e2s //. rewrite addSn /= => /IHi A. move: (A e1 e2s) => [] /=.
   rewrite orplc_Swcons oins_Swcons => -> [os] ->. split => //. by exists (x :: os).
Qed.

Theorem rplc_insC_bef: forall xs i k e1 e2s, i < k -> k <= size xs ->
orplc i (Some e1) (ins k e2s xs) = oins k e2s  (rplc i (Some e1) xs)
/\ exists os, orplc i (Some e1) (ins k e2s xs) = Some os.
Proof. move=> ??? e1 e2s /le_ex [?] <-.  rewrite ?addSn -?addnS => /rplc_insC_bef' A.
move: (A e1 e2s) => []. rewrite addnS=> -> [os] ->. split=> //. by exists os.  Qed.

Lemma rplc_insC_in: forall xs i k e1 e2s e2s',
rplc k (Some e1) e2s = Some e2s' -> orplc (i + k) (Some e1) (ins i e2s xs) = ins i e2s' xs.
Proof. intros. elim: i xs k e1 e2s e2s' H => [|i IHi].
 + move=> xs k e1 e2s e2s'; rewrite add0n //=.
   elim: k xs e1 e2s e2s' => [|k IHk] xs e1 e2s e2s'; case: e2s => [|e2 e2s] //; rewrite cat_cons //=.
  * by move=> [] [] <-; rewrite cat_cons.
  * by move=> /wcons_some [e2s''] [] /(IHk xs) -> ->.
 + by move=> [|x xs] k e1 e2s e2s' //=; rewrite addSn orplc_Swcons => /(IHi xs) ->.
Qed.

(* replace/remove commutation *)

Lemma rplc_rmC_aft' xs i k e1 e2s rrm:
 rm i e2s xs = Some rrm -> (size e2s + i + k) < size xs ->
  orplc (i+k) (Some e1) (rm i e2s xs) =
  orm i e2s (rplc (size e2s + i + k) (Some e1) xs)
   /\ exists os, orplc (i+k) (Some e1) (rm i e2s xs) = Some os.
Proof. elim: i xs k e1 e2s rrm => [|i IHi] xs k e1 e2s rrm.
 + rewrite ?addn0 add0n. elim: e2s k xs e1 => [[|k]|e2 e2s IHe2s k] [|x xs] e1;
   rewrite ?addn0 ?orm_id ?rm_id /=; try by eauto.
  - move=> _. rewrite add0n. case Hrplc: rplc => [a|] /=. by eauto.
    move: Hrplc => /rplc_noneP1. by rewrite ltnNge ltnS => ->.
   case Heq: (x == e2) => //. move/eqP: Heq <-. rewrite orm_0wcons addSn => H1.
   move: H1. eapply IHe2s => /(_ e1) /= [] -> [os] ->.
 + rewrite ?addSn ?addnS; move: xs IHi => [|x xs IHi]; first by case: e2s.
   rewrite rm_Scons orplc_Swcons => /wcons_some [rrm'] []. swap => _. swap.
   rewrite addSn rplc_Scons orm_Swcons => /=. swap.
   maxapply IHi => /(_ e1) [] -> [os] -> /=. by eauto.
Qed.

Theorem rplc_rmC_aft xs i k e1 e2s rrm: i <= k ->
 rm i e2s xs = Some rrm -> size e2s + k < size xs ->
   orplc k (Some e1) (rm i e2s xs) =
   orm i e2s (rplc (size e2s + k) (Some e1) xs)
    /\ exists os, orplc k (Some e1) (rm i e2s xs) = Some os.
Proof. move => /le_ex [?] <-. rewrite ?addnA.
apply rplc_rmC_aft' => /(_ e1) [] -> [os] -> /=. Qed.

Lemma rplc_rmC_bef': forall i xs k e1 e2s rrm,
 rm (S (i+k)) e2s xs = Some rrm -> i < size xs ->
  orplc i (Some e1) (rm (S (i+k)) e2s xs) =
  orm (S (i+k)) e2s (rplc i (Some e1) xs)
   /\ exists os, orplc i (Some e1) (rm (S (i+k)) e2s xs) = Some os.
Proof. elim => [|i IHi] xs k e1 e2s rrm.
 + rewrite add0n; elim: e2s xs k e1 => [|er e2s IHe2s] xs k e1 /=.
  * rewrite rm_id => _ /=. case: xs => [|x xs] //= _ . by eauto.
  * case: xs => [|x xs] //=; rewrite orplc_0wcons => /wcons_some [rrm'] [] -> /=. by eauto.
 + rewrite ?addSn ?addnS. case: xs => [|x xs] //=.
   case: e2s => [|e2 e2s] /=.
  - move=> _. case Hrplc: rplc => [rplc_r|] /=; first by eauto.
     by move: Hrplc => /rplc_noneP1; rewrite ltnNge ltnS => ->.
  - move => /wcons_some [rrm'] []. swap => _.
    rewrite orplc_Swcons ?orm_Swcons. maxapply IHi => /(_ e1) [] -> [os] -> /=. by eauto. Qed.

Theorem rplc_rmC_bef xs i k e1 e2s rrm:
 i < k -> rm k e2s xs = Some rrm -> i < size xs ->
  orplc i (Some e1) (orm k e2s (Some xs)) =
  orm k e2s (rplc i (Some e1) xs)
   /\ exists os, orplc i (Some e1) (rm k e2s xs) = Some os.
Proof. move=> /le_ex [?] <-; rewrite ?addSn.
by apply rplc_rmC_bef' => /(_ e1) [] -> ? ->. Qed.

Theorem rplc_rmC_in {xs i k y}: forall ys ers' ers,
 rplc i y ers = Some ers' -> orm k ers xs = Some ys ->
  orm k ers' (orplc (i + k) y xs) = Some ys.
Proof. case: xs i k y => [xs|*//]; intros. case: y H => [y|] //=; last by rewrite rplc_none_none.
  elim: k xs i y ys ers ers' H0 => [|k IHk].
 + move=> xs i; elim: i xs => [|i IHi] xs y ys [|er ers] ers' //=; case: xs => [|x xs] //=;
   case Heq: (x == er) => // ?; first by move=> [] <-; rewrite eq_refl.
   by move=> /wcons_some [ers''] [] ? ->; move/eqP: Heq ->;
   rewrite orm_0wcons (IHi xs y ys ers ers'').
 + by move=> [|x xs] i y ys [|er ers] ers'; rewrite ?addnS ?rplc_0none //= orm_Swcons =>
   /wcons_some [ys' []] ? -> ?; rewrite (IHk _ _ _ ys' (er::ers)). Qed.

(* relating other operations to nth *)
Lemma ins_some_nth_aft {n ys}: forall xs es n2, n < n2 -> ins n2 es xs = Some ys
-> nth n ys = nth n xs.
Proof. elim: n ys => [|n IHn] ys [|x xs] [|e es] [|n2] //= Hltn /wcons_some [ys'] [] Hys' -> //=;
  by rewrite (IHn _ xs _ n2 _ Hys')//. Qed.

Lemma rm_some_nth_aft: forall n xs ys es n2, n < n2 -> rm n2 es xs = Some ys
-> nth n ys = nth n xs.
Proof. elim => [|n IHn] [|x xs] ys [|e es] [|n2] //= Hltn; try move=> [] <- //=;
 move=> /wcons_some [ys'] [] Hys' -> //; rewrite (IHn xs _ _ n2 _ Hys') //.
Qed.

Lemma rm_some_nth_bef: forall n xs ys es n2, n <= n2 -> rm n es xs = Some ys
-> nth n2 ys = nth (n2 + size es) xs.
Proof. elim => [|n IHn] xs ys es n2.
+ move=> H; elim: xs es => [|x xs IHxs] [[] <- //|e es] //=; try by rewrite addn0.
  by case Heq: (x == e) => // /IHxs ->; rewrite addnS.
+ case: es => [|e es]; first by rewrite rm_id addn0 => _ [] ->.
  by case: xs => [|x xs] //= Hleq /wcons_some [ys'] [] ? ->; case: n2 Hleq => [|n2] // /= ?;
  rewrite (IHn xs _ (e::es)) //. Qed.

Lemma rm_some_nth_in {k i xs}: forall ys es, i < size es -> rm k es xs = Some ys ->
nth (i + k) xs = nth i es.
Proof. by elim: k i xs => [|k IHk i]; [elim => [|i IHi] /=|]; move => [|x xs] ys [|e es] //=;
 [| |(rewrite addnS ?nth_nil_none //= => ? /wcons_some [ys'] [] ?; rewrite (IHk _ _ ys' (e::es)))];
 case Heq: (x == e) => //; [move /eqP: Heq => <- | move => ??; rewrite (IHi _ ys es)]. Qed.

Lemma ins_some_nth_bef {n xs}: forall ys es n2, n2 <= n -> ins n2 es xs = Some ys
-> nth n xs = nth (size es + n) ys.
Proof. elim: n xs => [|n IHn] xs ys es n2.
 + by rewrite leqn0 => /eqP -> /= [] <-; rewrite nth_app_next.
 + case: n2 => [_|n2] /=. by move=> [] <-; rewrite nth_app_next.
   by case: xs => [|x xs] // ? /wcons_some [ls'] [] ?;
      rewrite addnS (IHn _ ls' es n2) //= => ->.
Qed.

Lemma ins_some_nth_in {i k es ys xs} : k < size es -> ins i es xs = Some ys -> nth (i + k) ys = nth k es.
Proof. elim: i xs ys => [|i IHi] xs ys.
 + move=> H /= [] <-; rewrite add0n. elim: k es H => [|k IHk] [|e es] //=.
   by move /IHk.
 + by case: xs => [|x xs] //= Hlt /wcons_some [zs] [] /(IHi xs zs Hlt) <- ->.
Qed.

Lemma rplc_nth_eq n xs ys z: rplc n (Some z) xs = Some ys -> nth n ys = Some z.
Proof. elim: n xs ys => [|n IHn] [|x xs] [|y ys] //=.
 - by move=> [] ->.
 - by case: rplc.
 - by case Hrplc: rplc => [ls|] //= []; move: Hrplc => /IHn /= <- _ ->. Qed.

Lemma rplc_nth_neq' n1 n2 xs ys z: n1 < n2 ->
rplc n1 z xs = Some ys -> nth n2 xs = nth n2 ys.
Proof. case: z => [z|] //; last by rewrite rplc_none_none.
elim: n1 xs ys n2 => [|n1 IHn1] [|x xs] ys n2 //=; case: n2 => [|n2] //= ?.
 + by move => [] <-.
 + by move => /wcons_some [ys'] [] ? ->; rewrite (IHn1 _ ys'). Qed.

Lemma rplc_nth_neq'' n1 n2 xs ys z: n1 < n2 ->
rplc n2 z xs = Some ys -> nth n1 xs = nth n1 ys.
Proof. case: z => [z|] //; last by rewrite rplc_none_none.
elim: n2 xs ys n1 => [|n2 IHn2] [|x xs] ys [|n1] //= ? /wcons_some [ys'[? ->]] //.
by apply (IHn2 _ ys'). Qed.

Theorem rplc_nth_neq n1 n2 xs ys z: n1 != n2 ->
rplc n2 z xs = Some ys -> nth n1 xs = nth n1 ys.
Proof. rewrite neq_ltn => /orP []; [exact: rplc_nth_neq'' |exact: rplc_nth_neq']. Qed.

(* remove/cut properties *)

Lemma rm_cut : forall xs n1 n2 es1 es2 ys1 ys2,
 orm n1 es1 xs = Some ys1 -> orm n2 es2 xs = Some ys2 -> n1 <= n2 -> n2 <= n1 + size es1 ->
 orm n1 (cut es2 0 (n1 + size es1 - n2)) (orm n1 es1 xs) =
 orm n1 (cut es1 (n2 - n1) (size es2)) (orm n2 es2 xs) /\
 exists os, orm n1 (cut es1 (n2 - n1) (size es2)) (orm n2 es2 xs) = Some os.
Proof. move=> [xs|] n1 //; elim: n1 xs => [|n1 IHn1].
 + elim => [|x xs IHxs].
  - move=> n2 [|??] [|??] //= [|??] [|??] //= _ _ _.
    rewrite leqn0 => /eqP ->. rewrite subnn. by eauto.
  - move=> n2 [|e1 es1] [|e2 es2] ys1 ys2 /= H1 H2 H3;
     try (rewrite leqn0 => /eqP Hn2; move: H2; rewrite Hn2 subnn ?orm_id;
          case: (x == e2); by eauto).
   * case: n2 H2 H3 => [|n2] //. by eauto.
     case: n2 H3 => [|n2] // _ _; rewrite add0n ?subn0; try case: subn => [|?];
     move: H1; case: (x == e1) => //; rewrite ?cut_id orm_id => ->; by eauto.
   * move: H1. case Heq: (x == e1) => // /IHxs A.
     move: H2. case: n2 H3 => [|n2] _.
    - case: (x == e2) => // /A B. move: (B (leq0n _) (leq0n _)) => /=.
      rewrite add0n ?subn0 => [] [] -> [os] ->; by eauto.
    - move => /wcons_some [ys2'] [] /A B _. rewrite add0n => /(B (leq0n _)) /= [].
      rewrite subn0 => ->. move/eqP: Heq ->. rewrite orm_0wcons => [] [os] ->. by eauto.
 + move=> [|x xs] [|n2] es1 es2 ys1 ys2 //; rewrite ?cons_wcons ?orm_Swcons subSS.
  - move: es1 es2 => [|??] [|??] //=; case: subn; case: subn => //=; by eauto.
   move=> /wcons_some [ys1'] [] /IHn1 A _ /wcons_some [ys2'] [] /A B _ /B C.
   rewrite addSn. move => /C [] -> [os] -> /=. by eauto.
Qed.

(* inversion theorems *)
Lemma rm_ins_id : forall n xs es ys,
ins n es xs = Some ys -> rm n es ys = Some xs.
Proof. elim => [|n IHn] xs es ys.
 + elim: es xs ys => [[|x xs]|e es IHes xs] ys //= [] <-; try (by rewrite rm_id).
   rewrite orm_some cons_wcons orm_0wcons /= (IHes xs) //.
 + case: xs => [|x xs] //. rewrite oins_some cons_wcons oins_Swcons => /wcons_some [ys'] [].
   move=> /IHn <- ->. by rewrite orm_some cons_wcons orm_Swcons.
Qed.

Lemma ins_rm_id : forall n xs es ys,
size es > 0 -> rm n es xs = Some ys -> ins n es ys = Some xs.
Proof. elim => [|n IHn] xs es ys.
 + move=> _. elim: es xs ys => [|e es IHes] [|x xs] ys //=; try (by rewrite rm_id => -> /=).
   case Heq: (x == e) => // /IHes [] <-. by move/eqP: Heq ->.
 + case: xs => [|x xs] //. case: es => //= [] [] <-. swap. rewrite orm_some cons_wcons orm_Swcons.
   move=> /wcons_some => [] [ys'] []. swap => -> /=. maxapply IHn. by move=> /= ->.
Qed.

Section AboutSizes.

Theorem cutSZ (xs : seq X) i n:
size (cut xs i n) =
 if (i + n <= size xs) then size xs - n
 else if (i <= size xs) then i
 else size xs.
Proof. elim: i xs n => [|i IHi] xs n /=.
 + elim: n xs => [|n IHn] [|x xs] //=. rewrite IHn. nat_norm.
   rewrite -addn1 -(addn1 (size xs)) leq_add2r. case Hleq: (n <= size xs) => //=.
   by rewrite ?addn1 subSS.
 + move: xs => [|x xs] //=. rewrite IHi. nat_norm.
   rewrite -(addn1 (i + n)) -(addn1 (size xs)) leq_add2r. case Hleq: (i + n <= size xs).
   move: (Hleq) => /leq_addWl. rewrite -addn1 addnC => /addnBA ->. by rewrite addnC.
   rewrite -(addn1 i) leq_add2r. case: (i <= size xs); ssromega.
Qed.

Theorem cut_lenleq (xs : seq X) i n:
size (cut xs i n) <= size xs.
Proof. move: (cutSZ xs i n). case: ifP => Hleq.
 - move: (leq_subr n (size xs)). by swap => ->.
 - case: ifP => Hleq'; move=> /eq_leq =>//.
   move: Hleq'. swap. by apply leq_trans. Qed.

End AboutSizes.

Section Miscellanea.

Fixpoint find {Z : Type} p (xs : seq Z) : option Z :=
 match xs with
 | xh :: xt => if p xh then Some xh else find p xt
 | _ => None end.

Lemma foldl_map (T1 T2 S : Type) (f : S -> T2 -> S) (g : T1 -> T2) (x : seq T1) (r : S):
foldl f r (map g x) = foldl (fun x => (f x) \o g) r x.
by elim: x r => [|x xs IH] //=. Qed.

Lemma filter_filter {p p' : X -> bool} {xs} : filter p (filter p' xs) = filter p' (filter p xs).
elim: xs => //= [xh xt IHxs]. case P1: (p xh); case P2: (p' xh);  rewrite /= ?P1 ?P2 IHxs //. Qed.

Lemma all_filter p q (cs :seq X): all p cs -> all p [seq x <- cs | q x].
by elim: cs => [|c cs IH] //= /andP [] A0 /IH A1; case A2: q => /=; rewrite ?A0 A1. Qed.

Lemma has_filter p q (xs : seq X): p --- q -> has q (filter p xs) = has q xs.
intros A1. elim: xs => [|x xs IH] //=. move: (A1 x). case A0: (p x).
 + by rewrite /= IH.
 + by move => -> //. Qed.

Lemma map_inj {X' : eqType} (f : X -> X') x s: injective f -> ((f x) \in (map f s)) = (x \in s).
move => B0. elim: s => [|c s IH] //=.
case A0: (x == c) => /=.
 + move: A0 => /eqP ->. by rewrite /in_mem /= ?eq_refl.
 + move: IH. rewrite /in_mem /=. case A1: eq_op.
  * move: A1 A0 => /eqP /B0 ->. by rewrite eq_refl.
  * by move: A0 => -> ->. Qed.

Lemma find_absent {A p xs}: find p xs = @None A <-> has p xs = false.
by elim: xs => // a l [IHa IHb] /=; case: (p a); split. Qed.

Lemma has_find {A p xs}: has p xs = true -> exists (x : A), find p xs = Some x.
case H: (find p xs) => [x|].
  + by exists x.
  + by move => G; apply find_absent in H; rewrite H in G. Qed.

Lemma find_pred {xs p} {x : X}: find p xs = Some x -> p x.
elim: xs => [|xh xt IHxs] //.
 + by rewrite /=; case H: (p xh) => // [] [] <-. Qed.

Lemma find_filter p q (xs : seq X): p --- q -> find q (filter p xs) = find q xs.
intros A1. elim: xs => [|x xs IH] //=. move: (A1 x). case A0: (p x).
 + by rewrite /= IH.
 + by move => -> //. Qed.

Lemma find_has {p xs} {x : X}: find p xs = Some x -> has p xs = true.
by elim: xs => [|xh xt IHxs]; rewrite //=; case P: (p xh) => //. Qed.

End Miscellanea.

(* Sequence difference *)

Definition seqminus (x y : seq X) := filter (fun z => z \notin y) x.

Section SeqMinus.

Notation "X \ Y" := (seqminus X Y) (at level 40, left associativity).

Lemma sum_setminus (f : X -> nat) (S1 S2 : seq X):
  foldl addn 0 (map f (S1 \ S2)) <= foldl addn 0 (map f S1).
elim: S1 S2 => [|s cs IH] S2 //=. case A0: (in_mem) => /=; move: (IH S2); rewrite ?add0n ?(fadd (f s)).
 + move: (foldl _ _ _) => a. move: (foldl _ _ _) => b. rewrite -{2}(add0n (a)). by apply leq_add.
 + by apply leq_add. Qed.

Lemma seqminus_nil (l : seq X): l \ [::] = l.
 elim: l => [|t l IH] //=. by rewrite IH. Qed.

Lemma seqminus_nil' (l : seq X): [::] \ l = [::].
 elim: l => [|t l IH] //=. Qed.

Lemma seqminus_cons (l l2 : seq X) x: x \notin l -> l \  (x :: l2) = l \ l2.
elim: l => [|y l IH] //=. rewrite /in_mem /= eq_sym. case A0: eq_op => //= A1. by rewrite IH. Qed.

Lemma seqminus_cons' (l l2 : seq X) x: x \notin l2 -> (x :: l) \ l2 = x :: (l \ l2).
by move => /= ->. Qed.

Corollary seqminus_singleton (l : seq X) x: x \notin l -> l \ [:: x] = l.
move: (seqminus_cons l [::] x). by rewrite /= seqminus_nil. Qed.

Import Bool.

Lemma notin_setminus (l : seq X) x: x \notin (l \ [::x]).
elim: l => [|z l IH] //=. case A0: (in_mem z) => //=. move: A0.
by rewrite /in_mem /= orb_false_r eq_sym => ->. Qed.

Corollary uniq_setminus (l l2 : seq X): uniq l -> uniq (l \ l2).
rewrite /seqminus. apply filter_uniq. Qed.

Lemma filter_and (l : seq X) p1 p2: filter p2 (filter p1 l) = filter (fun x => p1 x && p2 x) l.
elim: l => [|x l IH] //=. case A0: (p1 x) => //=.
 + case A1: (p2 x) => //=. by rewrite IH. Qed.

Lemma seqminus_cat (l l1 l2 : seq X): l \ l1 \ l2 = l \ (l1 ++ l2).
rewrite /seqminus. rewrite filter_and. apply eq_filter => x /=. by rewrite mem_cat /= negb_orb. Qed.

Lemma seqminus_p1 (l1 l2 : seq X) x: x \notin l2 -> l2 \ (l1 \ [:: x]) = l2 \ l1.
rewrite /seqminus => A0. apply eq_in_filter => z A1. rewrite mem_filter /= /in_mem /= orb_false_r.
case A2: eq_op => //=. by move: A2 A1 A0 => /eqP -> ->. Qed.

End SeqMinus.

End Lists.

Notation "X \ Y" := (seqminus X Y) (at level 40, left associativity).

Lemma map_seq_minus {X X' : eqType} (s1 s2 : seq X) (f : X -> X'):
  injective f -> map f (s1 \ s2) = (map f s1) \ (map f s2).
move => B0. rewrite /seqminus. elim: s1 => [|x s1 IH] //=.
rewrite map_inj //. case A1: (x \notin s2) => /=; by rewrite IH. Qed.


(*  Copyright 2004 INRIA  *)
Require Export Classical.

Lemma zenon_nottrue :
  (~True -> False).
Proof. tauto. Qed.

Lemma zenon_noteq : forall (T : Type) (t : T),
  ((t <> t) -> False).
Proof. tauto. Qed.

Lemma zenon_and : forall P Q : Prop,
  (P -> Q -> False) -> (P /\ Q -> False).
Proof. tauto. Qed.

Lemma zenon_or : forall P Q : Prop,
  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
Proof. tauto. Qed.

Lemma zenon_imply : forall P Q : Prop,
  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_equiv : forall P Q : Prop,
  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notand : forall P Q : Prop,
  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notor : forall P Q : Prop,
  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notimply : forall P Q : Prop,
  (P -> ~Q -> False) -> (~(P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notequiv : forall P Q : Prop,
  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.

Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
Proof. auto. Qed.

Lemma zenon_equal_step :
  forall (S T : Type) (fa fb : S -> T) (a b : S),
  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.

Lemma zenon_pnotp : forall P Q : Prop,
  (P = Q) -> (P -> ~Q -> False).
Proof. intros P Q Ha. rewrite Ha. auto. Qed.

Lemma zenon_notequal : forall (T : Type) (a b : T),
  (a = b) -> (a <> b -> False).
Proof. auto. Qed.

Ltac zenon_intro id :=
  intro id || let nid := fresh in (intro nid; clear nid)
.

Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.

Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Rbase.
Require Import Rsequence.
Require Import Ranalysis.
Require Import Rfunctions.
Require Import Rseries_def.
Require Import Fourier.
Require Import RiemannInt.
Require Import SeqProp.
Require Import Ranalysis_def.
Require Import MyRIneq.

Local Open Scope R_scope.

(** * Intermediate Value Theorem on an Interval and its corollary *)
(** This proof was mainly taken from Reals.Rsqrt_def *)

Lemma IVT_interv_prelim0 : forall (x y:R) (P:R->bool) (N:nat),
       x < y ->
       interval x y (Dichotomy_ub x y P N) /\ interval x y (Dichotomy_lb x y P N).
Proof.
intros x y P N x_lt_y.
induction N.
 simpl ; intuition.
  split ; [left ; assumption | right ; reflexivity].
  split ; [right ; reflexivity | left ; assumption].
 simpl.
 replace ((Dichotomy_lb x y P N + Dichotomy_ub x y P N) / 2) with
  (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N)).
 case (P (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N))).
 split.
 apply middle_interval ; intuition.
 intuition.
 split ; [| apply middle_interval] ; intuition.
 unfold middle ; reflexivity.
Qed.

Lemma IVT_interv_prelim1 : forall (x y b:R) (D : R -> bool),
       x < y ->
       Rseq_cv (dicho_up x y D) b ->
       interval x y b.
Proof.
intros x y x0 D x_lt_y bnd.
 assert (Main : forall n, interval x y (dicho_up x y D n)).
  intro n. unfold dicho_up.
  apply (proj1 (IVT_interv_prelim0 x y D n x_lt_y)).
 split.
  apply Rle_cv_lim with (Vn:=dicho_up x y D) (Un:=fun n => x).
  intro n ; exact (proj1 (Main n)).
  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (x -x) with 0 by field ; rewrite Rabs_R0 ; assumption.
  assumption.
  apply Rle_cv_lim with (Un:=dicho_up x y D) (Vn:=fun n => y).
  intro n ; exact (proj2 (Main n)).
  assumption.
  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (y -y) with 0 by field ; rewrite Rabs_R0 ; assumption.
Qed.

Lemma IVT_interv : forall (f : R -> R) (x y : R),
       continuity_interval f x y ->
       x < y ->
       interval (f x) (f y) 0 ->
       {z : R | interval x y z /\ f z = 0}.
Proof.
intros f x y H H0 [H1 H2].
 case (Rle_lt_or_eq_dec _ _ H1) ; clear H1 ; intro H1.
 case (Rle_lt_or_eq_dec _ _ H2) ; clear H2 ; intro H2.
  cut (x <= y).
  intro.
  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3).
  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3).
  intros X X0.
  elim X; intros.
  elim X0; intros.
  assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
  rewrite H4 in p0.
  exists x0.
  split.
  split.
  apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
  simpl in |- *.
  right; reflexivity.
  apply growing_ineq.
  apply dicho_lb_growing; assumption.
  assumption.
  apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
  apply decreasing_ineq.
  apply dicho_up_decreasing; assumption.
  assumption.
  right; reflexivity.
  2: left; assumption.
  set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
  set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
  cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
  cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
  intros.
  cut (forall n:nat, f (Vn n) <= 0).
  cut (forall n:nat, 0 <= f (Wn n)).
  intros.
  assert (H9 := H6 H8).
  assert (H10 := H5 H7).
  apply Rle_antisym; assumption.
  intro.
  unfold Wn in |- *.
  cut (forall z:R, cond_positivity z = true <-> 0 <= z).
  intro.
  assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
  elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
  apply H9.
  apply H8.
  elim (H7 (f y)); intros.
  apply H12.
  left ; assumption.
  intro.
  unfold cond_positivity in |- *.
  case (Rle_dec 0 z); intro.
  split.
  intro; assumption.
  intro; reflexivity.
  split.
  intro feqt;discriminate feqt.
  intro.
  elim n0; assumption.
  unfold Vn in |- *.
  cut (forall z:R, cond_positivity z = false <-> z < 0).
  intros.
  assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
  elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
  left ; apply H9.
  apply H8.
  elim (H7 (f x)); intros.
  apply H12.
  assumption.
  intro.
  unfold cond_positivity in |- *.
  case (Rle_dec 0 z); intro.
  split.
  intro feqt; discriminate feqt.
  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
  split.
  intro; auto with real.
  intro; reflexivity.
  cut (Un_cv Wn x0).
  intros.
  assert (Temp : x <= x0 <= y).
   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
  assert (H7 := continuity_seq f Wn x0 (H x0 Temp) H5).
  case (total_order_T 0 (f x0)); intro.
  elim s; intro.
  left; assumption.
  rewrite <- b; right; reflexivity.
  unfold Un_cv in H7; unfold R_dist in H7.
  cut (0 < - f x0).
  intro.
  elim (H7 (- f x0) H8); intros.
  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
  assert (H11 := H9 x2 H10).
  rewrite Rabs_right in H11.
  pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
  unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
  assert (H12 := Rplus_lt_reg_r _ _ _ H11).
  assert (H13 := H6 x2).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
  apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
  apply H6.
  exact H8.
  apply Ropp_0_gt_lt_contravar; assumption.
  unfold Wn in |- *; assumption.
  cut (Un_cv Vn x0).
  intros.
  assert (Temp : x <= x0 <= y).
   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
  assert (H7 := continuity_seq f Vn x0 (H x0 Temp) H5).
  case (total_order_T 0 (f x0)); intro.
  elim s; intro.
  unfold Un_cv in H7; unfold R_dist in H7.
  elim (H7 (f x0) a); intros.
  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
  assert (H10 := H8 x2 H9).
  rewrite Rabs_left in H10.
  pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
  rewrite Ropp_minus_distr' in H10.
  unfold Rminus in H10.
  assert (H11 := Rplus_lt_reg_r _ _ _ H10).
  assert (H12 := H6 x2).
  cut (0 < f (Vn x2)).
  intro.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
  rewrite <- (Ropp_involutive (f (Vn x2))).
  apply Ropp_0_gt_lt_contravar; assumption.
  apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
  rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
    [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
  assumption.
  apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
  right; rewrite <- b; reflexivity.
  left; assumption.
  unfold Vn in |- *; assumption.
  exists y ; repeat split ; intuition.
  exists x ; repeat split ; intuition.
Qed.


(** * Properties of cocwp (cwp on cotrees). *)

Set Implicit Arguments.

From Coq Require Import
  Basics
  QArith
  Lra
  Equivalence
  Reals
.

Local Open Scope equiv_scope.
Local Open Scope program_scope.

From algco Require Import
  aCPO
  cocwp
  cotree
  cpo
  geometric_series
  misc
  order
  R
  eR
  tactics
.

Local Open Scope eR_scope.
Local Open Scope order_scope.

Create HintDb cotcwp.

Lemma chain_cotree_loop_approx {A} (x : A) (e : A -> bool)
  (g : A -> cotree bool (unit + A))
  (f : A -> cotree bool (unit + A)) :
  chain (cotree_loop_approx x e g f).
Proof.
  unfold cotree_loop_approx, cotree_loop_F.
  intro i.
  revert x e g f.
  induction i; simpl; intros x e g f.
  - destruct (e x); try reflexivity; constructor.
  - destruct (e x); try reflexivity; apply cotree_le_bind.
    intros [[]|a]; try reflexivity; try constructor; apply IHi.
Qed.

(** Example of Proper_co followed by induction on atree. *)
Lemma cotree_bind_map_sum {A} t g :
  cotree_bind (cotree_map inr t)
    (fun lr : A + (unit + A) => match lr with
                             | inl j => g j
                             | inr x => coleaf x
                             end) = t.
Proof.
  apply cotree_ext, equ_cotree_eq.
  replace t with (co tinj t) by apply co_tinj_t.
  unfold cotree_bind, cotree_map, tcofold.
  rewrite co_co''; eauto with cotree order.
  apply Proper_co'.
  { apply monotone_compose; eauto with cotree order aCPO. }
  { apply Proper_tinj. }
  2: { rewrite co_tinj_t; reflexivity. }
  unfold compose.
  apply equ_arrow; intro a.
  unfold atree_cotree_map, atree_cotree_bind; simpl.
  induction a; unfold compose; simpl.
  - rewrite co_tfold_bot; reflexivity.
  - rewrite co_tfold_leaf; try reflexivity; constructor.
  - rewrite co_tfold_node; auto with cotree order;
      try solve [intros; constructor].
    apply cotree_eq_equ; constructor; intro b; apply equ_cotree_eq, H.
Qed.

Lemma iid_F_cotree_iter_F {A} (a : cotree bool (unit + A)) (b : cotree bool A) :
  iid_F a b = cotree_iter_F (const a) (const b) tt.
Proof. reflexivity. Qed.

Lemma continuous_iid_F {A} (t : cotree bool (unit + A)) :
  continuous (iid_F t).
Proof.
  intros ch Hch s Hs.
  rewrite iid_F_cotree_iter_F.
  unfold compose.
  replace (fun x => iid_F t (ch x)) with
    (fun x => cotree_iter_F (const t) (const (ch x)) tt).
  2: { ext i; rewrite iid_F_cotree_iter_F; reflexivity. }
  set (ch' := (fun t' => cotree_iter_F (const t) (const t')) ∘ ch).
  replace (fun x : nat => cotree_iter_F (const t) (const (ch x)) tt) with
    (fun i => ch' i tt) by reflexivity.
  apply apply_supremum.
  apply continuous_cotree_iter_F.
  - unfold const.
    intros i j; destruct (Hch i j) as [k [Hk Hk']].
    exists k; split; intros []; auto.
  - unfold const.
    split.
    + intros i []; apply Hs.
    + intros x Hx []; apply Hs; intro i; apply Hx.
Qed.

#[global]
  Instance monotone_btwp {A} (f : A -> eR) : Proper (leq ==> leq) (btwp f).
Proof.
  apply monotone_tfold.
  - intros; eRauto.
  - intros g g' Hg; simpl.
    apply eRle_div, eRplus_le_compat; apply Hg.
Qed.
#[global] Hint Resolve monotone_btwp : cotcwp.

Lemma fold_avg_bounded {A} (f : A -> eR) (t : atree bool A) :
  bounded f 1 ->
  tfold 1 f (fun k : bool -> eR => (k false + k true) / 2) t ⊑ 1.
Proof.
  revert f; induction t; intros f Hf; simpl; eRauto.
  unfold compose.
  apply eRmult_le_reg_r with (r:=2); eRauto.
  unfold eRdiv.
  rewrite eRmult_assoc.
  rewrite eRinv_l; eRauto.
  etransitivity.
  { apply eRplus_le_compat; apply H; auto. }
  constructor; lra.
Qed.

Lemma monotone_avg : monotone (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros f g Hfg; simpl.
  apply eRle_div, eRplus_le_compat; apply Hfg.
Qed.

#[global]
  Instance antimonotone_btwlp {A} (f : A -> eR) {Hf: bounded f 1}
  : Proper (leq ==> flip leq) (btwlp f).
Proof.
  apply antimonotone_tfold.
  - intro a; apply fold_avg_bounded; auto.
  - apply monotone_avg.
Qed.
#[global] Hint Resolve antimonotone_btwlp : cotcwp.

Corollary continuous_cotwp {A} (f : A -> eR) : continuous (cotwp f).
Proof. apply continuous_co, monotone_btwp. Qed.
#[global] Hint Resolve continuous_cotwp : cotcwp.

Corollary cocontinuous_cotwlp {A} (f : A -> eR) :
  bounded f 1 ->
  cocontinuous (cotwlp f).
Proof. intro Hf; apply cocontinuous_coop, antimonotone_btwlp; auto. Qed.
#[global] Hint Resolve cocontinuous_cotwlp : cotcwp.

Lemma wcontinuous_avg : wcontinuous (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros ch Hch s Hs; unfold compose.
  unfold eRdiv.
  rewrite eRmult_comm.
  replace (fun x : nat => (ch x false + ch x true) * / 2) with
    (fun i => / 2 * (ch i false + ch i true)).
  2: { ext i; apply eRmult_comm. }
  apply supremum_scalar.
  apply supremum_sum.
  { intro i; apply Hch. }
  { intro i; apply Hch. }
  { apply apply_supremum; auto. }
  { apply apply_supremum; auto. }
Qed.

Lemma dec_wcontinuous_avg : dec_wcontinuous (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros ch Hch s Hs; unfold compose.
  unfold eRdiv.
  rewrite eRmult_comm.
  replace (fun x : nat => (ch x false + ch x true) * / 2) with
    (fun i => / 2 * (ch i false + ch i true)).
  2: { ext i; apply eRmult_comm. }
  apply infimum_scalar.
  { simpl; destr; try congruence; lra. }
  apply infimum_sum.
  { intro i; apply Hch. }
  { intro i; apply Hch. }
  { apply apply_infimum; auto. }
  { apply apply_infimum; auto. }
Qed.

(** Computation lemmas for cotwp. *)
Lemma cotwp_bot {A} (f : A -> eR) :
  cotwp f cobot = 0.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_bot; reflexivity.
Qed.

Lemma cotwp_leaf {A} (f : A -> eR) (x : A) :
  cotwp f (coleaf x) = f x.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_leaf; eRauto.
Qed.

Lemma cotwp_node {A} (f : A -> eR) (k : bool -> cotree bool A) :
  cotwp f (conode k) = (cotwp f (k false) + cotwp f (k true)) / 2.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_node; eRauto.
  apply wcontinuous_avg.
Qed.

(** An essential lemma about the co-semantics. Proof by using
    co_compose to turn the LHS into a single comorphism, then
    Proper_co to show equality of LHS and RHS. *)
Lemma cotwp_bind {A B} (f : B -> eR) (t : cotree bool A) (k : A -> cotree bool B) :
  cotwp f (cotree_bind t k) = cotwp (cotwp f ∘ k) t.
Proof.
  unfold cotwp.
  unfold cotree_bind, tcofold.
  apply equ_eR.
  set (g := btwp f).
  set (h := atree_cotree_bind k).
  assert (Hg: wcontinuous (co g)).
  { apply continuous_wcontinuous, continuous_co, monotone_btwp. }
  assert (Hh: monotone h).
  { apply monotone_atree_cotree_bind. }
  generalize (@co_co (cotree bool A) (atree bool A) (cotree bool B)
                eR _ _ _ _ _ _ _ _ _ _ h (co g) Hh Hg).
  intro H.
  apply equ_arrow with (x:=t) in H.
  unfold compose, h in H.
  unfold compose in H; rewrite H; clear H.
  revert t.
  apply equ_arrow.
  apply Proper_co.
  { replace (fun x : atree bool A => co g (h x)) with (co g ∘ h) by reflexivity.
    apply monotone_compose.
    - apply monotone_atree_cotree_bind.
    - apply monotone_co, monotone_btwp. }
  { apply monotone_btwp. }
  apply equ_arrow.
  intro t.
  apply equ_eR.
  unfold g, h in *; clear g h Hg Hh.
  unfold compose.
  revert f k.
  induction t; intros f k; simpl.
  - apply cotwp_bot.
  - reflexivity.
  - apply equ_eR.
    unfold btwp, atree_cotree_bind in *; simpl.
    rewrite co_tfold_node; eRauto.
    { apply equ_eR; unfold compose; rewrite 2!H; reflexivity. }
    { apply wcontinuous_avg. }
Qed.

(** Computation lemmas for cotwlp. *)
Lemma cotwlp_bot {A} (f : A -> eR) :
  cotwlp f cobot = 1.
Proof.
  apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_bot; reflexivity.
Qed.

Lemma cotwlp_leaf {A} (f : A -> eR) (x : A) :
  bounded f 1 ->
  cotwlp f (coleaf x) = f x.
Proof.
  intro Hf; apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_leaf; eRauto; apply Hf.
Qed.

Lemma cotwlp_node {A} (f : A -> eR) (k : bool -> cotree bool A) :
  bounded f 1 ->
  cotwlp f (conode k) = (cotwlp f (k false) + cotwlp f (k true)) / 2.
Proof.
  intro Hf; apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_node; eRauto.
  { apply dec_wcontinuous_avg. }
  { intro a; apply fold_avg_bounded; auto. }
  { unfold eRdiv, eRmult; simpl.
    destruct (R_eq_dec 2 0); try lra.
    constructor; lra. }
Qed.

Corollary btwlp_bounded {A} (f : A -> eR) (t : atree bool A) :
  bounded f 1 ->
  btwlp f t ⊑ 1.
Proof. apply fold_avg_bounded. Qed.

(** See above. *)
Lemma cotwlp_bind {A B} (f : B -> eR) (t : cotree bool A) (k : A -> cotree bool B) :
  bounded f 1 ->
  cotwlp f (cotree_bind t k) = cotwlp (cotwlp f ∘ k) t.
Proof.
  intro Hf.
  unfold cotwlp.
  unfold cotree_bind.
  apply equ_eR.
  set (g := btwlp f).
  set (h := atree_cotree_bind k).
  assert (Hg: cocontinuous (coop g)).
  { apply cocontinuous_coop, antimonotone_btwlp; auto. }
  assert (Hh: monotone h).
  { apply monotone_atree_cotree_bind. }
  generalize (@co_coop (cotree bool A) (atree bool A) (cotree bool B)
                eR _ _ _ _ _ _ _ _ _ _ h (coop g) Hh Hg).
  intro H.
  apply equ_arrow with (x:=t) in H.
  unfold compose, h in H; rewrite H; clear H.
  revert t.
  apply equ_arrow.
  apply Proper_coop.
  { replace (fun x : atree bool A => co g (h x)) with (co g ∘ h) by reflexivity.
    intros a b Hab; unfold flip.
    apply antimonotone_coop; auto.
    apply antimonotone_btwlp; auto. }
  { apply antimonotone_btwlp.
    intro x; unfold compose, coop.
    apply leq_eRle.
    unfold g.
    apply lattice_ge_inf with O; auto with eR. }
  apply equ_arrow.
  intro t.
  apply equ_eR.
  unfold g, h in *; clear g h Hg Hh.
  unfold compose.
  revert Hf.
  revert f k.
  induction t; intros f k Hf; simpl.
  - apply cotwlp_bot.
  - reflexivity.
  - apply equ_eR.
    unfold btwlp, atree_cotree_bind in *; simpl.
    rewrite coop_tfold_node; eRauto.
    { apply equ_eR; unfold compose; rewrite 2!H; auto; reflexivity. }
    { apply dec_wcontinuous_avg. }
    { intro; apply fold_avg_bounded; auto. }
    { unfold eRdiv, eRmult; simpl.
      destruct (R_eq_dec 2 0); try lra.
      constructor; lra. }
Qed.

Lemma cotwp_filter {A} (P : A -> bool) (f : A -> eR) :
  cotwp (fun x => if P x then f x else 0) === cotwp f ∘ cotree_filter P.
Proof.
  unfold cotwp, cotree_filter, tcofold.
  rewrite co_co; eauto with cotcwp cotree order.
  apply Proper_co; eauto with cotcwp order.
  { apply monotone_compose; eauto with cotree order.
    apply monotone_co; eauto with cotcwp. }
  apply equ_arrow; intro a.
  unfold compose.
  revert P f; induction a; intros P f; simpl.
  - unfold atree_cotree_filter. simpl.
    unfold btwp; simpl.
    rewrite co_tfold_bot.
    reflexivity.
  - unfold btwp; simpl.
    unfold atree_cotree_filter; simpl.
    destruct (P a).
    + rewrite co_tfold_leaf; eRauto.
    + rewrite co_tfold_bot; reflexivity.
  - unfold btwp, atree_cotree_filter in *; simpl.
    unfold id, compose in *.
    rewrite co_tfold_node; eRauto.
    { unfold compose; apply equ_eR.
      f_equal; f_equal; apply equ_eR, H. }
    { apply wcontinuous_avg. }
Qed.

Lemma btwp_node {A} (f : A -> eR) (g : bool -> atree bool A) :
  btwp f (anode g) = (btwp f (g false) + btwp f (g true)) / 2.
Proof. reflexivity. Qed.

Lemma btwp_strict {A} (t : atree bool A) :
  btwp (fun _ : A => 0) t = 0.
Proof.
  unfold btwp; induction t; simpl; auto.
  unfold compose; rewrite 2!H; eRauto.
Qed.

Lemma btwlp_costrict {A} (t : atree bool A) :
  btwlp (fun _ : A => 1) t = 1.
Proof.
  unfold btwlp; induction t; simpl; auto.
  unfold compose; rewrite 2!H; eRauto.
  rewrite <- eRplus_combine_fract.
  apply eRplus_half_plus_half.
Qed.

Lemma cotwp_strict {A} :
  cotwp (fun _ : A => 0) = const 0.
Proof.
  symmetry; apply co_unique_ext.
  - apply monotone_btwp.
  - apply continuous_wcontinuous, continuous_const.
  - ext t; rewrite btwp_strict; reflexivity.
Qed.

Lemma cotwlp_costrict {A} :
  cotwlp (fun _ : A => 1) = const 1.
Proof.
  symmetry; apply coop_unique_ext.
  - apply antimonotone_btwlp; intro; reflexivity.
  - apply cocontinuous_const.
  - ext t; rewrite btwlp_costrict; reflexivity.
Qed.

Lemma btwp_cotuple {A B} (t : atree bool (A + B)) (f : A -> eR) (g : B -> eR) :
  btwp (cotuple f g) t = btwp (cotuple f (const 0)) t + btwp (cotuple (const 0) g) t.
Proof.
  revert f g; induction t; intros f g; simpl; eRauto.
  - destruct a; simpl; unfold const; eRauto.
  - rewrite btwp_node.
    rewrite 2!H.
    rewrite 2!btwp_node.
    rewrite <- 5!eRplus_combine_fract.
    set (x := btwp (cotuple f (const 0)) (a false) / 2).
    set (y := btwp (cotuple (const 0) (const 0)) (a false) / 2).
    set (z := btwp (cotuple (const 0) g) (a false) / 2).
    set (w := btwp (cotuple f g) (a true) / 2).
    set (y' := btwp (cotuple f (const 0)) (a true) / 2).
    set (w' := btwp (cotuple (const 0) g) (a true) / 2).
    rewrite <- eRplus_assoc.
    cut (y + w = y' + w').
    { intro Heq; destruct x, y, z, w, y', w';
        compute; auto; inv Heq; apply eR_eq; lra. }
    unfold y, y', w, w'.
    rewrite 2!eRplus_combine_fract.
    replace (cotuple (const 0) (const 0)) with (fun _ : A + B => 0).
    2: { ext ab; destruct ab; reflexivity. }
    rewrite btwp_strict; eRauto.
    rewrite H; reflexivity.
Qed.

Lemma cotwp_cotuple {A B} (t : cotree bool (A + B)) (f : A -> eR) (g : B -> eR) :
  cotwp (cotuple f g) t = cotwp (cotuple f (const 0)) t + cotwp (cotuple (const 0) g) t.
Proof.
  unfold cotwp, co.
  rewrite <- sup_sum.
  2: { apply monotone_chain.
       - apply monotone_btwp.
       - apply chain_ideal. }
  2: { apply monotone_chain.
       - apply monotone_btwp.
       - apply chain_ideal. }
  f_equal; ext i; unfold compose.
  apply btwp_cotuple.
Qed.

Lemma tie_cotree_iid_tie_cotree {A} :
  @tie_cotree_iid A = tie_cotree.
Proof.
  ext ct.
  unfold tie_cotree_iid, tie_cotree, cotree_iter, iter.
  apply cotree_ext, equ_cotree_eq; rewrite sup_apply.
  2: { apply chain_directed, chain_iter_n';
       eauto with order cotree; constructor. }
  apply eq_equ; f_equal; ext i.
  revert ct; induction i; intros t; simpl; auto.
  unfold iid_F; simpl; unfold cotree_iter_F, const; f_equal.
  ext lr; destruct lr; simpl; auto.
  f_equal; destruct u; apply IHi.
Qed.

Lemma btwp_scalar {A} (c : eR) (f : A -> eR) (t : atree bool A) :
  c * btwp f t = btwp (fun x => c * f x) t.
Proof.
  unfold btwp.
  revert c f; induction t; intros c f; simpl; eRauto.
  unfold compose.
  rewrite <- 2!H.
  rewrite eRmult_eRdiv_assoc, eRmult_plus_distr_l; reflexivity.
Qed.

Lemma cotwp_scalar {A} (c : eR) (f : A -> eR) (t : cotree bool A) :
  c * cotwp f t = cotwp (fun x => c * f x) t.
Proof.
  unfold cotwp, co.
  unfold compose.
  rewrite sup_scalar.
  f_equal; ext i.
  apply btwp_scalar.
Qed.

Lemma btwp_sum {A} (f g : A -> eR) (t : atree bool A) :
  btwp (fun a => f a + g a) t = btwp f t + btwp g t.
Proof.
  unfold btwp.
  revert f; induction t; intros f; simpl; eRauto.
  unfold compose.
  rewrite 2!H,  eRplus_combine_fract.
  rewrite <- 2!eRplus_assoc, eRplus_comm4; reflexivity.
Qed.

Lemma cotwp_sum {A} (f g : A -> eR) (t : cotree bool A) :
  cotwp (fun a => f a + g a) t = cotwp f t + cotwp g t.
Proof.
  symmetry.
  set (h := fun t => cotwp f t + cotwp g t).
  replace (cotwp f t + cotwp g t) with (h t) by reflexivity.
  cut (h = cotwp (fun a => f a + g a)).
  { intros ->; reflexivity. }
  apply co_unique_ext.
  - apply monotone_btwp.
  - unfold h.
    apply wcontinuous_sum;
      apply continuous_wcontinuous, continuous_co, monotone_btwp.
  - clear t.
    ext t.
    rewrite btwp_sum.
    unfold compose, h.
    f_equal; apply co_incl'_ext, monotone_btwp.
Qed.

Lemma cotwp_linear {A} (c : eR) (f g : A -> eR) (t : cotree bool A) :
  cotwp (fun a => c * f a + g a) t = c * cotwp f t + cotwp g t.
Proof. rewrite cotwp_sum, cotwp_scalar; reflexivity. Qed.

Lemma monotone_btwp' {A} (f g : A -> eR) (t : atree bool A) :
  f ⊑ g ->
  btwp f t <= btwp g t.
Proof.
  unfold btwp.
  revert f g; induction t; intros f g Hfg; simpl.
  - reflexivity.
  - apply Hfg.
  - unfold compose.
    rewrite <- 2!eRplus_combine_fract.
    apply eRplus_le_compat; apply eRmult_le_compat_r, H; auto.
Qed.

Lemma monotone_btwlp' {A} (f g : A -> eR) (t : atree bool A) :
  f ⊑ g ->
  btwlp f t <= btwlp g t.
Proof.
  unfold btwlp.
  revert f g; induction t; intros f g Hfg; simpl.
  - reflexivity.
  - apply Hfg.
  - unfold compose.
    rewrite <- 2!eRplus_combine_fract.
    apply eRplus_le_compat; apply eRmult_le_compat_r, H; auto.
Qed.

Lemma monotone_cotwp {A} (f g : A -> eR) (t : cotree bool A) :
  f ⊑ g ->
  cotwp f t <= cotwp g t.
Proof.
  intro Hfg.
  apply leq_eRle.
  unfold cotwp.
  apply ge_sup.
  { apply monotone_directed.
    - apply monotone_btwp.
    - apply chain_directed, chain_ideal. }
  intro i; unfold compose.
  apply le_sup with i.
  { apply monotone_directed.
    - apply monotone_btwp.
    - apply chain_directed, chain_ideal. }
  unfold compose.
  apply monotone_btwp'; auto.
Qed.

Lemma monotone_cotwlp {A} (f g : A -> eR) (t : cotree bool A) :
  bounded g 1 ->
  f ⊑ g ->
  cotwlp f t <= cotwlp g t.
Proof.
  intros Hg Hfg.
  apply leq_eRle.
  unfold cotwlp.
  apply le_inf.
  { apply antimonotone_downward_directed.
    - apply antimonotone_btwlp; auto.
    - apply chain_directed, chain_ideal. }
  intro i; unfold compose.
  apply ge_inf with i.
  { apply antimonotone_downward_directed.
    - apply antimonotone_btwlp.
      intro a; etransitivity; eauto; apply Hfg.
    - apply chain_directed, chain_ideal. }
  unfold compose.
  apply monotone_btwlp'; auto.
Qed.

Theorem markov_inequality {A} (f : A -> eR) (a : eR) (t : cotree bool A) :
  a <> 0 ->
  a <> infty ->
  cotwp (fun x => if eRle_dec a (f x) then 1 else 0) t <= cotwp f t / a.
Proof.
  intros Ha Ha'.
  unfold eRdiv.
  apply eRmult_le_div; auto.
  rewrite cotwp_scalar.
  apply monotone_cotwp.
  intro x.
  destr; eRauto.
Qed.

Lemma cotree_bind_iid_chain_ {A} t i :
  cotree_bind (iid_chain_ t i)
    (fun x : unit + A => match x with
                      | inl _ => t
                      | inr b => coleaf (inr b)
                      end) =
    cotree_bind t
      (fun x : unit + A => match x with
                        | inl _ => iid_chain_ t i
                        | inr b => coleaf (inr b)
                        end).
Proof.
  revert t; induction i; intro t; simpl.
  { rewrite cotree_bind_leaf.
    replace (fun x : unit + A => match x with
                              | inl _ => coleaf (inl tt)
                              | inr b => coleaf (inr b)
                              end) with
      (@coleaf bool (unit + A)).
    2: { ext lr; destruct lr as [[]|?]; reflexivity. }
    rewrite cotree_bind_id_r; reflexivity. }
  rewrite IHi.
  rewrite cotree_bind_assoc.
  f_equal.
  ext lr; destruct lr as [[]|a]; auto.
  rewrite cotree_bind_leaf; reflexivity.
Qed.

Lemma cotree_bind_iid_chain_snip {A} t i :
  cotree_bind (iid_chain_ t i)
    (fun x : unit + A =>
       match x with
       | inl _ => snip t
       | inr b => coleaf b
       end) =
    cotree_bind t
      (fun x : unit + A =>
         match x with
         | inl _ => snip (iid_chain_ t i)
         | inr b => coleaf b
         end).
Proof.
  replace (fun x : unit + A => match x with
                            | inl _ => snip t
                            | inr b => coleaf b
                            end) with
    (snip ∘ fun x : unit + A => match x with
                             | inl _ => t
                             | inr b => coleaf (inr b)
                             end).
  2: { unfold compose; ext lr; destruct lr; auto; rewrite snip_leaf; auto. }
  rewrite <- snip_bind.
  replace (fun x : unit + A => match x with
                               | inl _ => snip (iid_chain_ t i)
                               | inr b => coleaf b
                               end) with
    (snip ∘ fun x : unit + A => match x with
                             | inl _ => iid_chain_ t i
                             | inr b => coleaf (inr b)
                             end).
  2: { unfold compose; ext lr; destruct lr; auto; rewrite snip_leaf; auto. }
  rewrite <- snip_bind.
  f_equal.
  apply cotree_bind_iid_chain_.
Qed.

Lemma iid_chain_iter_n {A} (t : cotree bool (unit + A)) :
  iid_chain t = iter_n (iid_F' t) cobot.
Proof.
  ext i; revert t; induction i; intro t.
  { unfold iid_chain; simpl; rewrite snip_leaf; reflexivity. }
  unfold iid_chain in *; simpl.
  unfold compose. unfold iid_F' in *.
  unfold snip in *.
  rewrite <- IHi; clear IHi.
  rewrite cotree_bind_assoc.
  etransitivity.
  2: { apply cotree_bind_iid_chain_snip. }
  f_equal.
  ext lr; destruct lr as [[]|a]; simpl; auto.
  rewrite cotree_bind_leaf; reflexivity.
Qed.

Lemma cotwp_cotuple_const_inl {A} a t :
  cotwp (cotuple (fun _ : unit => a) (fun _ : A => 0)) t =
    cotwp (cotuple (const 1) (const 0)) t * a.
Proof.
  rewrite eRmult_comm, cotwp_scalar.
  f_equal; ext lr; destruct lr as [[]|b]; eRauto.
Qed.

Lemma cowp_iid_chain_geometric_series {A}
  (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cowp f (iid_chain_ t i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  unfold cowp.
  revert f t; induction i; intros f t; simpl.
  { rewrite cotwp_leaf; reflexivity. }
  rewrite <- IHi; clear IHi.
  unfold compose, cotuple, const.
  rewrite cotwp_bind.
  unfold compose.
  replace (fun x : unit + A =>
             cotwp (fun x0 : unit + A => match x0 with
                                      | inl _ => 0
                                      | inr b => f b
                                      end) match x with
               | inl _ => t
               | inr b => coleaf (inr b)
               end) with
    (cotuple (fun _ : unit => cotwp (cotuple (const 0) f) t) f).
  2: { ext lr; destruct lr as [[]|a]; simpl; auto.
       rewrite cotwp_leaf; reflexivity. }
  rewrite cotwp_cotuple.
  rewrite eRplus_comm.
  f_equal.
  replace (fun x : unit + A => match x with
                            | inl _ => 0
                            | inr b => f b
                            end) with
    (cotuple (fun _ : unit => 0) f) by reflexivity.
  revert f t; induction i; intros f t; simpl.
  { eRauto; rewrite cotwp_leaf; reflexivity. }
  rewrite eRmult_comm.
  rewrite eRmult_assoc.
  specialize (IHi f t).
  rewrite eRmult_comm in IHi.
  rewrite <- IHi; clear IHi.
  rewrite cotwp_bind.
  unfold compose.
  rewrite cotwp_scalar.
  f_equal; ext lr; destruct lr as [[]|a]; simpl.
  - apply cotwp_cotuple_const_inl.
  - unfold const; eRauto.
    rewrite cotwp_leaf; reflexivity.
Qed.

Lemma cotwp_iid_chain_geometric_series {A}
  (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iid_chain t i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  unfold iid_chain.
  unfold snip.
  rewrite cotwp_bind.
  unfold cotuple, const, compose.
  replace (fun x : unit + A => cotwp f match x with
                                 | inl _ => cobot
                                 | inr b => coleaf b
                                 end) with
    (cotuple (fun _ : unit => 0) f).
  2: { ext lr; destruct lr as [[]|a]; simpl; auto.
       - rewrite cotwp_bot; reflexivity.
       - rewrite cotwp_leaf; reflexivity. }
  apply cowp_iid_chain_geometric_series.
Qed.

Lemma cotwp_iter_n_iid_F_iid_F' {A} (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iter_n (iid_F t) cobot i) = cotwp f (iter_n (iid_F' t) cobot i).
Proof.
  revert f t; induction i; intros f t; simpl; auto.
Qed.

Corollary cotwp_iter_n_geometric_series {A} (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iter_n (iid_F t) cobot i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  rewrite <- cotwp_iid_chain_geometric_series.
  rewrite cotwp_iter_n_iid_F_iid_F'.
  f_equal; rewrite iid_chain_iter_n; reflexivity.
Qed.

Theorem cotwp_tie_cotree_iid {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  cofail t < 1 -> cotwp f (tie_cotree_iid t) = cowp f t / (1 - cofail t).
Proof.
  intro Hlt.
  unfold tie_cotree_iid.
  unfold cotree_iter.
  unfold iter.
  rewrite continuous_sup_eR; auto with cotcwp.
  2: { apply chain_directed, chain_iter_n'.
       - constructor.
       - apply continuous_monotone, continuous_iid_F. }
  etransitivity.
  2: { apply geometric_series_sup; eRauto. }
  f_equal; ext i.
  unfold compose.
  apply cotwp_iter_n_geometric_series.
Qed.

Lemma btwp_bounded {A} (f : A -> eR) t ub :
  bounded f ub ->
  btwp f t <= ub.
Proof.
  unfold btwp.
  revert f ub; induction t; intros f ub Hf; simpl; eRauto.
  rewrite <- eRplus_combine_fract.
  replace ub with (ub / 2 + ub / 2) by apply eRplus_half_plus_half.
  apply eRplus_le_compat; apply eRle_div, H; auto.
Qed.

Lemma btwp_btwlp_sum_1 {A} (f : A -> eR) t :
  bounded f 1 ->
  btwp f t + btwlp (fun x : A => 1 - f x) t = 1.
Proof.
  unfold btwp, btwlp.
  revert f; induction t; intros f Hf; simpl.
  - eRauto.
  - eRauto.
  - rewrite <- 2!eRplus_combine_fract, <- eRplus_assoc.
    rewrite eRplus_comm4, eRplus_assoc.
    etransitivity.
    2: { apply eRplus_half_plus_half. }
    f_equal; rewrite eRplus_combine_fract; f_equal; apply H; auto.
Qed.

Lemma cotwp_cotwlp_sum_1 {A} (f : A -> eR) (t : cotree bool A) :
  bounded f 1 ->
  cotwp f t + cotwlp (fun x => 1 - f x) t = 1.
Proof.
  intro Hf.
  unfold cotwp, cotwlp.
  unfold co, coop.
  eapply supremum_infimum_sum.
  6: { apply lattice_sup_spec; auto with eR. }
  6: { apply lattice_inf_spec; auto with eR. }
  { apply chain_f_ideal; eauto with cotcwp order. }
  { apply dec_chain_f_ideal, antimonotone_btwlp; intro; eRauto. }
  { intro i; unfold compose. simpl. unfold flip.
    apply btwp_bounded; eauto. }
  { intro i; unfold compose; simpl; unfold flip.
    apply btwlp_bounded; intro; eRauto. }
  intro i; unfold compose.
  apply btwp_btwlp_sum_1; auto.
Qed.

Corollary cofail_cowlp {A} (t : cotree bool (unit + A)) :
  cofail t = 1 - cowlp (const 1) t.
Proof.
  apply eRplus_eq_minus.
  { eRauto. }
  rewrite eRplus_comm.
  unfold cofail, cowpfail.
  etransitivity.
  2: { eapply cotwp_cotwlp_sum_1 with (f := cotuple (const 1) (const 0)).
       intros []; eRauto. }
  f_equal; unfold cowlp; f_equal.
  ext lr; destruct lr as [[]|s]; eRauto.
Qed.

Lemma cotwlp_bounded {A} (t : cotree bool A) (f : A -> eR) :
  bounded f 1 ->
  cotwlp f t <= 1.
Proof.
  intro Hf; apply leq_eRle, lattice_ge_inf with (i:=O); auto with eR.
Qed.

Corollary cowlp_cofail {A} (t : cotree bool (unit + A)) :
  cowlp (const 1) t = 1 - cofail t.
Proof.
  apply eRplus_eq_minus.
  { eRauto. }
  rewrite eRplus_comm.
  apply eRminus_eq_plus.
  { eRauto. }
  - apply cotwlp_bounded; intros [[]|a]; eRauto.
  - apply cofail_cowlp.
Qed.

Lemma cocwp_cotwp_tie_cotree {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  cofail t < 1 ->
  cocwp f t = cotwp f (tie_cotree t).
Proof.
  intro Hlt.
  rewrite <- tie_cotree_iid_tie_cotree.
  rewrite cotwp_tie_cotree_iid; auto.
  unfold cocwp.
  f_equal.
  apply eRplus_eq_minus.
  { eRauto. }
  unfold cofail, cowpfail, cowlp.
  replace (cotuple (const 0) (const 1)) with
    (fun x => 1 - cotuple (fun _ : unit => 1) (fun _ : A => 0) x).
  2: { ext lr; destruct lr; eRauto. }
  apply cotwp_cotwlp_sum_1.
  intros [[]|s]; simpl; eRauto.
Qed.

Corollary cotwp_tie_cotree_iid_wlp {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  0 < cowlp (const 1) t -> cotwp f (tie_cotree_iid t) = cowp f t / cowlp (const 1) t.
Proof.
  intro Hlt; rewrite cowlp_cofail; apply cotwp_tie_cotree_iid.
  rewrite cofail_cowlp.
  apply eRminus_pos_lt; eRauto.
Qed.


(* coq-prelude
 * Copyright (C) 2018 ANSSI
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program. If not, see <http://www.gnu.org/licenses/>.
 *)

From Coq Require Import Setoid.
From Equations Require Import Equations Signature.

From Prelude Require Import Control Equality.

Local Open Scope prelude_scope.
Local Open Scope list_scope.

Add Parametric Morphism
    (a:  Type)
   `{Equality a}
  : cons
    with signature (@equal a _)
                     ==> (@equal (list a) _)
                     ==> (@equal (list a) _)
      as cons_morphism.
Proof.
  intros x y Heqx r q Eqrst.
  constructor.
  exact Heqx.
  cbn in Eqrst.
  exact Eqrst.
Qed.

(* WORK IN PROGRESS *)

Equations list_map {a b:  Type} (f:  a -> b) (l:  list a) : list b :=
list_map _ nil := nil;
list_map f (cons x r) := (f x) :: (list_map f r).

Add Parametric Morphism
    (a b:  Type)
   `{Equality a}
   `{Equality b}
  : list_map
    with signature (@equal (a -> b) _)
                     ==> eq
                     ==> (@equal (list b) _)
      as list_map_morphism.
Proof.
  intros f g Heq s.
  cbn.
  induction s.
  + repeat rewrite list_map_equation_1.
    reflexivity.
  + repeat rewrite list_map_equation_2.
    constructor.
    ++ apply Heq.
    ++ exact IHs.
Qed.

Lemma list_map_nil
      {a b:  Type}
      (f:    a -> b)
  : list_map f nil = nil.
Proof.
 reflexivity.
Qed.

Instance list_Functor
  : Functor list :=
  { map := @list_map
  }.
+ intros a Ha x.
  induction x.
  ++ reflexivity.
  ++ rewrite list_map_equation_2.
     rewrite IHx.
     reflexivity.
+ induction x.
  ++ reflexivity.
  ++ rewrite list_map_equation_2.
     rewrite IHx.
     reflexivity.
Defined.

Definition list_pure
           {a:  Type}
           (x:  a)
  : list a :=
  x :: nil.

Equations concat {a:  Type} (l l':  list a) : list a :=
concat nil l' := l';
concat (cons x r) l' := x :: concat r l'.

Add Parametric Morphism
    (a:  Type)
   `{Equality a}
  : concat
    with signature (@equal (list a) _)
                     ==> (@equal (list a) _)
                     ==> (@equal (list a) _)
      as concat_list_morphism.
Proof.
  induction x.
  + intros y Heq r s Heqr.
    inversion Heq; subst.
    exact Heqr.
  + intros y Heq r s Heqr.
    inversion Heq; subst.
    Search concat.
    repeat rewrite concat_equation_2.
    constructor.
    ++ exact Heq0.
    ++ apply IHx.
       exact Heq'.
       exact Heqr.
Qed.

Lemma concat_nil
      {a:  Type}
      (l:  list a)
  : concat l nil = l.
Proof.
  induction l.
  + reflexivity.
  + rewrite concat_equation_2.
    rewrite IHl.
    reflexivity.
Qed.

Equations list_app {a b:  Type} (f:  list (a -> b)) (l:  list a) : list b :=
list_app (cons f r) l := concat (f <$> l) (list_app r l);
list_app nil _ := nil.

Equations list_app' {a b:  Type} (x:  a) (f:  list (a -> b)) (l:  list a) : list b :=
list_app' x (cons f r) l := concat (list_pure (f x)) (concat (f <$> l) (list_app' x r l));
list_app' _ nil _ := nil.

Lemma list_app_list_app'
      {a b:  Type}
      (lf:   list (a -> b))
      (x:    a)
      (rst:  list a)
  : list_app lf (x :: rst) = list_app' x lf rst.
Proof.
  induction lf.
  + rewrite list_app_equation_1.
    rewrite list_app'_equation_1.
    reflexivity.
  + rewrite list_app_equation_2.
    rewrite list_app'_equation_2.
    rewrite concat_equation_2.
    rewrite concat_equation_1.
    rewrite IHlf.
    cbn.
    rewrite list_map_equation_2.
    rewrite concat_equation_2.
    reflexivity.
Qed.

Lemma list_app_nil
      {a b:  Type}
      (f:    list (a -> b))
  : list_app f nil = nil.
Proof.
  induction f.
  + reflexivity.
  + rewrite list_app_equation_2.
    rewrite concat_equation_1.
    exact IHf.
Qed.

Add Parametric Morphism
    (a b:  Type)
   `{Equality a}
   `{Equality b}
  : list_app
    with signature (@equal (list (a -> b)) _)
                     ==> eq
                     ==> (@equal (list b) _)
      as list_app_morphism.
Proof.
  intros x y Heq.
  induction Heq.
  + intros s.
    repeat rewrite list_app_equation_2.
    rewrite Heq.
    rewrite IHHeq.
    reflexivity.
  + intros s.
    rewrite list_app_equation_1.
    reflexivity.
Qed.

Conjecture list_conjecture_applicative_1
  : forall (a b c:  Type) `{Equality c}
           (u:      list (b -> c))
           (v:      list (a -> b))
           (w:      list a),
    list_app (list_app (list_app (list_pure compose) u) v) w
    == list_app u (list_app v w).

Instance list_Applicative
  : Applicative (list) :=
  { pure   := @list_pure
  ; apply  := @list_app
  }.
Proof.
  + intros a Heq v.
    induction v.
    ++ reflexivity.
    ++ cbn in *.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       rewrite functor_identity.
       reflexivity.
  + apply list_conjecture_applicative_1.
  + intros a b Heq v x.
    rewrite list_app_equation_2.
    rewrite list_app_equation_1.
    rewrite concat_nil.
    cbn.
    rewrite list_map_equation_2.
    rewrite list_map_equation_1.
    reflexivity.
  + intros a b H u y.
    induction u.
    ++ rewrite list_app_equation_1.
       rewrite list_app_nil.
       reflexivity.
    ++ rewrite list_app_equation_2.
       rewrite IHu.
       cbn.
       rewrite list_map_equation_2.
       rewrite concat_equation_2.
       rewrite concat_equation_1.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       cbn.
       rewrite list_map_equation_2.
       reflexivity.
  + intros a b H g x.
    rewrite list_app_equation_2.
    rewrite list_app_equation_1.
    rewrite concat_nil.
    reflexivity.
Defined.