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

- Frederic Blanqui, 2005-02-17
- Adam Koprowski and Hans Zantema, 2007-03
- Joerg Endrullis and Dimitri Hendriks, 2008-07

General definitions and results about relations.
*)

Require Import Setoid Basics Morphisms List.
Require Export Relations.
Require Import Lia.

Require Import LogicUtil.
Require Export RelMidex.

Set Implicit Arguments.

Arguments inclusion {A} R1 R2.
Arguments same_relation {A} R1 R2.
Arguments transp {A} R x y.
Arguments clos_refl_trans {A} R x y.
Arguments clos_trans {A} R x y.
Arguments reflexive {A} R.
Arguments transitive {A} R.
Arguments antisymmetric {A} R.
Arguments symmetric {A} R.
Arguments equiv {A} R.
Arguments union {A} R1 R2 x y.
Arguments lexprod [A B] _ _ _ _.
Arguments symprod [A B] _ _ _ _.

(***********************************************************************)
(** Notations for some relations and operations on relations. *)

Notation rel := relation.

Notation incl := inclusion.
Declare Scope relation_scope.
Infix "<<" := incl (at level 50) : relation_scope.

Notation same := same_relation.
Infix "==" := same (at level 70).

Infix "U" := union (at level 45) : relation_scope.
Notation "x #" := (clos_refl_trans x) (at level 35) : relation_scope.
Notation "x !" := (clos_trans x) (at level 35) : relation_scope.

Open Scope relation_scope.

(***********************************************************************)
(** Properties of [incl]. *)

#[export] Instance incl_refl A : Reflexive (@incl A).

Proof. fo. Qed.

Ltac incl_refl := apply incl_refl.

#[export] Instance incl_trans A : Transitive (@incl A).

Proof. fo. Qed.

Ltac incl_trans S := apply incl_trans with S; try incl_refl.

#[export] Instance incl_same A : Proper (same ==> same ==> impl) (@incl A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Lemma incl_elim A (R S : rel A) : R << S -> forall x y, R x y -> S x y.

Proof. auto. Qed.

Arguments incl_elim [A R S] _ [x y] _.

(***********************************************************************)
(** Properties of [same]. *)

Lemma rel_eq A (R S : rel A) : R == S <-> forall x y, R x y <-> S x y.

Proof. fo. Qed.

#[export] Instance same_equiv A : Equivalence (@same A).

Proof. fo. Qed.

(***********************************************************************)
(** Basic meta-theorems. *)

Lemma eq_incl_refl_rel A (R : rel A) : Reflexive R -> eq << R.

Proof. intros hR x y xy. subst y. apply hR. Qed.

Lemma sym A (R : rel A) x y : Symmetric R -> (R x y <-> R y x).

Proof. split_all. Qed.

(***********************************************************************)
(** Morphisms wrt [incl] and [same]. *)

#[export] Instance refl_same A : Proper (same ==> impl) (@Reflexive A).

Proof. fo. Qed.

#[export] Instance sym_same A : Proper (same ==> impl) (@Symmetric A).

Proof. fo. Qed.

#[export] Instance trans_same A : Proper (same ==> impl) (@Transitive A).

Proof.
  intros R S e h x y z xy yz. rewrite rel_eq in e. rewrite <- e in *.
  apply h with y; hyp.
Qed.

#[export] Instance equiv_same A : Proper (same ==> impl) (@Equivalence A).

Proof. intros R S RS [hr hs ht]. constructor; rewrite <- RS; hyp. Qed.

(***********************************************************************)
(** Properties of [Proper]. *)

Lemma prop2_incl A B C (f : A -> B -> C) :
  Proper (incl --> incl --> incl ==> impl)
         (fun R S T => Proper (R ==> S ==> T) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' hf x x' xx' y y' yy'.
  apply TT'. apply hf; fo.
Qed.

Lemma prop3_incl A B C D (f : A -> B -> C -> D) :
  Proper (incl --> incl --> incl --> incl ==> impl)
         (fun R S T V => Proper (R ==> S ==> T ==> V) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' hf x x' xx' y y' yy' z z' zz'.
  apply VV'. apply hf; fo.
Qed.

Lemma prop4_incl A B C D E (f : A -> B -> C -> D -> E) :
  Proper (incl --> incl --> incl --> incl --> incl ==> impl)
         (fun R S T V W => Proper (R ==> S ==> T ==> V ==> W) f).

Proof.
  intros R R' RR' S S' SS' T T' TT' V V' VV' W W' WW'
         hf x x' xx' y y' yy' z z' zz' a a' aa'.
  apply WW'. apply hf; fo.
Qed.

#[export] Instance prop_rel_same A (E : rel A) :
  Proper (same ==> impl) (Proper (E ==> E ==> impl)).

Proof.
  intros R S [RS SR] h x x' xx' y y' yy' xy.
  apply RS. eapply h. apply xx'. apply yy'. apply SR. hyp.
Qed.

Lemma prop_subrel A (R S : rel A) :
  Equivalence S -> subrelation R S -> Proper (R ==> R ==> impl) S.

Proof.
  intros S_eq RS u u' uu' v v' vv' uv. apply RS in uu'. apply RS in vv'.
  rewrite <- uu', <- vv'. hyp.
Qed.

Lemma prop_rel_sym A B (f : A -> B -> Prop) R S :
  Symmetric R -> Symmetric S
  -> Proper (R ==> S ==> impl) f -> Proper (R ==> S ==> iff) f.

Proof.
  intros R_sym S_sym f_prop x x' xx' y y' yy'. split; intro h.
  eapply f_prop. apply xx'. apply yy'. hyp.
  eapply f_prop. sym. apply xx'. sym. apply yy'. hyp.
Qed.

#[export] Instance equiv_prop A (R : rel A) :
  Transitive R -> Symmetric R -> Proper (R ==> R ==> impl) R.

Proof. intros R_trans R_sym t t' tt' u u' uu' tu. trans t. hyp. trans u; hyp. Qed.

(***********************************************************************)
(** Empty relation. *)

Definition empty_rel {A} : rel A := fun x y => False.

(***********************************************************************)
(** Relation associated to a boolean function. *)

Definition rel_of_bool A (f : A->A->bool) : rel A :=
  fun x y => f x y = true.

(***********************************************************************)
(** Boolean function associated to a decidable relation. *)

Section bool_of_rel.

  Variables (A : Type) (R : rel A) (R_dec : rel_dec R).

  Definition bool_of_rel t u := if R_dec t u then true else false.

  Lemma bool_of_rel_true x y : bool_of_rel x y = true <-> R x y.

  Proof using Type.
    unfold bool_of_rel. split; destruct (R_dec x y).
    auto. discr. refl. tauto.
  Qed.

  Lemma bool_of_rel_false x y : bool_of_rel x y = false <-> ~R x y.

  Proof using Type.
    unfold bool_of_rel. split; destruct (R_dec x y).
    discr. auto. tauto. refl.
  Qed.

  Lemma bool_of_rel_refl x : Reflexive R -> bool_of_rel x x = true.

  Proof.
    intro R_refl. unfold bool_of_rel. destruct (R_dec x x). refl.
    exfalso. apply n. refl.
  Qed.

  Global Instance bool_of_rel_prop :
    Symmetric R -> Transitive R -> Proper (R ==> R ==> Logic.eq) bool_of_rel.

  Proof.
    intros R_sym R_trans x x' xx' y y' yy'. unfold bool_of_rel.
    destruct (R_dec x y); destruct (R_dec x' y'); try refl.
    exfalso. apply n. trans x. hyp. trans y; hyp.
    exfalso. apply n. trans x'. hyp. trans y'; hyp.
  Qed.

End bool_of_rel.

Arguments bool_of_rel_true {A R} _ {x y}.
Arguments bool_of_rel_false {A R} _ {x y}.

(***********************************************************************)
(** Definition of some properties on relations. *)

Definition classic_left_total A B (R : A -> B -> Prop) :=
  forall x, exists y, R x y.

Definition left_total A B (R : A -> B -> Prop) :=
  forall x, {y | R x y}.

Definition functional A B (R : A -> B -> Prop) :=
  forall x y z, R x y -> R x z -> y = z.

Definition finitely_branching A B (R : A -> B -> Prop) :=
  forall x, {l | forall y, R x y <-> In y l}.

Definition irreflexive A (R : rel A) := forall x, ~R x x.

Definition asymmetric A (R : rel A) := forall x y, R x y -> ~R y x.

(** Predicate saying that [f] is an infinite sequence of [R]-steps. *)
Definition IS A (R : rel A) f := forall i, R (f i) (f (S i)).

Definition EIS A (R : rel A) := exists f, IS R f.

Definition NT A (R : rel A) x := exists f, f 0 = x /\ IS R f.

(** Predicate saying that [f] and [g] describe an infinite sequence
  of R-steps modulo E: for all i, f(i) E g(i) R f(i+1). *)
Definition ISMod A (E R : rel A) (f g : nat -> A) :=
  forall i, E (f i) (g i) /\ R (g i) (f (S i)).

(* Called PreOrder in Coq. *)
Definition quasi_ordering A (R : rel A) := reflexive R /\ transitive R.

Definition ordering A (R : rel A) :=
  reflexive R /\ transitive R /\ antisymmetric R.

Definition strict_ordering A (R : rel A) := irreflexive R /\ transitive R.

(***********************************************************************)
(** Strict part. *)

Definition strict_part A (R : rel A) : rel A := fun x y => R x y /\ ~R y x.

(***********************************************************************)
(** Intersection. *)

Definition intersection A (R S : rel A) : rel A := fun x y => R x y /\ S x y.

Lemma intersection_dec A (R S : rel A) (Rdec : rel_dec R) (Sdec : rel_dec S) :
  rel_dec (intersection R S).

Proof.
  intros x y. unfold intersection. case (Rdec x y); case (Sdec x y); intuition.
Defined.

(***********************************************************************)
(** Finitely branching relations. *)

Section finitely_branching.

  Variables (A : Type) (R : rel A) (FB : finitely_branching R).

  Definition sons x := proj1_sig (FB x).

  Lemma in_sons_R : forall x y, In y (sons x) -> R x y.

  Proof. intros x y. exact (proj2 (proj2_sig (FB x) y)). Qed.

  Lemma R_in_sons : forall x y, R x y -> In y (sons x).

  Proof. intros x y. exact (proj1 (proj2_sig (FB x) y)). Qed.

End finitely_branching.

Arguments in_sons_R [A R] _ [x y] _.
Arguments R_in_sons [A R] _ [x y] _.

(***********************************************************************)
(** Equivalence relation associated to a PreOrder. *)

Definition inter_transp A (R : rel A) : rel A := fun x y => R x y /\ R y x.

(*COQ: declaring these Lemma's as Instance's creates problems in
FSetUtil and FGraph *)

Lemma inter_transp_refl A (R : rel A) :
  Reflexive R -> Reflexive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_sym A (R : rel A) : Symmetric (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_trans A (R : rel A) :
  Transitive R -> Transitive (inter_transp R).

Proof. fo. Qed.

Lemma inter_transp_incl A (R : rel A) : inter_transp R << R.

Proof. fo. Qed.

(***********************************************************************)
(** Properties of [IS]. *)

#[export] Instance IS_incl A : Proper (incl ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h i. subst. fo. Qed.

#[export] Instance IS_same A : Proper (same ==> Logic.eq ==> impl) (@IS A).

Proof. intros R S RS f g fg h. subst. fo. Qed.

#[export] Instance EIS_same A : Proper (same ==> impl) (@EIS A).

Proof. intros R S RS h. destruct h as [f h]. exists f. rewrite <- RS. hyp. Qed.

Lemma NT_IS_elt A (R : rel A) f k : IS R f -> NT R (f k).

Proof. intro hf. exists (fun i => f (i+k)). fo. Qed.

Lemma red_NT A (R : rel A) t u : R t u -> NT R u -> NT R t.

Proof.
  intros tu [f [f0 hf]]. subst.
  exists (fun k => match k with 0 => t | S k' => f k' end).
  intuition. intro k. destruct k. hyp. apply hf.
Qed.

(***********************************************************************)
(** Properties of [irreflexive]. *)

#[export] Instance irreflexive_incl A : Proper (incl --> impl) (@irreflexive A).

Proof. fo. Qed.

(***********************************************************************)
(** Monotony. *)

Definition monotone A B (R : rel A) (S : rel B) f :=
  forall x y, R x y -> S (f x) (f y).

Lemma monotone_transp A B (R : rel A) (S : rel B) f :
  monotone R S f -> monotone (transp R) (transp S) f.

Proof. unfold monotone, transp. auto. Qed.

(***********************************************************************)
(** Composition. *)

Definition compose A (R S : rel A) : rel A :=
  fun x y => exists z, R x z /\ S z y.

Infix "@" := compose (at level 40) : relation_scope.

#[export] Instance compose_incl A : Proper (incl ==> incl ==> incl) (@compose A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac comp := apply compose_incl; try incl_refl.

#[export] Instance compose_same A : Proper (same ==> same ==> same) (@compose A).

Proof. fo. Qed.

Definition absorbs_right A (R S : rel A) := R @ S << R.

Definition absorbs_left A (R S : rel A) := S @ R << R.

Lemma comp_assoc A (R S T : rel A) : (R @ S) @ T << R @ (S @ T).

Proof.
  unfold incl. intros. do 4 destruct H. exists x1; split. hyp.
  exists x0; split; hyp.
Qed.

Lemma comp_assoc' A (R S T : rel A) : R @ (S @ T) << (R @ S) @ T.

Proof.
  unfold incl. intros. do 2 destruct H. do 2 destruct H0.
  exists x1; split. exists x0; split; hyp. exact H1.
Qed.

Ltac assoc :=
  match goal with
    | |- (?s @ ?t) @ ?u << _ => incl_trans (s @ (t @ u)); try apply comp_assoc
    | |- ?s @ (?t @ ?u) << _ => incl_trans ((s @ t) @ u); try apply comp_assoc'
    | |- _ << (?s @ ?t) @ ?u => incl_trans (s @ (t @ u)); try apply comp_assoc'
    | |- _ << ?s @ (?t @ ?u) => incl_trans ((s @ t) @ u); try apply comp_assoc
  end.

Lemma absorbs_left_rtc A (R S : rel A) : R @ S << S -> R# @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma absorbs_right_rtc A (R S : rel A) : S @ R << S -> S @ R# << S.

Proof. intros h t v [u [tu uv]]. induction uv; fo. Qed.

(***********************************************************************)
(** Properties of [union]. *)

#[export] Instance union_incl A : Proper (incl ==> incl ==> incl) (@union A).

Proof. fo. Qed.

(*FIXME: try to remove*)
Ltac union := apply union_incl; try incl_refl.

#[export] Instance union_same A : Proper (same ==> same ==> same) (@union A).

Proof. fo. Qed.

Lemma union_commut A (R S : rel A) : R U S == S U R.

Proof. fo. Qed.

Lemma union_assoc A (R S T : rel A) : (R U S) U T == R U (S U T).

Proof. fo. Qed.

Lemma comp_union_l A (R S T : rel A) : (R U S) @ T == (R @ T) U (S @ T).

Proof. fo. Qed.

Lemma comp_union_r A (R S T : rel A) : T @ (R U S) == (T @ R) U (T @ S).

Proof. fo. Qed.

Lemma union_empty_r A (R : rel A) : R U empty_rel == R.

Proof. fo. Qed.

Lemma union_empty_l A (R : rel A) : empty_rel U R == R.

Proof. fo. Qed.

Lemma incl_union_l A (R S T : rel A) : R << S -> R << S U T.

Proof. fo. Qed.

Lemma incl_union_r A (R S T : rel A) : R << T -> R << S U T.

Proof. fo. Qed.

Lemma union_incl_eq A (R R' S : rel A) : R U R' << S <-> R << S /\ R' << S.

Proof. fo. Qed.

(***********************************************************************)
(** Reflexive closure. *)

Definition clos_refl A (R : rel A) : rel A := eq U R.

Notation "x %" := (clos_refl x) (at level 35) : relation_scope.

#[export] Instance rc_incl A : Proper (incl ==> incl) (@clos_refl A).

Proof. fo. Qed.

#[export] Instance rc_same A : Proper (same ==> same) (@clos_refl A).

Proof. fo. Qed.

#[export] Instance rc_refl A (R : rel A) : Reflexive (R%).

Proof. fo. Qed.

#[export] Instance rc_trans A (R : rel A) : Transitive R -> Transitive (R%).

Proof.
  intro. unfold Transitive, clos_refl, union. intros. decomp H0. subst y. hyp.
  decomp H1. subst z. auto. right. apply H with (y := y); hyp.
Qed.

Lemma incl_rc A (R : rel A) : R << R%.

Proof. fo. Qed.

(***********************************************************************)
(** Compatibility closure. *)

Section comp_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive comp_clos (R : rel A) : rel A :=
  | comp_clos_intro u u' v v' : E u u' -> E v v' -> R u' v' -> comp_clos R u v.

  Lemma comp_clos_intro_refl (R : rel A) t u : R t u -> comp_clos R t u.

  Proof. intro tu. eapply comp_clos_intro. refl. refl. hyp. Qed.

  Lemma comp_clos_eq R : same (comp_clos R) (E @ (R @ E)).

  Proof.
    split.
    intros t u tu. inversion_clear tu; subst. ex u'. intuition. ex v'. intuition.
    intros t u [t' [tt' [u' [t'u' u'u]]]]. eapply comp_clos_intro.
    apply tt'. sym. apply u'u. hyp.
  Qed.

  Lemma incl_comp_clos R : R << comp_clos R.

  Proof.
    intros u v uv. apply comp_clos_intro with (u':=u) (v':=v).
    refl. refl. hyp.
  Qed.

  #[global]  Instance comp_clos_incl : Proper (incl ==> incl) comp_clos.

  Proof.
    intros R S RS u v uv. inversion uv; subst.
    apply comp_clos_intro with (u':=u') (v':=v'); fo.
  Qed.

  #[global] Instance comp_clos_same : Proper (same ==> same) comp_clos.

  Proof. intros R S [RS SR]. split. rewrite RS. refl. rewrite SR. refl. Qed.

  Lemma comp_clos_union R S :
    same (comp_clos (R U S)) (comp_clos R U comp_clos S).

  Proof.
    split.
    (* << *)
    induction 1.
    destruct H1 as [h|h]; [left|right];
      (eapply comp_clos_intro; [apply H | apply H0 | hyp]).
    (* >> *)
    intros t u [h|h].
    eapply comp_clos_incl. apply incl_union_l. refl. hyp.
    eapply comp_clos_incl. apply incl_union_r. refl. hyp.
  Qed.

  #[global]  Instance comp_clos_prop R : Proper (E ==> E ==> impl) (comp_clos R).

  Proof.
    intros u u' uu' v v' vv' h. inversion h; subst.
    eapply comp_clos_intro.
    trans u. hyp. apply H.
    trans v. hyp. apply H0.
    hyp.
  Qed.

End comp_clos.

(***********************************************************************)
(** Properties of [clos_trans]. *)

#[export] Instance tc_trans A (R : rel A) : Transitive (R!).

Proof. unfold Transitive. intros. apply t_trans with y; hyp. Qed.

#[export] Instance tc_incl A : Proper (incl ==> incl) (@clos_trans A).

Proof.
  intros R R' H t u H0. elim H0; intros.
  apply t_step. apply H. hyp. trans y; hyp.
Qed.

#[export] Instance tc_same A : Proper (same ==> same) (@clos_trans A).

Proof. intros R S [RS SR]. split; apply tc_incl; hyp. Qed.

Lemma incl_tc A (R S : rel A) : R << S -> R << S!.

Proof. intros. unfold incl. unfold incl in H. intros. apply H in H0. apply t_step. trivial.  Qed.

Lemma trans_tc_incl A (R : rel A) : Transitive R -> R! << R.

Proof.
  unfold transitive, incl. intros. induction H0. hyp.
  apply H with y; hyp.
Qed.

Lemma trans_comp_incl A (R : rel A) : Transitive R -> R @ R << R.

Proof. fo. Qed.

Lemma absorbs_left_tc A (R S : rel A) : R @ S << S -> R! @ S << S.

Proof.
  intro. unfold incl, compose. intros. do 2 destruct H0.
  gen H1. clear H1. elim H0; intros; auto. apply H. exists y0. auto.
Qed.

Lemma tc_absorbs_left A (R S : rel A) : R @ S << S -> R @ S! << S!.

Proof.
  intro. unfold incl. intros. do 2 destruct H0. generalize x0 y H1 H0.
  induction 1; intros. apply t_step. apply H. exists x1; split; hyp.
  trans y0; auto.
Qed.

Lemma trans_intro A (R : rel A) : R @ R << R <-> Transitive R.

Proof.
  split. unfold Transitive. intros. apply H. exists y. intuition.
  intros h x z [y [xy yz]]. apply (h _ _ _ xy yz).
Qed.

Lemma comp_tc_idem A (R : rel A) : R! @ R! << R!.

Proof.
  unfold incl. intros. do 2 destruct H. trans x0; hyp.
Qed.

Lemma tc_min A (R S : rel A) : R << S -> Transitive S -> R! << S.

Proof.
  intros RS Strans. intros x y. induction 1. apply RS. hyp. trans y; hyp.
Qed.

Lemma trans_tc A (R : rel A) : Transitive R -> R! == R.

Proof. intro t. split. apply tc_min. refl. hyp. apply incl_tc. refl. Qed.

Lemma tc_idem A (R : rel A) : R!! == R!.

Proof.
  split. intros x y. induction 1. hyp. trans y; hyp.
  apply incl_tc. refl.
Qed.

Lemma tc_eq A (R S : rel A) : S << R -> R << S! -> R! == S!.

Proof.
  intros SR RSt. split; apply tc_min. hyp. apply tc_trans.
  trans R. hyp. apply incl_tc. refl. apply tc_trans.
Qed.

Lemma tc_incl_trans A (R S : rel A) : Transitive S -> R << S -> R! << S.

Proof. intros S_trans RS. intros t u tu; revert t u tu. induction 1; fo. Qed.

#[export] Instance tc_prop A (E R : rel A) : Reflexive E ->
  Proper (E ==> E ==> impl) R -> Proper (E ==> E ==> impl) (R!).

Proof.
  intros E_refl RE x x' xx' y y' yy' xy. revert x y xy x' xx' y' yy'.
  induction 1; intros x' xx' y' yy'.
  apply t_step. eapply RE. apply xx'. apply yy'. hyp.
  trans y. apply IHxy1. hyp. refl. apply IHxy2. refl. hyp.
Qed.

Lemma tc_prop_iff A (R E : rel A) : Equivalence E
  -> Proper (E ==> E ==> iff) R -> Proper (E ==> E ==> iff) (clos_trans R).

Proof.
  intros E_eq R_prop. apply prop_rel_sym; class. apply tc_prop; class.
  intros x x' xx' y y' yy' xy. rewrite <- xx', <- yy'. hyp.
Qed.

Lemma tc_step_l A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R x z & R! z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion IHxy1; inversion IHxy2; right; solve [eauto |
    inversion H; try inversion H0; exists x0;
    [trivial | constructor 2 with y; auto]].
Qed.

Lemma tc_step_r A (R : rel A) x y :
  R! x y -> R x y \/ (exists2 z, R! x z & R z y).

Proof.
  compute; intro xy; induction xy.
  left; trivial.
  inversion_clear IHxy1; inversion_clear IHxy2; right;
    solve [eauto | inversion H0; exists x0;
    [constructor 2 with y; auto | trivial]].
Qed.

Lemma tc_transp A (R : rel A) : transp (R!) == (transp R)!.

Proof.
  intros; split; compute.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
  induction 1.
  constructor; trivial.
  constructor 2 with y; auto.
Qed.

(***********************************************************************)
(** Symmetric closure of a relation. *)

Section clos_sym.

  Variable (A : Type) (R : rel A).

  Inductive clos_sym : rel A :=
  | s_step : forall x y, R x y -> clos_sym x y
  | s_sym : forall x y, clos_sym y x -> clos_sym x y.

#[global] Instance sc_sym : Symmetric clos_sym.

  Proof. intros x y xy. apply s_sym. hyp. Qed.

End clos_sym.

(***********************************************************************)
(** Reflexive, transitive and symmetric closure of a relation. *)

Section clos_equiv.

  Variable (A : Type) (R : rel A).

  Inductive clos_equiv : rel A :=
  | e_step : forall x y, R x y -> clos_equiv x y
  | e_refl : forall x, clos_equiv x x
  | e_trans : forall x y z, clos_equiv x y -> clos_equiv y z -> clos_equiv x z
  | e_sym : forall x y, clos_equiv x y -> clos_equiv y x.

  #[global] Instance ec_equiv : Equivalence clos_equiv.

  Proof. exact (Build_Equivalence _ e_refl e_sym e_trans). Qed.

End clos_equiv.

#[export] Instance ec_incl A : Proper (incl ==> incl) (@clos_equiv A).

Proof.
  intros R S RS x y; revert x y; induction 1.
  apply e_step. fo. refl. trans y; fo. sym. fo.
Qed.

Lemma ec_min A (R S : rel A) : Equivalence S -> R << S -> clos_equiv R << S.

Proof.
  intros S_eq RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp. hyp.
Qed.

(***********************************************************************)
(** Properties of [clos_refl_trans]. *)

#[export] Instance rtc_refl A (R : rel A) : Reflexive (R#).

Proof. unfold Reflexive. apply rt_refl. Qed.

#[export] Instance rtc_trans A (R : rel A) : Transitive (R#).

Proof. unfold Transitive. intros. eapply rt_trans. apply H. hyp. Qed.

#[export] Instance rtc_incl A : Proper (incl ==> incl) (@clos_refl_trans A).

Proof.
  intro. unfold incl. intros. elim H0; intros.
  apply rt_step. apply H. hyp. refl. trans y1; hyp.
Qed.

#[export] Instance rtc_same A : Proper (same ==> same) (@clos_refl_trans A).

Proof. intros R S [RS SR]. split; apply rtc_incl; hyp. Qed.

Lemma incl_rtc A (R : rel A) : R << R#.

Proof. unfold inclusion. intros. Print clos_refl_trans. apply rt_step. trivial. Qed.

Lemma tc_incl_rtc A (R : rel A) : R! << R#.

Proof. induction 1. apply rt_step. hyp. trans y; hyp. Qed.

Lemma tc_split A (R : rel A) : R! << R @ R#.

Proof.
  unfold incl. induction 1. exists y. split. hyp. refl.
  destruct IHclos_trans1. destruct H1. exists x0. split. hyp.
  trans y. hyp. apply incl_elim with (R:=R!). apply tc_incl_rtc. hyp.
Qed.

Lemma rc_incl_rtc A (R : rel A) : R% << R#.

Proof.
  unfold incl, clos_refl. intros. destruct H.
  subst y. refl. apply rt_step. exact H.
Qed.

Lemma rtc_split A (R : rel A) : R# << eq U R!.

Proof.
  unfold incl, union. intros. elim H.
  intros. right. apply t_step. hyp.
  intro. left. refl.
  intros. destruct H1; destruct H3.
  left. trans y0; hyp.
  subst y0. right. hyp.
  subst y0. right. hyp.
  right. trans y0; hyp.
Qed.

Lemma rtc_split_eq A (R : rel A) : R# == eq U R!.

Proof.
  split. apply rtc_split. rewrite union_incl_eq. split.
  intros x y h. subst. refl. apply tc_incl_rtc.
Qed.

Lemma rtc_split2 A (R : rel A) : R# << eq U R @ R#.

Proof.
  unfold incl, union. intros. elim H; clear H x y; intros.
  right. exists y; split. exact H. refl. auto. destruct H0.
  subst y. destruct H2. auto. destruct H0. right. exists x0. auto.
  do 2 destruct H0. right. exists x0. split. exact H0.
  trans y; auto.
Qed.

Lemma tc_split_inv A (R : rel A) : R# @ R << R!.

Proof.
  intros x y RRxy. destruct RRxy as [z [Rxz Rzy]].
  destruct (rtc_split Rxz).
  rewrite H. intuition.
  constructor 2 with z. hyp.
  constructor 1. hyp.
Qed.

Lemma tc_merge A (R : rel A) : R @ R# << R!.

Proof.
  unfold incl. intros. destruct H. destruct H.
  ded (rtc_split H0). destruct H1; subst.
  apply t_step; hyp. trans x0. apply t_step. hyp. hyp.
Qed.

Lemma rtc_transp A (R : rel A) : transp (R#) << (transp R)#.

Proof.
  unfold incl. induction 1. apply rt_step. hyp. refl. trans y; hyp.
Qed.

Lemma incl_rtc_rtc A (R S : rel A) : R << S# -> R# << S#.

Proof. unfold incl. induction 2. apply H. hyp. refl. trans y; hyp. Qed.

Lemma comp_rtc_idem A (R : rel A) : R# @ R# << R#.

Proof. unfold incl. intros. do 2 destruct H. trans x0; hyp. Qed.

Lemma trans_rtc_incl A (R : rel A) : Reflexive R -> Transitive R -> R# << R.

Proof. intros R_refl R_trans x y. induction 1. hyp. refl. trans y; hyp. Qed.

Lemma rtc_invol A (R : rel A) : R # # == R #.

Proof.
  split. intros x y. induction 1. hyp. refl. trans y; hyp. apply incl_rtc.
Qed.

Lemma rtc_intro_seq A (R : rel A) f i : forall j, i <= j ->
  (forall k, i <= k < j -> R (f k) (f (1+k))) -> R# (f i) (f j).

Proof.
  cut (forall n, (forall k, i <= k < i + n -> R (f k) (f (1+k))) ->
    R# (f i) (f (n+i))).
  intros h j ij hij. assert (j = (j-i) + i). lia.
  rewrite H. apply h.
  intros k hk. apply hij. lia.
  induction n; intro h. refl. trans (f (n+i)).
  apply IHn. intros k hk. apply h. lia.
  apply rt_step. apply h. lia.
Qed.

Lemma rtc_min A (R S : rel A) : PreOrder S -> R << S -> R# << S.

Proof.
  intros S_PO RS. intros u v; revert u v; induction 1.
  fo. refl. trans y; hyp.
Qed.

#[export] Instance rtc_sym A (R : rel A) : Symmetric R -> Symmetric (R#).

Proof.
  intros R_sym x; revert x; induction 1.
  apply rt_step. hyp. refl. trans y; hyp.
Qed.

(***********************************************************************)
(** Quasi-ordering closure. *)

Section qo_clos.

  Variables (A : Type) (E : rel A) (E_eq : Equivalence E).

  Inductive qo_clos (R : rel A) : rel A :=
  | qo_step : R << qo_clos R
  | qo_refl : E << qo_clos R
  | qo_trans : Transitive (qo_clos R).

  Variable R : rel A.

  #[global] Instance qo_clos_preorder : PreOrder (qo_clos R).

  Proof. split. intro x. apply qo_refl. refl. apply qo_trans. Qed.

  Variable R_prop : Proper (E ==> E ==> impl) R.

  #[global]  Instance qo_clos_prop : Proper (E ==> E ==> impl) (qo_clos R).

  Proof.
    intros x x' xx' y y' yy' h. revert x y h x' xx' y' yy'.
    induction 1; intros x' xx' y' yy'.
    apply qo_step. rewrite <- xx', <- yy'. hyp.
    apply qo_refl. rewrite <- xx', <- yy'. hyp.
    trans y. apply IHh1. hyp. refl. apply IHh2. refl. hyp.
  Qed.

  (*COQ: if removed, Coq fails in LComp*)
  #[global] Instance qo_clos_prop_iff : Proper (E ==> E ==> iff) (qo_clos R).

  Proof. apply prop_rel_sym; class. Qed.

  Lemma qo_clos_inv : forall t u,
      qo_clos R t u -> E t u \/ exists v, R t v /\ qo_clos R v u.

  Proof.
    induction 1.
    right. ex y. intuition. auto.
    destruct IHqo_clos1 as [h1|[a [i1 i2]]];
      destruct IHqo_clos2 as [h2|[b [j1 j2]]].
    left. trans y; hyp.
    right. ex b. rewrite h1. auto.
    right. ex a. rewrite <- h2. auto.
    right. ex a. intuition. trans b. trans y. hyp. apply qo_step. hyp. hyp.
  Qed.

End qo_clos.

(***********************************************************************)
(** Properties of [transp]. *)

#[export] Instance transp_incl A : Proper (incl ==> incl) (@transp A).

Proof. fo. Qed.

#[export] Instance transp_same A : Proper (same ==> same) (@transp A).

Proof. fo. Qed.

(*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

Lemma transp_refl A (R : rel A) : Reflexive R -> Reflexive (transp R).

Proof. auto. Qed.

Lemma transp_trans A (R : rel A) : Transitive R -> Transitive (transp R).

Proof. fo. Qed.

Lemma transp_sym A (R : rel A) : Symmetric R -> Symmetric (transp R).

Proof. fo. Qed.

Lemma transp_invol A (R : rel A) : transp (transp R) == R.

Proof. fo. Qed.

Lemma transp_union A (R S : rel A) : transp (R U S) == transp R U transp S.

Proof. fo. Qed.

(***********************************************************************)
(** Relations between closures, union and composition. *)

Lemma rtc_comp_permut A (R S : rel A) : R# @ (R# @ S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split2 H0). destruct H1.
  subst x0. exists x; split. refl. exact H.
  do 4 destruct H1. exists y; split. trans x1.
  apply rt_step. exists x2; split. trans x0; hyp.
  hyp. hyp. refl.
Qed.

Lemma rtc_union A (R S : rel A) : (R U S)# << (R# @ S)# @ R#.

Proof.
  unfold incl. intros. elim H; intros.
  (* step *)
  destruct H0. exists x0; split. refl. apply rt_step. exact H0.
  exists y0; split. apply rt_step. exists x0; split. refl. exact H0.
  refl.
  (* refl *)
  exists x0; split; refl.
  (* trans *)
  do 2 destruct H1. do 2 destruct H3.
  assert (h : ((R# @ S)# @ clos_refl_trans R) x1 x2).
  apply incl_elim with (R := (R# @ clos_refl_trans (R# @ S))).
  apply rtc_comp_permut. exists y0; split; hyp.
  destruct h. destruct H6. exists x3; split.
  trans x1; hyp. trans x2; hyp.
Qed.

Lemma rtc_comp A (R S : rel A) : R# @ S << S U R! @ S.

Proof.
  unfold incl. intros. do 2 destruct H. ded (rtc_split H). destruct H1.
  subst x0. left. exact H0. right. exists x0; split; hyp.
Qed.

Lemma union_fact A (R S : rel A) : R U R @ S << R @ S%.

Proof.
  unfold incl. intros. destruct H.
  exists y; split; unfold clos_refl, union; auto.
  do 2 destruct H. exists x0; split; unfold clos_refl, union; auto.
Qed.

Lemma union_fact2 A (R S : rel A) : R @ S U R << R @ S%.

Proof. incl_trans (R U R @ S). apply union_commut. apply union_fact. Qed.

Lemma incl_rc_rtc A (R S : rel A) : R << S! -> R% << S#.

Proof.
  intro. unfold incl. intros. destruct H0. subst y. refl.
  apply incl_elim with (R := S!). apply tc_incl_rtc. apply H. exact H0.
Qed.

Lemma incl_tc_rtc A (R S : rel A) : R << S# -> R! << S#.

Proof. intro. unfold incl. induction 1. apply H. hyp. trans y; hyp. Qed.

Lemma rtc_comp_modulo A (R S : rel A) : R# @ (R# @ S)! << (R# @ S)!.

Proof.
  unfold incl. intros. do 2 destruct H.
  ded (tc_split H0). do 2 destruct H1. do 2 destruct H1.
  ded (rtc_split H2). destruct H4. subst x1.
  apply t_step. exists x2. intuition. trans x0; hyp.
  trans x1. apply t_step. exists x2. intuition.
  trans x0; hyp. exact H4.
Qed.

Lemma tc_union A (R S : rel A) : (R U S)! << R! U (R# @ S)! @ R#.

Proof.
  unfold incl. induction 1. destruct H. left. apply t_step. exact H.
  right. exists y. intuition. apply t_step. exists x. intuition.
  destruct IHclos_trans1. destruct IHclos_trans2.
  left. trans y; hyp.
  right. do 2 destruct H2. exists x0. intuition.
  apply rtc_comp_modulo. exists y. intuition. apply tc_incl_rtc. exact H1.
  right. do 2 destruct H1. destruct IHclos_trans2. exists x0.
  intuition. trans y. exact H2. apply tc_incl_rtc. exact H3.
  do 2 destruct H3. exists x1. intuition. trans x0. exact H1.
  apply rtc_comp_modulo. exists y. intuition.
Qed.

(***********************************************************************)
(** Commutation properties. *)

Section commut.

  Variables (A : Type) (R S : rel A) (commut : R @ S << S @ R).

  Lemma commut_rtc : R# @ S << S @ R#.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x x0 H y H0.
    clear H0 y H x0 x. induction 1; intros.
    assert ((S @ R) x y0). apply commut. exists y. intuition.
    do 2 destruct H1. exists x0. intuition.
    exists y. intuition.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    ded (IHclos_refl_trans1 _ H2). do 2 destruct H4.
    exists x1. intuition. trans x0; hyp.
  Qed.

  Lemma commut_rtc_inv : R @ S# << S# @ R.

  Proof.
    unfold incl. intros. do 2 destruct H. generalize x0 y H0 x H.
    clear H x x0 H0 y. induction 1; intros.
    assert ((S @ R) x0 y). apply commut. exists x. intuition.
    do 2 destruct H1. exists x1. intuition.
    exists x0. intuition.
    ded (IHclos_refl_trans1 _ H). do 2 destruct H0.
    ded (IHclos_refl_trans2 _ H1). do 2 destruct H2.
    exists x2. intuition. apply rtc_trans with x1; hyp.
  Qed.

  Lemma commut_tc : R! @ S << S @ R!.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj1 Hxy)) as [z' Hz'].
    assert (SE : (S @ R#) z' y). apply commut_rtc. exists z. intuition.
    destruct SE as [x' Rx'].
    assert (SRx : (S @ R) x x'). apply commut. exists z'. intuition.
    destruct SRx as [y' Sy']. exists y'. split. intuition.
    apply tc_merge. exists x'. intuition.
  Qed.

  Lemma commut_tc_inv : R @ S! << S! @ R.

  Proof.
    intros x y H. destruct H as [z Hxy].
    destruct (tc_split (proj2 Hxy)) as [z' Hz'].
    assert (SRx : (S @ R) x z'). apply commut. exists z. intuition.
    destruct SRx as [y' Sy'].
    assert (SE : (S# @ R) y' y). apply commut_rtc_inv. exists z'. intuition.
    destruct SE as [x' Sx']. exists x'. split; try intuition.
    apply tc_merge. exists y'. intuition.
  Qed.

  Lemma commut_comp T : R @ (S @ T) << (S @ R) @ T.

  Proof. rewrite comp_assoc', commut. refl. Qed.

  Lemma comp_incl_assoc T V : R @ S << T -> R @ (S @ V) << T @ V.

  Proof. intro h. rewrite comp_assoc', h. refl. Qed.

End commut.

(***********************************************************************)
(** Inverse image. *)

Section inverse_image.

  Variables (A B : Type) (R : rel B) (f : A->B).

  Definition Rof : rel A := fun a a' => R (f a) (f a').

  (*COQ: declaring these lemmas as Global Instance makes Coq loop
  later in some other files *)

  Lemma Rof_refl : Reflexive R -> Reflexive Rof.

  Proof. fo. Qed.

  Lemma Rof_trans : Transitive R -> Transitive Rof.

  Proof. fo. Qed.

  Lemma Rof_sym : Symmetric R -> Symmetric Rof.

  Proof. fo. Qed.

  Lemma Rof_preorder : PreOrder R -> PreOrder Rof.

  Proof. fo. Qed.

  Lemma Rof_equiv : Equivalence R -> Equivalence Rof.

  Proof. fo. Qed.

  Variable F : A -> B -> Prop.

  Definition RoF : rel A :=
    fun a a' => exists b', F a' b' /\ forall b, F a b -> R b b'.

End inverse_image.

#[export] Instance Rof_incl A B : Proper (incl ==> Logic.eq ==> incl) (@Rof A B).

Proof. intros R S RS f g fg. subst g. fo. Qed.

(***********************************************************************)
(** Alternative definition of the transitive closure, more convenient
for some inductive proofs. *)

Inductive clos_trans1 A (R : rel A) : rel A :=
| t1_step : forall x y, R x y -> clos_trans1 R x y
| t1_trans : forall x y z, R x y -> clos_trans1 R y z -> clos_trans1 R x z.

Notation "x !1" := (clos_trans1 x) (at level 35) : relation_scope.

#[export] Instance tc1_trans A (R : rel A) : Transitive (R!1).

Proof.
  induction 1; intro H1.
  exact (t1_trans x H H1).
  exact (t1_trans x H (IHclos_trans1 H1)).
Qed.

Lemma tc1_eq A (R : rel A) x y : R!1 x y <-> R! x y.

Proof.
  split; induction 1.
  apply t_step. hyp. trans y. apply t_step. hyp. hyp.
  apply t1_step. hyp. trans y; hyp.
Qed.

(***********************************************************************)
(** Alternative definition of the reflexive and transitive closure,
more convenient for some inductive proofs. *)

Inductive clos_refl_trans1 A (R : rel A) : rel A :=
| rt1_refl : forall x, clos_refl_trans1 R x x
| rt1_trans : forall x y z,
  R x y -> clos_refl_trans1 R y z -> clos_refl_trans1 R x z.

Notation "x #1" := (clos_refl_trans1 x) (at level 9) : relation_scope.

#[export] Instance rtc1_preorder A (R : rel A) : PreOrder (R#1).

Proof.
  split; intro x. apply rt1_refl.
  induction 1; intro H1. hyp.
  exact (rt1_trans x H (IHclos_refl_trans1 H1)).
Qed.

Lemma rtc1_eq A (R : rel A) x y : R#1 x y <-> R# x y.

Proof.
  split; induction 1.
  refl. trans y. apply rt_step. hyp. hyp.
  eapply rt1_trans. apply H. refl. refl. trans y; hyp.
Qed.

Lemma tc1_incl_rtc1 A (R : rel A) : R!1 << R#1.

Proof.
  induction 1.
  eapply rt1_trans. apply H. refl.
  eapply rt1_trans. apply H. hyp.
Qed.

Lemma rtc1_union A (R S : rel A) : (R U S)#1 << (S#1 @ R)#1 @ S#1.

Proof.
  intros x y xRSy. induction xRSy as [ | x y z xRSy yRSz].
  exists x. split; refl.
  destruct IHyRSz as [m [ym mz]].
  destruct ym as [m | m n o mn no].
  induction xRSy as [xRy | xSy].
  exists m. split; trivial. apply rt1_trans with m.
  exists x. split; trivial. refl. refl.
  exists x. split. refl. apply rt1_trans with m; trivial.
  exists o. split; trivial.
  induction xRSy as [xRy | xSy].
  apply rt1_trans with m.
  exists x. split. refl. hyp.
  apply rtc1_preorder with n; trivial.
  apply rt1_trans with n; trivial. refl.
  apply rt1_trans with n.
  destruct mn as [q [mq qn]]. exists q. split; trivial.
  apply rt1_trans with m; hyp. hyp.
Qed.

Lemma union_rel_rt1_left A (R S : rel A) : R#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. left. hyp. hyp.
Qed.

Lemma union_rel_rt1_right A (R S : rel A) : S#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rt1_trans with y. right. hyp. hyp.
Qed.

Lemma incl_rt1_union_union A (R S : rel A) : (R!1 U S!1)#1 << (R U S)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  apply union_rel_rt1_right. apply tc1_incl_rtc1. hyp.
Qed.

Lemma incl_union_rt1_union A (R S : rel A) : (R U S)#1 << (R!1 U S!1)#1.

Proof.
  intros x y xRy. induction xRy. refl.
  apply rtc1_preorder with y; trivial.
  destruct H.
  apply union_rel_rt1_left. apply rt1_trans with y.
  apply t1_step. hyp. refl.
  apply union_rel_rt1_right. apply rt1_trans with y.
  apply t1_step. hyp. refl.
Qed.

Lemma comm_s_rt1 A (R S : rel A) :
  S@(R!1) << (R!1)@(S!1) -> (S!1)@(R!1) << (R!1)@(S!1).

Proof.
  intros comm x y [z [H1 H2]].
  induction H1 as [x z H | x y' z H H0 IH].
  apply comm.
  exists z; split; hyp.
  assert (H1 := IH H2); clear IH H2.
  destruct H1 as [u [H2 H3]].
  assert ((R!1 @ S!1) x u).
  apply comm. exists y'; split; hyp.
  destruct H1 as [m [xRm mSu]].
  exists m; split. hyp.
  exact (tc1_trans mSu H3).
Qed.

Lemma comm_s_r A (R S : rel A) :
  S@R << (R!1)@(S#1) -> (R U S)#1 @ R @ (R U S)#1 << (R!1) @ (R U S)#1.

Proof.
  intros comm x y [z2 [[z1 [xRSz1 z1Rz2]] z2RSy]].
  induction xRSz1 as [ | m n z1 mRSn nRSz1 IH].
  exists z2. split. apply t1_step. hyp. hyp.
  (* m RUS n RUS# z1 R z2 RUS# y *)
  assert (((R!1) @ (R U S)#1) n y) as mRedy. apply IH. hyp.
  (* m RUS n R!1@RUS#1 y *)
  clear nRSz1 z1Rz2 z2RSy IH z1 z2.
  destruct mRedy as [o [nRo oRSy]].
  (* m RUS n R!1 o RUS#1 y *)
  induction mRSn.
  (* m R n *)
  exists o. split; auto. apply t1_trans with n; hyp.
  (* m S n *)
  destruct nRo as [o p oRp | o p q oRp pRq ];

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp. hyp.

  assert (((R!1)@(S#1)) m p) as mRedp. apply comm; exists o; split; hyp.
  destruct mRedp as [x [mRx xSp]].
  exists x. split. hyp. hyp.
  destruct mRedp as [n [mRn sSp]].
  exists n; split. hyp.
  apply rtc1_preorder with q.
  apply rtc1_preorder with p.
  apply union_rel_rt1_right. hyp.
  apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.
  hyp.
Qed.

(***********************************************************************)
(** Extension to [option A] of a relation on [A] so that it is
reflexive on [None]. *)

Section opt_r.

  Variables (A : Type) (R : rel A).

  Inductive opt_r : rel (option A) :=
  | opt_r_None : opt_r None None
  | opt_r_Some : forall a b, R a b -> opt_r (Some a) (Some b).

  #[global]  Instance opt_r_refl : Reflexive R -> Reflexive opt_r.

  Proof. intros h [x|]. apply opt_r_Some. refl. apply opt_r_None. Qed.

  #[global]  Instance opt_r_sym : Symmetric R -> Symmetric opt_r.

  Proof.
    intros h x y xy. inversion xy; subst. hyp. apply opt_r_Some. sym. hyp.
  Qed.

  #[global]  Instance opt_r_trans : Transitive R -> Transitive opt_r.

  Proof.
    intros h x y z xy yz. inversion xy; inversion yz; subst; try discr.
    apply opt_r_None. inversion H3; subst. apply opt_r_Some. trans b; hyp.
  Qed.

  #[global] Instance Some_prop : Proper (R ==> opt_r) (@Some A).

  Proof. intros x y xy. apply opt_r_Some. hyp. Qed.

End opt_r.

(****************************************************************************)
(** Extension of a relation on [A] to [option A] so that it is
irreflexive on [None]. *)

Section opt.

  Variables (A : Type) (R : rel A).

  Inductive opt : rel (option A) :=
  | opt_intro : forall x y, R x y -> opt (Some x) (Some y).

  Global Instance opt_trans : Transitive R -> Transitive opt.

  Proof.
    intros R_trans x y z xy yz. inversion xy; inversion yz; clear xy yz; subst.
    inversion H3; clear H3; subst. apply opt_intro. trans y0; hyp.
  Qed.

  Global Instance opt_sym : Symmetric R -> Symmetric opt.

  Proof.
    intros R_sym x y xy. inversion xy; clear xy; subst. apply opt_intro. hyp.
  Qed.

  Global Instance opt_opt_r E : Proper (E ==> E ==> impl) R ->
    Proper (opt_r E ==> opt_r E ==> impl) opt.

  Proof.
    intros R_E x x' xx' y y' yy' xy.
    inversion xy; inversion xx'; inversion yy'; clear xy xx' yy'; subst;
      try discr. inversion H6; inversion H3; clear H6 H3; subst.
    apply opt_intro. eapply R_E. apply H2. apply H5. hyp.
  Qed.

  Lemma opt_absorbs_right_opt_r E : R @ E << R -> opt @ opt_r E << opt.

  Proof.
    intros RE x z [y [xy yz]].
    inversion xy; clear xy; subst. inversion yz; clear yz; subst.
    apply opt_intro. apply RE. exists y0. fo.
  Qed.

  Lemma opt_absorbs_left_opt_r E : E @ R << R -> opt_r E @ opt << opt.

  Proof.
    intros ER x z [y [xy yz]].
    inversion yz; clear yz; subst. inversion xy; clear xy; subst.
    apply opt_intro. apply ER. exists x0. fo.
  Qed.

End opt.

#[export] Instance opt_incl A : Proper (incl ==> incl) (@opt A).

Proof.
  intros R S RS x y xy. inversion xy; clear xy; subst. apply opt_intro. fo.
Qed.

#[export] Instance opt_prop A (E1 E2 R : rel A) :
  Proper (E1 ==> E2 ==> impl) R -> Proper (opt E1 ==> opt E2 ==> impl) (opt R).

Proof.
  intros h x x' xx' y y' yy' xy. inversion xx'; clear xx'; subst.
  inversion yy'; clear yy'; subst. inversion xy; clear xy; subst.
  apply opt_intro. eapply h. apply H. apply H0. hyp.
Qed.

Lemma opt_absorbs_right A (R E : rel A) :
  R @ E << R -> opt R @ opt E << opt R.

Proof.
  intros RE x z [y [xy yz]].
  inversion xy; clear xy; subst. inversion yz; clear yz; subst.
  apply opt_intro. apply RE. exists y0. fo.
Qed.

Lemma opt_absorbs_left A (R E : rel A) :
  E @ R << R -> opt E @ opt R << opt R.

Proof.
  intros ER x z [y [xy yz]].
  inversion yz; clear yz; subst. inversion xy; clear xy; subst.
  apply opt_intro. apply ER. exists x0. fo.
Qed.

(***********************************************************************)
(** Restriction of a relation to some set. *)

Section restrict.

  Variables (A : Type) (P : A -> Prop) (R : rel A).

  Definition restrict : rel A := fun x y => P x /\ R x y.

  #[global]  Instance restrict_prop E :
    Proper (E ==> impl) P -> Proper (E ==> E ==> impl) R ->
    Proper (E ==> E ==> impl) restrict.

  Proof.
    intros PE RE x x' xx' y y' yy' [hxy xy]. split.
    rewrite <- xx'. hyp. eapply RE. apply xx'. apply yy'. hyp.
  Qed.

End restrict.

Lemma restrict_union A (P : A -> Prop) R S :
  restrict P (R U S) == restrict P R U restrict P S.

Proof. fo. Qed.


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

Require Import tree proof.
Require Import formula sequent_rules.

Require Import relevant_HR relevant_LR2 relevant_LR2_dec relevant_equiv.

Require Import mini_HI mini_LI2 mini_LI2_dec mini_equiv.

Set Implicit Arguments.

(* Then we convert it to HR using proof transformation algorithms *)

Corollary HR_decider f : HR_proof f + (HR_proof f -> False).
Proof.
  destruct (LR2_decider (nil,f)) as [ (t & Ht) | H ];
    [ left | right ].

  apply LR2_HR.
  exists (tree_ht t), t; split; auto; red; auto.

  intros H1; apply HR_LR2 in H1; revert H1.
  intros (t & Ht); apply (H t), Ht.
Qed.

Print HR_proof.
Check HR_decider.
Print Assumptions HR_decider.

(* Extraction "hr_decider.ml" HR_decider. *)

Corollary HI_decider f : HI_proof f + (HI_proof f -> False).
Proof.
  destruct (LI2_decider (nil,f)) as [ (t & Ht) | H ];
    [ left | right ].

  apply LI2_HI.
  exists (tree_ht t), t; split; auto; red; auto.

  intros H1; apply HI_LI2 in H1; revert H1.
  intros (t & Ht); apply (H t), Ht.
Qed.

Print HI_proof.
Check HI_decider.
Print Assumptions HI_decider.


(*
Copyright © 2008 Russell O’Connor

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

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

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.logic.Classic.
Require Export CoRN.metric2.Metric.
Require Import CoRN.metric2.Classification.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.model.totalorder.QposMinMax.

Local Open Scope Q_scope.

Section HausdorffMetric.

(**
* Hausdorff Metric

This module defines the Hausdorff metric on the subsets of a
metric space X. Subsets are defined as predicates X -> Prop here.
The Hausdorff distance between unbounded subsets is often infinite,
which is accepted by our definition of a metric via the ball propositions.
To get a separated metric we have to restrict to closed subsets of X,
so that when the Hausdorff distance between A and B is zero,
then A and B are subsets of each other (equality of subsets).
One can still compute the Hausdorff distance between non-closed
subsets, it is equal to the distance between the closures of the subsets.
*)

Variable X : MetricSpace.

(** This is the (weak) hemiMetric, which makes an asymmetric metric.
We make use of the classical quantifer in this definition, so that
pairs of points {x,y} are compact subsets.
*)
Definition hemiMetric (e:Q) (A B: X -> Prop) :=
 forall x:X, A x ->
 existsC X (fun (y:X) => B y /\ ball e x y).

(** This (weak) metric, makes the full symmetric metric. *)
Definition hausdorffBall (e:Q) (A B: X -> Prop) :=
 0 <= e /\ hemiMetric e A B /\ hemiMetric e B A.

Lemma hemiMetric_wd1 : forall (e0 e1:Q) A B,
 (e0 == e1) -> hemiMetric e0 A B -> hemiMetric e1 A B.
Proof.
 intros e0 e1 A B He H x Hx.
 destruct (H x Hx) as [HG | y [Hy Hxy]] using existsC_ind.
  apply existsC_stable; assumption.
 apply existsWeaken.
 exists y. split. exact Hy.
 unfold QposEq in He. rewrite -> He in Hxy; auto.
Qed.

Lemma hausdorffBall_wd1 : forall (e0 e1:Q) A B,
 (e0 == e1) -> hausdorffBall e0 A B -> hausdorffBall e1 A B.
Proof.
 intros e0 e1 A B He [H0 H1].
 split. rewrite <- He. exact H0.
 split; apply hemiMetric_wd1 with e0.
 exact He. apply H1. exact He. apply H1.
Qed.

Lemma hemiMetric_refl : forall (e:Q) A, 0 <= e -> hemiMetric e A A.
Proof.
 intros e epos A x Hx.
 apply existsWeaken.
 exists x.
 split; try assumption.
 apply ball_refl. exact A.
Qed.

Lemma hausdorffBall_refl : forall (e:Q) A, 0 <= e -> hausdorffBall e A A.
Proof.
 intros e A epos. split. exact epos.
 split; apply hemiMetric_refl; exact epos.
Qed.

Lemma hausdorffBall_sym : forall e A B,
 hausdorffBall e A B -> hausdorffBall e B A.
Proof.
 intros e A B [H0 H1].
 split. exact H0. split; apply H1.
Qed.

Lemma hemiMetric_triangle : forall e0 e1 A B C,
 hemiMetric e0 A B -> hemiMetric e1 B C -> hemiMetric (e0 + e1) A C.
Proof.
 intros e0 e1 A B C H0 H1 x Hx.
 destruct (H0 x Hx) as [HG | y [Hy Hxy]] using existsC_ind.
  apply existsC_stable; assumption.
 destruct (H1 y Hy) as [HG | z [Hz Hyz]] using existsC_ind.
  apply existsC_stable; assumption.
 apply existsWeaken.
 exists z.
 split; try assumption.
 apply ball_triangle with y; assumption.
Qed.

Lemma hausdorffBall_triangle : forall e0 e1 A B C,
 hausdorffBall e0 A B -> hausdorffBall e1 B C -> hausdorffBall (e0 + e1) A C.
Proof.
 intros e0 e1 A B C [H0A H0B] [H1A H1B].
 split.
 apply (Qle_trans _ (e0 + 0)). rewrite Qplus_0_r.
 exact H0A. apply Qplus_le_r. exact H1A. split.
  apply hemiMetric_triangle with B. apply H0B. apply H1B.
 apply hemiMetric_wd1 with (e1 + e0)%Q.
  ring.
 apply hemiMetric_triangle with B. apply H1B. apply H0B.
Qed.

(** Unfortunately this isn't a metric for an aribitrary predicate.  More
assumptions are needed to show our definition of ball is closed.  See
FinEnum for an example of an instance of the Hausdorff metric. *)

Lemma hemiMetric_stable :forall e A B, ~~(hemiMetric e A B) -> hemiMetric e A B.
Proof.
 unfold hemiMetric.
 auto 7 using existsC_stable.
Qed.

Lemma hausdorffBall_stable :forall e A B, ~~(hausdorffBall e A B) -> hausdorffBall e A B.
Proof.
 unfold hausdorffBall.
 firstorder using hemiMetric_stable.
Qed.

Lemma hemiMetric_wd :forall (e1 e2:Q), (e1 == e2) ->
 forall A1 A2, (forall x, A1 x <-> A2 x) ->
 forall B1 B2, (forall x, B1 x <-> B2 x) ->
 (hemiMetric e1 A1 B1 <-> hemiMetric e2 A2 B2).
Proof.
 cut (forall e1 e2 : Q, e1 == e2 -> forall A1 A2 : X -> Prop, (forall x : X, A1 x <-> A2 x) ->
   forall B1 B2 : X -> Prop, (forall x : X, B1 x <-> B2 x) ->
     (hemiMetric e1 A1 B1 -> hemiMetric e2 A2 B2)).
  intros; split.
   eauto.
  symmetry in H0.
  assert (H1':forall x : X, A2 x <-> A1 x) by firstorder.
  assert (H2':forall x : X, B2 x <-> B1 x) by firstorder.
  eauto.
 intros e1 e2 He A1 A2 HA B1 B2 HB H x Hx.
 rewrite <- HA in Hx.
 destruct (H x Hx) as [HG | y [Hy0 Hy1]] using existsC_ind.
  auto using existsC_stable.
 apply existsWeaken.
 exists y.
 change (e1 == e2) in He.
 rewrite <- HB.
 split. exact Hy0.
 rewrite <- He.
 assumption.
Qed.

Lemma hausdorffBall_wd :forall (e1 e2:Q), (e1 == e2) ->
 forall A1 A2, (forall x, A1 x <-> A2 x) ->
 forall B1 B2, (forall x, B1 x <-> B2 x) ->
 (hausdorffBall e1 A1 B1 <-> hausdorffBall e2 A2 B2).
Proof.
 intros.
 unfold hausdorffBall.
 setoid_replace (hemiMetric e1 A1 B1) with (hemiMetric e2 A2 B2).
  setoid_replace (hemiMetric e1 B1 A1) with (hemiMetric e2 B2 A2).
  2: apply hemiMetric_wd; auto.
 2: apply hemiMetric_wd; auto.
 rewrite H. reflexivity.
Qed.

End HausdorffMetric.

Section HausdorffMetricStrong.

Variable X : MetricSpace.
(**
** Strong Hausdorff Metric
This section introduces an alternative stronger notition of Haudorff metric
that uses a constructive existential.
*)

Definition hemiMetricStrong (e:Q) (A B: X -> Prop) :=
 forall x:X, A x ->
 forall d:Qpos, {y:X | B y /\ ball (e+ proj1_sig d) x y}.

Definition hausdorffBallStrong (e:Q) (A B: X -> Prop) :=
 (hemiMetricStrong e A B * hemiMetricStrong e B A)%type.

Lemma hemiMetricStrong_wd1 : forall (e0 e1:Q) A B,
 (e0 == e1) -> hemiMetricStrong e0 A B -> hemiMetricStrong e1 A B.
Proof.
 intros e0 e1 A B He H x Hx d.
 destruct (H x Hx d) as [y [Hy Hxy]].
 exists y. split. exact Hy.
 rewrite <- He. exact Hxy.
Qed.

Lemma hausdorffBallStrong_wd1 : forall (e0 e1:Q) A B,
 (e0 == e1) -> hausdorffBallStrong e0 A B -> hausdorffBallStrong e1 A B.
Proof.
 intros e0 e1 A B He [H0 H1].
 split; apply hemiMetricStrong_wd1 with e0; assumption.
Qed.

Lemma hemiMetricStrong_refl : forall (e:Q) A, 0 <= e -> hemiMetricStrong e A A.
Proof.
 intros e A epos x Hx d.
 exists x.
 split; try assumption.
 apply ball_refl.
 apply (Qle_trans _ (e+0)). rewrite Qplus_0_r.
 exact epos. apply Qplus_le_r.
 apply (Qpos_nonneg d).
Qed.

Lemma hausdorffBallStrong_refl : forall (e:Q) A, 0 <= e -> hausdorffBallStrong e A A.
Proof.
 intros e A.
 split; apply hemiMetricStrong_refl; exact H.
Qed.

Lemma hausdorffBallStrong_sym : forall e A B,
 hausdorffBallStrong e A B -> hausdorffBallStrong e B A.
Proof.
 intros e A B [H0 H1].
 split; assumption.
Qed.

Lemma hemiMetricStrong_triangle : forall e0 e1 A B C,
 hemiMetricStrong e0 A B -> hemiMetricStrong e1 B C -> hemiMetricStrong (e0 + e1) A C.
Proof.
 intros e0 e1 A B C H0 H1 x Hx d.
 assert (0 < (1#2)) as halfPos. reflexivity.
 destruct (H0 x Hx (exist _ _ halfPos*d)%Qpos) as [y [Hy Hxy]].
 destruct (H1 y Hy (exist _ _ halfPos*d)%Qpos) as [z [Hz Hyz]].
 exists z.
 split; try assumption.
 setoid_replace (e0 + e1 + proj1_sig d)
   with ((e0 + (1#2) * proj1_sig d) +(e1 + (1#2) * proj1_sig d))%Q
 by (simpl; ring).
 apply ball_triangle with y; assumption.
Qed.

Lemma hausdorffBallStrong_triangle : forall e0 e1 A B C,
 hausdorffBallStrong e0 A B -> hausdorffBallStrong e1 B C -> hausdorffBallStrong (e0 + e1) A C.
Proof.
 intros e0 e1 A B C [H0A H0B] [H1A H1B].
 split.
  apply hemiMetricStrong_triangle with B; assumption.
 apply hemiMetricStrong_wd1 with (e1 + e0)%Q.
 unfold QposEq. simpl. ring.
 apply hemiMetricStrong_triangle with B; assumption.
Qed.

(*
Lemma hemiMetricStrong_closed : forall e A B,
 FinitelyEnumerable X B ->
 (forall d, hemiMetricStrong (e+d) A B) ->
 hemiMetricStrong e A B.
Proof.
intros e A B HB H x Hx d.
destruct (H ((1#2)*d)%Qpos x Hx ((1#2)*d)%Qpos) as [y [Hy Hxy]].
exists y.
split; try assumption.
setoid_replace (e + d)%Qpos with (e + (1 # 2) * d + (1 # 2) * d)%Qpos by QposRing.
assumption.
Qed.

Lemma hausdorffBallStrong_closed : forall e A B,
 FinitelyEnumerable X A -> FinitelyEnumerable X B ->
 (forall d, hausdorffBallStrong (e+d) A B) ->
 hausdorffBallStrong e A B.
Proof.
intros e A B HA HB H.
split;
 apply hemiMetricStrong_closed;
 try assumption;
 intros d;
 destruct (H d);
 assumption.
Qed.
*)
(*
Lemma HemiMetricStrongHemiMetric : stableMetric X ->
 forall (e:Qpos) A B,
 SubFinite X B ->
 hemiMetricStrong e A B -> hemiMetric X e A B.
Proof.
intros HX e A B HB H.
apply hemiMetric_closed; try assumption.
unfold hemiMetric.
intros d x Hx.
apply existsWeaken.
destruct (H x Hx d) as [y Hy].
exists y.
assumption.
Qed.

Lemma HausdorffBallStrongHausdorffBall : stableMetric X ->
 forall (e:Qpos) A B,
 SubFinite X A -> SubFinite X B ->
 hausdorffBallStrong e A B -> hausdorffBall X e A B.
Proof.
intros HX e A B HA HB [H0 H1].
split; auto using HemiMetricStrongHemiMetric.
Qed.
*)
Hypothesis almostDecideX : locatedMetric X.

(*
Lemma HemiMetricHemiMetricStrong : forall (e:Qpos) A B,
 FinitelyEnumerable X B ->
 hemiMetric X e A B -> hemiMetricStrong e A B.
Proof.
intros e A B [l Hl] H x Hx.
generalize (H x Hx).
clear H.
revert B Hl x Hx.
induction l; intros B Hl x Hx H d.
 exfalso.
 generalize H.
 apply existsC_ind.
  tauto.
 intros y [Hy0 Hy1].
 apply -> Hl.
  apply Hy0.
 auto.
destruct (almostDecideX e (e+d)%Qpos x a).
  abstract (
  autorewrite with QposElim;
  rewrite Qlt_minus_iff;
  ring_simplify;
  auto with * ).
 exists a.
 destruct (Hl a); auto with *.
set (B':=fun x => ~~In x l).
assert ({ y : X | B' y /\ ball (m:=X) (e + d) x y}).
 apply IHl; auto.
  reflexivity.
 destruct (H) as [HG | y [Hy0 Hy1]] using existsC_ind.
  auto using existsC_stable.
 apply existsWeaken.
 exists y.
 abstract (
 split; auto;
 intros Y;
 apply -> Hl;[apply Hy0|];
 intros H;
 apply Y;
 destruct H as [H|H];
 [rewrite H in n; contradiction|auto with *]).
destruct X0 as [y [Hy0 Hy1]].
exists y.
abstract (
split; auto;
apply <- Hl;
auto 7 with * ).
Defined.

Lemma HausdorffBallHausdorffBallStrong : forall (e:Qpos) A B,
 FinitelyEnumerable X A -> FinitelyEnumerable X B ->
 hausdorffBall X e A B -> hausdorffBallStrong e A B.
intros e A B HA HB [H0 H1].
split; auto using HemiMetricHemiMetricStrong.
Defined.

Definition HemiMetricStrongAlmostDecidable :
 forall (e d:Qpos) A B,
 FinitelyEnumerable X A -> FinitelyEnumerable X B ->
 e < d -> hemiMetricStrong d A B + {hemiMetricStrong e A B->False}.
Proof.
assert (P1:forall (e d : Qpos) (a:X) (B : X -> Prop),
FinitelyEnumerable X B ->
e < d -> hemiMetricStrong d (fun x=>a=x) B + (hemiMetricStrong e (fun x=>a=x) B -> False)).
 intros e d a B [lB HB].
 revert B HB.
 induction lB.
  intros B HB Hed.
  right.
  intros H.
  destruct (H a (refl_equal a) d) as [y [Hy _]].
  apply -> HB.
   apply Hy.
  auto.
 intros B HB Hed.
 destruct (IHlB (fun x => ~~In x lB)) as [H|H].
    tauto.
   assumption.
  left.
  intros x Hx d0.
  destruct (H x Hx d0) as [y [Hy0 Hy1]].
  exists y.
  split; try assumption.
  assert (Z:=HB y); auto with *.
  apply <- HB.
  auto 7 with *.
 destruct (almostDecideX ((1#2)*(e+d))%Qpos d a a0).
   autorewrite with QposElim.
   rewrite Qlt_minus_iff.
   replace RHS with ((1#2)*(d + - e)) by ring.
   rewrite Qlt_minus_iff in Hed.
   Qauto_pos.
  left.
  intros x Hx d0.
  exists a0.
  destruct (HB a0).
  split; auto with *.
  apply ball_weak.
  rewrite <- Hx.
  assumption.
 right.
 intros H0.
 destruct (Qpos_lt_plus Hed) as [c Hc].
 apply H.
 intros x Hx d0.
 destruct (H0 a (refl_equal a) (Qpos_min d0 ((1#2)*c)%Qpos)) as [y [Hy0 Hy1]].
 destruct (HB y) as [Y _].
 exists y.
 split.
  intros Z.
  apply Y.
   assumption.
  intros H1.
  apply Z; clear Z.
  destruct H1 as [H1 | H1]; try assumption.
  elim n.
  rewrite H1.
  apply ball_weak_le with (e + Qpos_min d0 ((1 # 2) * c))%Qpos; auto.
  autorewrite with QposElim.
  rewrite Hc.
  rewrite Qle_minus_iff.
  replace RHS with ((1 # 2) * c + - (Qmin d0 ((1 # 2) * c))) by ring.
  rewrite <- Qle_minus_iff.
  rapply Qpos_min_lb_r.
 apply ball_weak_le with (e + Qmin d0 ((1 # 2) * c))%Qpos; auto.
  autorewrite with QposElim.
  rewrite Qle_minus_iff.
  replace RHS with (d0 + - (Qmin d0 ((1 # 2) * c))) by ring.
  rewrite <- Qle_minus_iff.
  rapply Qmin_lb_l.
 congruence.
intros e d A B HA HB Hed.
cut (hemiMetric X d A B + {hemiMetricStrong e A B -> False}).
 clear - HB.
 intros [Y|Y].
  left.
  apply HemiMetricHemiMetricStrong; auto.
 right; auto.
destruct HA as [lA HA].
revert A HA HB Hed.
induction lA.
 intros A HA HB _.
 left.
 intros x Hx.
 destruct (HA x) as [HAx _].
 elim (HAx Hx).
 auto with *.
intros A Ha HB Hed.
pose (A':=fun x => ~~In x lA).
destruct (IHlA A') as [I|I]; try assumption.
  unfold A'; tauto.
 destruct (P1 e d a B HB Hed) as [J|J].
  left.
  intros x Hx.
  rewrite Ha in Hx.
  revert Hx.
  cut (In x (a::lA) -> existsC X (fun y : X => B y /\ ball (m:=X) d x y)).
   unfold existsC; tauto.
  intros Hx.
  destruct Hx as [Hx|Hx].
   assert (J':hemiMetric X d (fun x : X => a = x) B).
    apply HemiMetricStrongHemiMetric; auto with *.
     clear - HB.
     destruct HB as [l Hl].
     exists l.
     firstorder.
   apply J'.
   assumption.
  change (In x lA) in Hx.
  apply I.
  unfold A'; auto.
 right.
 intros H.
 apply J.
 intros x Hx d0.
 apply H.
 rewrite Ha.
 rewrite Hx.
 auto with *.
right.
intros H.
apply I.
intros x Hx d0.
apply H.
rewrite Ha.
revert Hx.
unfold A'.
auto 7 with *.
Defined.

Definition HausdorffBallStrongAlmostDecidable :
 forall (e d:Qpos) A B,
 FinitelyEnumerable X A -> FinitelyEnumerable X B ->
 e < d -> hausdorffBallStrong d A B + {hausdorffBallStrong e A B->False}.
Proof.
intros e d A B HA HB Hed.
destruct (HemiMetricStrongAlmostDecidable e d A B HA HB Hed).
 destruct (HemiMetricStrongAlmostDecidable e d B A HB HA Hed).
  left.
  split; assumption.
 right.
 intros [_ H]; auto.
right.
intros [H _]; auto.
Defined.
*)

End HausdorffMetricStrong.

(*
Definition HausdorffBallAlmostDecidable :
 forall X, locatedMetric X ->
 forall (e d:Qpos) A B,
 FinitelyEnumerable X A -> FinitelyEnumerable X B ->
 e < d -> {hausdorffBall X d A B} + {~hausdorffBall X e A B}.
Proof.
intros X HX e d A B HA HB Hed.
destruct (HausdorffBallStrongAlmostDecidable X HX e d A B HA HB Hed) as [Z|Z].
 left.
 abstract (
 apply HausdorffBallStrongHausdorffBall;
  (apply located_stable || apply FinitelyEnumerable_SubFinite || idtac);assumption).
right.
abstract (
intros H;
apply Z;
apply HausdorffBallHausdorffBallStrong; assumption).
Defined.
*)


(* -*- coding: utf-8 -*- *)
(*      This file is distributed under the terms of the      *)
(*       GNU Lesser General Public License Version 2.1       *)
(* Author: Sosuke Moriguchi *)
(* Extended implementation from MSetList *)

(** * Finite sets library *)

(** This file is extension of [MSetList] to implement extensions in XSetInterface. *)

Require Export XSetInterface OrdersFacts OrdersLists.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Functions over lists *)

Module Ops (X:OrderedType) <: WOps X.

  Definition elt := X.t.
  Definition t := list elt.

  Definition empty : t := nil.

  Definition is_empty (l : t) := if l then true else false.

  (** ** The set operations. *)

  Fixpoint mem x s :=
    match s with
    | nil => false
    | y :: l =>
        match X.compare x y with
        | Lt => false
        | Eq => true
        | Gt => mem x l
        end
    end.

  Fixpoint add x s :=
    match s with
    | nil => x :: nil
    | y :: l =>
        match X.compare x y with
        | Lt => x :: s
        | Eq => s
        | Gt => y :: add x l
        end
    end.

  Definition singleton (x : elt) := x :: nil.

  Fixpoint remove x s :=
    match s with
    | nil => nil
    | y :: l =>
        match X.compare x y with
        | Lt => s
        | Eq => l
        | Gt => y :: remove x l
        end
    end.

  Fixpoint union (s : t) : t -> t :=
    match s with
    | nil => fun s' => s'
    | x :: l =>
        (fix union_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: union l s'
               | Eq => x :: union l l'
               | Gt => x' :: union_aux l'
               end
           end)
    end.

  Fixpoint inter (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix inter_aux (s' : t) : t :=
           match s' with
           | nil => nil
           | x' :: l' =>
               match X.compare x x' with
               | Lt => inter l s'
               | Eq => x :: inter l l'
               | Gt => inter_aux l'
               end
           end)
    end.

  Fixpoint diff (s : t) : t -> t :=
    match s with
    | nil => fun _ => nil
    | x :: l =>
        (fix diff_aux (s' : t) : t :=
           match s' with
           | nil => s
           | x' :: l' =>
               match X.compare x x' with
               | Lt => x :: diff l s'
               | Eq => diff l l'
               | Gt => diff_aux l'
               end
           end)
    end.

  Fixpoint equal (s : t) : t -> bool :=
    fun s' : t =>
    match s, s' with
    | nil, nil => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Eq => equal l l'
        | _ => false
        end
    | _, _ => false
    end.

  Fixpoint subset s s' :=
    match s, s' with
    | nil, _ => true
    | x :: l, x' :: l' =>
        match X.compare x x' with
        | Lt => false
        | Eq => subset l l'
        | Gt => subset s l'
        end
    | _, _ => false
    end.

  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
    fold_left (flip f) s i.

  Fixpoint filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: filter f l else filter f l
    end.

  Fixpoint for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then for_all f l else false
    end.

  Fixpoint exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else exists_ f l
    end.

  Fixpoint partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
        let (s1, s2) := partition f l in
        if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition cardinal (s : t) : nat := length s.

  Definition elements (x : t) : list elt := x.

  Definition min_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: _ => Some x
    end.

  Fixpoint max_elt (s : t) : option elt :=
    match s with
    | nil => None
    | x :: nil => Some x
    | _ :: l => max_elt l
    end.

  Definition choose := min_elt.

  Fixpoint compare s s' :=
   match s, s' with
    | nil, nil => Eq
    | nil, _ => Lt
    | _, nil => Gt
    | x::s, x'::s' =>
      match X.compare x x' with
       | Eq => compare s s'
       | Lt => Lt
       | Gt => Gt
      end
   end.

End Ops.

Module MakeRaw (X: OrderedType) <: RawSets X.
  Module Import MX := OrderedTypeFacts X.
  Module Import ML := OrderedTypeLists X.

  Include Ops X.

  (** ** Proofs of set operation specifications. *)

  Section ForNotations.

  Definition inf x l :=
   match l with
   | nil => true
   | y::_ => match X.compare x y with Lt => true | _ => false end
   end.

  Fixpoint isok l :=
   match l with
   | nil => true
   | x::l => inf x l && isok l
   end.

  Notation Sort l := (isok l = true).
  Notation Inf := (lelistA X.lt).
  Notation In := (InA X.eq).

  (* TODO: modify proofs in order to avoid these hints *)
  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).

  Definition IsOk s := Sort s.

  Class Ok (s:t) : Prop := ok : Sort s.

  Hint Resolve @ok.
  Hint Unfold Ok.

  Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }.

  Lemma inf_iff : forall x l, Inf x l <-> inf x l = true.
  Proof.
    intros x l; split; intro H.
    (* -> *)
    destruct H; simpl in *.
      reflexivity.
    rewrite <- compare_lt_iff in H; rewrite H; reflexivity.
    (* <- *)
    destruct l as [|y ys]; simpl in *.
      constructor; fail.
    revert H; case_eq (X.compare x y); try discriminate; [].
    intros Ha _.
    rewrite compare_lt_iff in Ha.
    constructor; assumption.
  Qed.

  Lemma isok_iff : forall l, sort X.lt l <-> Ok l.
  Proof.
    intro l; split; intro H.
    (* -> *)
    elim H.
      constructor; fail.
    intros y ys Ha Hb Hc.
    change (inf y ys && isok ys = true).
    rewrite inf_iff in Hc.
    rewrite andb_true_iff; tauto.
    (* <- *)
    induction l as [|x xs].
      constructor.
    change (inf x xs && isok xs = true) in H.
    rewrite andb_true_iff, <- inf_iff in H.
    destruct H; constructor; tauto.
  Qed.

  Hint Extern 1 (Ok _) => rewrite <- isok_iff.

  Ltac inv_ok := match goal with
   | H:sort X.lt (_ :: _) |- _ => inversion_clear H; inv_ok
   | H:sort X.lt nil |- _ => clear H; inv_ok
   | H:sort X.lt ?l |- _ => change (Ok l) in H; inv_ok
   | H:Ok _ |- _ => rewrite <- isok_iff in H; inv_ok
   | |- Ok _ => rewrite <- isok_iff
   | _ => idtac
  end.

  Ltac inv := invlist InA; inv_ok; invlist lelistA.
  Ltac constructors := repeat constructor.

  Ltac sort_inf_in := match goal with
   | H:Inf ?x ?l, H':In ?y ?l |- _ =>
     cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto]
   | _ => fail
  end.

  Global Instance isok_Ok s `(isok s = true) : Ok s | 10.
  Proof.
  intros. assumption.
  Qed.

  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.

  Lemma mem_spec :
   forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s.
  Proof.
  induction s; intros x Hs; inv; simpl.
  intuition. discriminate. inv.
  elim_compare x a; rewrite InA_cons; intuition; try order.
  discriminate.
  sort_inf_in. order.
  rewrite <- IHs; auto.
  rewrite IHs; auto.
  Qed.

  Lemma add_inf :
   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; intuition.
  Qed.
  Hint Resolve add_inf.

  Global Instance add_ok s x : forall `(Ok s), Ok (add x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  simple induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma add_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (add x s) <-> X.eq y x \/ In y s.
  Proof.
  induction s; simpl; intros.
  intuition. inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition.
  left; order.
  Qed.

  Lemma remove_inf :
   forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s).
  Proof.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  apply Inf_lt with a; auto.
  Qed.
  Hint Resolve remove_inf.

  Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s).
  Proof.
  repeat rewrite <- isok_iff; revert s x.
  induction s; simpl.
  intuition.
  intros; elim_compare x a; inv; auto.
  Qed.

  Lemma remove_spec :
   forall (s : t) (x y : elt) (Hs : Ok s),
    In y (remove x s) <-> In y s /\ ~X.eq y x.
  Proof.
  induction s; simpl; intros.
  intuition; inv; auto.
  elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition;
   try sort_inf_in; try order.
  Qed.

  Global Instance singleton_ok x : Ok (singleton x).
  Proof.
  unfold singleton; simpl; auto.
  Qed.

  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
  Proof.
  unfold singleton; simpl; split; intros; inv; auto.
  Qed.

  Ltac induction2 :=
    simple induction s;
     [ simpl; auto; try solve [ intros; inv ]
     | intros x l Hrec; simple induction s';
        [ simpl; auto; try solve [ intros; inv ]
        | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]].

  Lemma union_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (union s s').
  Proof.
  induction2.
  Qed.
  Hint Resolve union_inf.

  Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2; constructors; try apply @ok; auto.
  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto.
  change (Inf x' (union (x :: l) l')); auto.
  Qed.

  Lemma union_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (union s s') <-> In x s \/ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
  left; order.
  Qed.

  Lemma inter_inf :
   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
   Inf a s -> Inf a s' -> Inf a (inter s s').
  Proof.
  induction2.
  apply Inf_lt with x; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve inter_inf.

  Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  constructors; auto.
  apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto.
  Qed.

  Lemma inter_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (inter s s') <-> In x s /\ In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  left; order.
  Qed.

  Lemma diff_inf :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt),
   Inf a s -> Inf a s' -> Inf a (diff s s').
  Proof.
  intros s s'; repeat rewrite <- isok_iff; revert s s'.
  induction2.
  apply Hrec; trivial.
  apply Inf_lt with x; auto.
  apply Inf_lt with x'; auto.
  apply Hrec'; auto.
  apply Inf_lt with x'; auto.
  Qed.
  Hint Resolve diff_inf.

  Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s').
  Proof.
  repeat rewrite <- isok_iff; revert s s'.
  induction2.
  Qed.

  Lemma diff_spec :
   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
   In x (diff s s') <-> In x s /\ ~In x s'.
  Proof.
  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
   try sort_inf_in; try order.
  right; intuition; inv; auto.
  Qed.

  Lemma equal_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   equal s s' = true <-> Equal s s'.
  Proof.
  induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
  intuition.
  split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
  split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
  inv.
  elim_compare x x' as C; try discriminate.
  (* x=x' *)
  rewrite IH; auto.
  split; intros E y; specialize (E y).
  rewrite !InA_cons, E, C; intuition.
  rewrite !InA_cons, C in E. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros E. discriminate.
  assert (In x (x'::s')) by (rewrite <- E; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  split; intros E. discriminate.
  assert (In x' (x::s)) by (rewrite E; auto).
  inv; try sort_inf_in; order.
  Qed.

  Lemma subset_spec :
   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
   subset s s' = true <-> Subset s s'.
  Proof.
  intros s s'; revert s.
  induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto.
  split; try red; intros; auto.
  split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv.
  split; try red; intros; auto. inv.
  inv. elim_compare x x' as C.
  (* x=x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons, C. intuition.
  rewrite !InA_cons, C in S. intuition; try sort_inf_in; order.
  (* x<x' *)
  split; intros S. discriminate.
  assert (In x (x'::s')) by (apply S; auto).
  inv; try sort_inf_in; order.
  (* x>x' *)
  rewrite IH; auto.
  split; intros S y; specialize (S y).
  rewrite !InA_cons. intuition.
  rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order.
  Qed.

  Global Instance empty_ok : Ok empty.
  Proof.
  constructors.
  Qed.

  Lemma empty_spec : Empty empty.
  Proof.
  unfold Empty, empty; intuition; inv.
  Qed.

  Lemma is_empty_spec : forall (s : t) (Hs : Ok s), is_empty s = true <-> Empty s.
  Proof.
  intros [ | x s] _; simpl.
  split; auto. intros _ x H. inv.
  split. discriminate. intros H. elim (H x); auto.
  Qed.

  Lemma elements_spec1 : forall (s : t) (x : elt) (Hs : Ok s), In x (elements s) <-> In x s.
  Proof.
  intuition.
  Qed.

  Lemma elements_spec2 : forall (s : t) (Hs : Ok s), sort X.lt (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s).
  Proof.
  intro s; repeat rewrite <- isok_iff; auto.
  Qed.

  Lemma min_elt_spec1 : forall (s : t) (x : elt) (Hs : Ok s), min_elt s = Some x -> In x s.
  Proof.
  destruct s; simpl; inversion 2; auto.
  Qed.

  Lemma min_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   min_elt s = Some x -> In y s -> ~ X.lt y x.
  Proof.
  induction s as [ | x s IH]; simpl; inversion 2; subst.
  intros; inv; try sort_inf_in; order.
  Qed.

  Lemma min_elt_spec3 : forall (s : t) (Hs : Ok s), min_elt s = None -> Empty s.
  Proof.
  destruct s; simpl; red; intuition. inv. discriminate.
  Qed.

  Lemma max_elt_spec1 : forall (s : t) (x : elt) (Hs : Ok s), max_elt s = Some x -> In x s.
  Proof.
  intros s x _. revert x. induction s as [ | x s IH]. inversion 1.
  destruct s as [ | y s]. simpl. inversion 1; subst; auto.
  right; apply IH; auto.
  Qed.

  Lemma max_elt_spec2 :
   forall (s : t) (x y : elt) (Hs : Ok s),
   max_elt s = Some x -> In y s -> ~ X.lt x y.
  Proof.
  induction s as [ | a s IH]. inversion 2.
  destruct s as [ | b s]. inversion 2; subst. intros; inv; order.
  intros. inv; auto.
  assert (~X.lt x b) by (apply IH; auto).
  assert (X.lt a b) by auto.
  order.
  Qed.

  Lemma max_elt_spec3 : forall (s : t) (Hs : Ok s), max_elt s = None -> Empty s.
  Proof.
  intros s _. induction s as [ | a s IH]. red; intuition; inv.
  destruct s as [ | b s]. inversion 1.
  intros; elim IH with b; auto.
  Qed.

  Definition choose_spec1 :
    forall (s : t) (x : elt) (Hs : Ok s), choose s = Some x -> In x s := min_elt_spec1.

  Definition choose_spec2 :
    forall (s : t) (Hs : Ok s), choose s = None -> Empty s := min_elt_spec3.

  Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' ->
   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
  Proof.
   unfold choose; intros s s' x x' Hs Hs' Hx Hx' H.
   assert (~X.lt x x').
    apply min_elt_spec2 with s'; auto.
    rewrite <-H; auto using min_elt_spec1.
   assert (~X.lt x' x).
    apply min_elt_spec2 with s; auto.
    rewrite H; auto using min_elt_spec1.
   order.
  Qed.

  Lemma fold_spec :
   forall (s : t) (Hs : Ok s) (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i.
  Proof.
  reflexivity.
  Qed.

  Lemma cardinal_spec :
   forall (s : t) (Hs : Ok s),
   cardinal s = length (elements s).
  Proof.
  auto.
  Qed.

  Lemma filter_inf :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   Inf x s -> Inf x (filter f s).
  Proof.
  simple induction s; simpl.
  intuition.
  intros x l Hrec a f Hs Ha; inv.
  case (f x); auto.
  apply Hrec; auto.
  apply Inf_lt with x; auto.
  Qed.

  Global Instance filter_ok s f : forall `(Ok s), Ok (filter f s).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  case (f x); auto.
  constructors; auto.
  apply filter_inf; auto.
  Qed.

  Lemma filter_spec :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   Proper (X.eq==>eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true).
  Proof.
  intros s x f _; induction s; simpl; intros.
  split; intuition; inv.
  destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition.
  setoid_replace x with a; auto.
  setoid_replace a with x in F; auto; congruence.
  Qed.

  Lemma filter_spec' :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   In x (filter f s) -> In x s.
  Proof.
  intros s x f _; induction s; simpl; intro H.
  now intuition.
  destruct (f a); auto.
  inversion_clear H; auto.
  Qed.

  Lemma for_all_spec :
   forall (s : t) (f : elt -> bool) (Hs : Ok s),
   Proper (X.eq==>eq) f ->
   (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof.
  intros s f _; unfold For_all; induction s; simpl; intros.
  split; intros; auto. inv.
  destruct (f a) eqn:F.
  rewrite IHs; auto. firstorder. inv; auto.
  setoid_replace x with a; auto.
  split; intros H'. discriminate.
  rewrite H' in F; auto.
  Qed.

  Lemma exists_spec :
   forall (s : t) (f : elt -> bool) (Hs : Ok s),
   Proper (X.eq==>eq) f ->
   (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof.
  intros s f _; unfold Exists; induction s; simpl; intros.
  firstorder. discriminate. inv.
  destruct (f a) eqn:F.
  firstorder.
  rewrite IHs; auto.
  firstorder.
  inv.
  setoid_replace a with x in F; auto; congruence.
  exists x; auto.
  Qed.

  Lemma partition_inf1 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (fst (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  auto.
  intros; apply H2; apply Inf_lt with x; auto.
  Qed.

  Lemma partition_inf2 :
   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
   Inf x s -> Inf x (snd (partition f s)).
  Proof.
  intros s f x; repeat rewrite <- isok_iff; revert s f x.
  simple induction s; simpl.
  intuition.
  intros x l Hrec f a Hs Ha; inv.
  generalize (Hrec f a H).
  case (f x); case (partition f l); simpl.
  intros; apply H2; apply Inf_lt with x; auto.
  auto.
  Qed.

  Global Instance partition_ok1 s f : forall `(Ok s), Ok (fst (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf1 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Global Instance partition_ok2 s f : forall `(Ok s), Ok (snd (partition f s)).
  Proof.
  repeat rewrite <- isok_iff; revert s f.
  simple induction s; simpl.
  auto.
  intros x l Hrec f Hs; inv.
  generalize (Hrec f H); generalize (@partition_inf2 l f x).
  case (f x); case (partition f l); simpl; auto.
  Qed.

  Lemma partition_spec1 :
   forall (s : t) (f : elt -> bool) (Hs : Ok s),
   Proper (X.eq==>eq) f -> Equal (fst (partition f s)) (filter f s).
  Proof.
  intros s f _; revert s; simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec Hf.
  generalize (Hrec Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  Lemma partition_spec1' :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   In x (fst (partition f s)) -> In x s.
  Proof.
  intros s x f _; induction s; simpl; intro H.
  now intuition.
  destruct (partition f s); simpl in *.
  destruct (f a); auto.
  inversion_clear H; auto.
  Qed.

  Lemma partition_spec2 :
   forall (s : t) (f : elt -> bool) (Hs : Ok s),
   Proper (X.eq==>eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof.
  intros s f _; revert s; simple induction s; simpl; auto; unfold Equal.
  split; auto.
  intros x l Hrec Hf.
  generalize (Hrec Hf); clear Hrec.
  destruct (partition f l) as [s1 s2]; simpl; intros.
  case (f x); simpl; auto.
  split; inversion_clear 1; auto.
  constructor 2; rewrite <- H; auto.
  constructor 2; rewrite H; auto.
  Qed.

  Lemma partition_spec2' :
   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
   In x (snd (partition f s)) -> In x s.
  Proof.
  intros s x f _; induction s; simpl; intro H.
  now intuition.
  destruct (partition f s); simpl in *.
  destruct (f a); auto.
  inversion_clear H; auto.
  Qed.

  End ForNotations.

  Definition In := InA X.eq.
  Instance In_compat : Proper (X.eq==>eq==> iff) In.
  Proof. repeat red; intros; rewrite H, H0; auto. Qed.

  Module L := MakeListOrdering X.
  Definition eq := L.eq.
  Definition eq_equiv := L.eq_equiv.
  Definition lt l1 l2 :=
    exists l1' l2', Ok l1' /\ Ok l2' /\ eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.

  Instance lt_strorder : StrictOrder lt.
  Proof.
  split.
  intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
  repeat rewrite <- isok_iff in *.
  assert (eqlistA X.eq s1 s2).
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s; auto. symmetry; auto.
  rewrite H in L.
  apply (StrictOrder_Irreflexive s2); auto.
  intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
                  (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
  exists s1', s3'.
  repeat rewrite <- isok_iff in *.
  do 4 (split; trivial).
  assert (eqlistA X.eq s2' s2'').
   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
   transitivity s2; auto. symmetry; auto.
  transitivity s2'; auto.
  rewrite H; auto.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
  intros s1 s2 E12 s3 s4 E34. split.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s1; auto. symmetry; auto.
   split; auto. transitivity s3; auto. symmetry; auto.
  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
  exists s1', s3'; do 2 (split; trivial).
   split. transitivity s2; auto.
   split; auto. transitivity s4; auto.
  Qed.

  Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s').
  Proof.
  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
  elim_compare x x'; auto.
  Qed.

  Lemma compare_spec : forall s s', Ok s -> Ok s' ->
   CompSpec eq lt s s' (compare s s').
  Proof.
  intros s s' Hs Hs'.
  destruct (compare_spec_aux s s'); constructor; auto.
  exists s, s'; repeat split; auto using @ok.
  exists s', s; repeat split; auto using @ok.
  Qed.

End MakeRaw.

(** * Encapsulation

   Now, in order to really provide a functor implementing [S], we
   need to encapsulate everything into a type of strictly ordered lists. *)

Module Make (X: OrderedType) <: Sets with Module E := X.
 Module Raw := MakeRaw X.
 Include Raw2Sets X Raw.
End Make.

(** For this specific implementation, eq coincides with Leibniz equality *)

Require Eqdep_dec.

Module Type OrderedTypeWithLeibniz.
  Include OrderedType.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End OrderedTypeWithLeibniz.

Module Type SWithLeibniz.
  Declare Module E : OrderedTypeWithLeibniz.
  Include SetsOn E.
  Parameter eq_leibniz : forall x y, eq x y -> x = y.
End SWithLeibniz.

Module MakeWithLeibniz (X: OrderedTypeWithLeibniz) <: SWithLeibniz with Module E := X.
  Module E := X.
  Module Raw := MakeRaw X.
  Include Raw2SetsOn X Raw.

  Lemma eq_leibniz_list : forall xs ys, eqlistA X.eq xs ys -> xs = ys.
  Proof.
    induction xs as [|x xs]; intros [|y ys] H; inversion H; [ | ].
    reflexivity.
    f_equal.
    apply X.eq_leibniz; congruence.
    apply IHxs; subst; assumption.
  Qed.

  Lemma eq_leibniz : forall s s', eq s s' -> s = s'.
  Proof.
    intros [xs Hxs] [ys Hys] Heq.
    change (equivlistA X.eq xs ys) in Heq.
    assert (H : eqlistA X.eq xs ys).
      rewrite <- Raw.isok_iff in Hxs, Hys.
      apply SortA_equivlistA_eqlistA with X.lt; auto with *.
    apply eq_leibniz_list in H.
    subst ys.
    f_equal.
    apply Eqdep_dec.eq_proofs_unicity.
    intros x y; destruct (bool_dec x y); tauto.
  Qed.

End MakeWithLeibniz.


(** This file implements bimonads. A [Bimonad] is a functor equipped
    with a monad/comonad structure and a distributive law over itself,
    which ensures the composition (W ∘ W) is also a monad and a
    comonad. Additionally there are some coherence laws, below, which
    may be read into several equivalent ways: *)
(**
    - The cojoin is a monad homomorphism (W → W ∘ W) and the counit a homomorphism (W → 1)
    - The join is a comonad homomorphism (W ∘ W → W) and the unit a homomorphism (1 → W)
    - W is a monoid in the category of comonoids (in the category of endofunctors)
    - W is a comonoid in the category of monoids (in the category of endofunctors)
 *)

From Tealeaves.Classes Require Export
  Monad
  Comonad
  BeckDistributiveLaw.

Import Product.Notations.
Import Functor.Notations.
Import Monad.Notations.
Import Comonad.Notations.

#[local] Generalizable Variables W A B.

(** * Bimonad typeclass *)
(******************************************************************************)
Section Bimonad.

  Context
    (W : Type -> Type)
    `{Fmap W}
    `{Return W}
    `{Join W}
    `{Cojoin W}
    `{Extract W}
    `{BeckDistributiveLaw W W}.

  Class Bimonad :=
    { bimonad_monad :> Monad W;
      bimonad_comonad :> Comonad W;
      bimonad_distributive_law :> BeckDistributiveLaw W W;
      bimonad_dist_counit_r :
        `(fmap W (extract W) ∘ bdist W W = extract W (A := W A));
      bimonad_dist_counit_l :
        `(extract W ∘ bdist W W = fmap W (extract W (A := A)));
      bimonad_cap :
        `(extract W ∘ join W = extract W ∘ extract W (A := W A));
      bimonad_baton :
        `(extract W ∘ ret W = @id A);
      bimonad_cup :
        `(cojoin W ∘ ret W = ret W ∘ ret W (A := A));
      bimonad_butterfly :
        `(cojoin W ∘ join W (A := A) =
          fmap W (join W) ∘ join W ∘ fmap W (bdist W W) ∘ cojoin W ∘ fmap W (cojoin W));
    }.

End Bimonad.

(** * Kleisli lifting operation <<bibind>> *)
(******************************************************************************)
Section Bimonad_kleisli_operations.

  Context
    (W : Type -> Type)
    `{Fmap W} `{Join W} `{Cojoin W}
    `{BeckDistribution W W}.

  Definition bibind {A B} : (W A -> W B) -> (W A -> W B) :=
    fun f => join W ∘ fmap W f ∘ cojoin W.

  Definition twist : W ∘ W ⇒ W ∘ W
    := fun A => fmap W (join W) ∘ bdist W W ∘ fmap W (cojoin W).

  Definition kcomposebi {A B C} :
    (W B -> W C) ->
    (W A -> W B) ->
    (W A -> W C) :=
    fun g f => join W ∘ fmap W g ∘ twist B ∘ fmap W f ∘ cojoin W.

End Bimonad_kleisli_operations.

Module Notations.
  Notation "g ⋆bi f" := (kcomposebi _ g f) (at level 70) : tealeaves_scope.
End Notations.

Import Notations.

(*
(** ** Specifications for suboperations *)
(******************************************************************************)
Section Bimonad_suboperations.

  Context
    `{Bimonad W}.

  Lemma cobind_to_bibind : forall `(f : W A -> B),
      cobind W f = bibind W (ret W ∘ f).
  Proof.
    intros. unfold bibind. unfold_ops @Cobind_Cojoin.
    rewrite <- (fun_fmap_fmap W). reassociate <-.
    now rewrite (mon_join_fmap_ret W).
  Qed.

  Lemma bind_to_bibind : forall `(f : A -> W B),
      bind W f = bibind W (f ∘ extract W).
  Proof.
    intros. unfold bibind. unfold_ops @Bind_Join.
    rewrite <- (fun_fmap_fmap W).
    reassociate <-. reassociate ->.
    now rewrite (com_fmap_extr_cojoin W).
  Qed.

  Lemma fmap_to_bibind : forall `(f : A -> B),
      fmap W f = bibind W (ret W ∘ f ∘ extract W).
  Proof.
    intros. unfold bibind.
    do 2 rewrite <- (fun_fmap_fmap W).
    repeat reassociate <-.
    rewrite (mon_join_fmap_ret W).
    reassociate ->.
    now rewrite (com_fmap_extr_cojoin W).
  Qed.

End Bimonad_suboperations.

(** ** Bimonadic Kleisli composition laws *)
(******************************************************************************)
Section Bimonad_kleisli_composition.

  Context
    `{Bimonad W}.

  (** Composition where <<g>> is a co-Kleisli arrow reduces to usual
      Kleisli composition. *)
  Lemma bi_kcompose1 {A B C} : forall (g : B -> W C) (f : W A -> W B),
      (g ∘ extract W) ⋆bi f = g ⋆ f.
  Proof.
    intros. unfold kcomposebi, kcompose.
    rewrite <- (fun_fmap_fmap W).
    reassociate <-. unfold twist.
    repeat reassociate <-.
    reassociate -> near (fmap W (join W)).
    rewrite (fun_fmap_fmap W). rewrite (bimonad_cap W).
    rewrite <- (fun_fmap_fmap W).
    repeat reassociate <-.
    reassociate -> near (bdist W W).
    rewrite (bimonad_dist_counit_r W).
    reassociate -> near (fmap W (cojoin W)).
    rewrite <- (natural (ϕ := @extract W _)); unfold_ops @Fmap_I.
    reassociate <-. reassociate -> near (cojoin W (A := B)).
    rewrite (com_fmap_extr_cojoin W).
    reassociate -> near (fmap W f).
    rewrite <- (natural (ϕ := @extract W _)); unfold_ops @Fmap_I.
    repeat reassociate ->. rewrite (com_extract_cojoin W).
    reflexivity.
  Qed.

  (** Composition where <<f>> is a Kleisli arrow reduces to usual
      co-Kleisli composition. *)
  Lemma bi_kcompose2 {A B C} : forall (g : W B -> W C) (f : W A -> B),
      g ⋆bi (ret W ∘ f) = g co⋆ f.
  Proof.
    intros. unfold kcomposebi, kcompose.
    rewrite <- (fun_fmap_fmap W).
    reassociate <-. unfold twist.
    repeat reassociate <-.
    reassociate -> near (fmap W (ret W)).
    rewrite (fun_fmap_fmap W). rewrite (bimonad_cup W).
    rewrite <- (fun_fmap_fmap W).
    repeat reassociate <-.
    reassociate -> near (fmap W (ret W) (A := W B)).
    rewrite (dist_unit_r W W).
    reassociate -> near (ret W).
    rewrite (natural (ϕ := @ret W _)); unfold_ops @Fmap_I.
    reassociate <-. reassociate -> near (fmap W (ret W)).
    rewrite (mon_join_fmap_ret W).
    reassociate -> near (ret W).
    rewrite (natural (ϕ := @ret W _)); unfold_ops @Fmap_I.
    reassociate <-. rewrite (mon_join_ret W).
    reflexivity.
  Qed.

End Bimonad_kleisli_composition.

(** ** Functoriality of [bibind] *)
(******************************************************************************)
Section Bimonad_bibind.

  Context
    `{Bimonad W}.

  Definition bind_id {A} :
    bibind W (ret W ∘ extract W) = @id (W A).
  Proof.
    intros. unfold bibind.
    rewrite <- (fun_fmap_fmap W).
    do 2 reassociate -> on left.
    rewrite (com_fmap_extr_cojoin W).
    reassociate <- on left.
    now rewrite (mon_join_fmap_ret W).
  Qed.

  Definition bind_functorial {A B C} : forall (g : W B -> W C) (f : W A -> W B),
      bibind W (g ⋆bi f) = bibind W g ∘ bibind W f.
  Proof.
    intros. unfold bibind. unfold kcomposebi.
    (** *)
    repeat reassociate -> on left.
    rewrite <- (fun_fmap_fmap W).
    repeat  reassociate <- on left.
    rewrite <- (mon_join_join W).
    (** *)
    rewrite <- (fun_fmap_fmap W).
    repeat reassociate -> on left.
    rewrite <- (com_cojoin_cojoin W).
    repeat  reassociate <- on left.
    (** *)
    repeat reassociate -> on left.
    rewrite <- (fun_fmap_fmap W).
    repeat  reassociate <- on left.
    reassociate -> near (fmap W (fmap W g)).
    change (fmap W (fmap W g)) with (fmap (W ∘ W) g).
    Set Keyed Unification.
    rewrite <- (natural (ϕ := @join W _)).
    Unset Keyed Unification.
    (** *)
    rewrite <- (fun_fmap_fmap W).
    repeat reassociate -> on left.
    reassociate <- near (fmap W (fmap W f)).
    change (fmap W (fmap W f)) with (fmap (W ∘ W) f).
    Set Keyed Unification.
    rewrite (natural (ϕ := @cojoin W _)).
    Unset Keyed Unification.
    repeat reassociate <- on left.
    repeat reassociate <- on right.
    (** *)
    reassociate -> near (join W).
    rewrite (bimonad_butterfly W).
    repeat reassociate <-.
    reassociate -> near (join W).
    Set Keyed Unification.
    rewrite (natural (ϕ := @join W _) (μ W)).
    Unset Keyed Unification.
    reassociate -> near (fmap W (cojoin W)).
    Set Keyed Unification.
    rewrite <- (natural (ϕ := @cojoin W _) (cojoin W)).
    Unset Keyed Unification.
    unfold twist.
    repeat reassociate <-.
    now repeat rewrite <- (fun_fmap_fmap W).
  Qed.

End Bimonad_bibind.
*)