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

Set Implicit Arguments.

Require Import LogicUtil Setoid Basics Morphisms List.
Require Export Relations RelMidex.
Require Import Omega.

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 same_rel := same_relation.

Notation "x << y" := (inclusion x y) (at level 50) : relation_scope.
Notation "R == S" := (same_relation R S) (at level 70).

Notation "x 'U' y" := (union x y) (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.

Bind Scope relation_scope with relation.

Arguments Scope transp [type_scope relation_scope].
Arguments Scope inclusion [type_scope relation_scope relation_scope].
Arguments Scope clos_refl_trans [type_scope relation_scope].
Arguments Scope union [type_scope relation_scope relation_scope].

Open Scope relation_scope.

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

Proof. split_all. 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. *)

Definition bool_of_rel A (R : rel A) (R_dec : rel_dec R) t u :=
  match R_dec t u with
    | left _ => true
    | _ => false
  end.

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

Global Instance same_rel_equiv A : Equivalence (@same_rel A).

Proof. fo. Qed.

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

Proof. fo. Qed.

Instance same_rel_sub_incl A : subrelation (@same_rel A) (@inclusion A).

Proof. fo. Qed.

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

Implicit Arguments in_sons_R [A R x y].
Implicit 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_Reflexive A (R : rel A) :
  Reflexive R -> Reflexive (inter_transp R).

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

(*WARNING: Do not declare following Lemmas as Instances. *)

Lemma R_inter_transp A (R : rel A) :
  Transitive R -> Proper (inter_transp R ==> inter_transp R ==> impl) R.

Proof. fo. Qed.

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

Proof. fo. Qed.

(***********************************************************************)
(** Morphisms wrt [inter_transp]. *)

Lemma inter_transp_1 A1 (R1 : rel A1) B (S : rel B) f :
  Proper (R1 ==> S) f -> Proper (inter_transp R1 ==> inter_transp S) f.

Proof. fo. Qed.

Lemma inter_transp_2 A1 (R1 : rel A1) A2 (R2 : rel A2)
  B (S : rel B) f : Proper (R1 ==> R2 ==> S) f ->
  Proper (inter_transp R1 ==> inter_transp R2 ==> inter_transp S) f.

Proof. fo. Qed.

Lemma Proper_inter_transp_1 A1 (R1 : rel A1) B (S : rel B) f :
  Symmetric R1 -> Proper (R1 ==> S) f -> Proper (R1 ==> inter_transp S) f.

Proof. fo. Qed.

Lemma Proper_inter_transp_2 A1 (R1 : rel A1) A2 (R2 : rel A2)
  B (S : rel B) f : Symmetric R1 -> Symmetric R2 ->
  Proper (R1 ==> R2 ==> S) f -> Proper (R1 ==> R2 ==> inter_transp S) f.

Proof. intros s1 s2 hf x1 y1 e1 x2 y2 e2. split; apply hf; fo. Qed.

Lemma Proper_inter_transp_3 A1 (R1 : rel A1) A2 (R2 : rel A2)
  A3 (R3 : rel A3) B (S : rel B) f :
  Symmetric R1 -> Symmetric R2 -> Symmetric R3 ->
  Proper (R1 ==> R2 ==> R3 ==> S) f ->
  Proper (R1 ==> R2 ==> R3 ==> inter_transp S) f.

Proof. intros s1 s2 s3 hf x1 y1 e1 x2 y2 e2 x3 y3 e3. split; apply hf; fo. Qed.

Lemma Proper_inter_transp_4 A1 (R1 : rel A1) A2 (R2 : rel A2)
  A3 (R3 : rel A3) A4 (R4 : rel A4) B (S : rel B) f :
  Symmetric R1 -> Symmetric R2 -> Symmetric R3 -> Symmetric R4 ->
  Proper (R1 ==> R2 ==> R3 ==> R4 ==> S) f ->
  Proper (R1 ==> R2 ==> R3 ==> R4 ==> inter_transp S) f.

Proof.
  intros s1 s2 s3 s4 hf x1 y1 e1 x2 y2 e2 x3 y3 e3 x4 y4 e4.
  split; apply hf; fo.
Qed.

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

Instance inclusion_Refl A : Reflexive (@inclusion A).

Proof. fo. Qed.

Ltac incl_refl := apply inclusion_Refl.

Instance inclusion_Trans A : Transitive (@inclusion A).

Proof. fo. Qed.

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

Instance inclusion_same_rel A :
  Proper (same_rel ==> same_rel ==> impl) (@inclusion A).

Proof. fo. Qed.

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

Proof. auto. Qed.

Implicit Arguments inclusion_elim [A R S x y].

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

Instance IS_inclusion A : Proper (inclusion ==> eq ==> impl) (@IS A).

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

Instance IS_same_rel A : Proper (same_rel ==> eq ==> impl) (@IS A).

Proof.
  intros R S [RS SR] f g fg h. eapply IS_inclusion. apply RS. apply fg. hyp.
Qed.

Instance EIS_same_rel A : Proper (same_rel ==> 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) : forall f k, IS R f -> NT R (f k).

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

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

Proof.
  intros t u 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]. *)

Instance irreflexive_inclusion A : Proper (inclusion --> 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.

Notation "R @ S" := (compose R S) (at level 40) : relation_scope.

Instance compose_inclusion A :
  Proper (inclusion ==> inclusion ==> inclusion) (@compose A).

Proof. fo. Qed.

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

Instance compose_m A :
  Proper (same_rel ==> same_rel ==> same_rel) (@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 inclusion. 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 inclusion. 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 inclusion, 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.

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

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

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

Instance clos_refl_m' A : Proper (inclusion ==> inclusion) (@clos_refl A).

Proof. fo. Qed.

Instance clos_refl_m A : Proper (same_rel ==> same_rel) (@clos_refl A).

Proof. fo. Qed.

Instance rc_refl A (R : rel A) : Reflexive (R%).

Proof. fo. Qed.

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 rc_incl A (R : rel A) : R << R%.

Proof. fo. Qed.

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

Instance tc_trans A (R : rel A) : Transitive (R!).

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

Instance clos_trans_inclusion A :
  Proper (inclusion ==> inclusion) (@clos_trans A).

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

Instance clos_trans_same_rel A :
  Proper (same_rel ==> same_rel) (@clos_trans A).

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

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

Proof. fo. Qed.

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

Proof.
  unfold transitive, inclusion. 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 inclusion, 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 inclusion. 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 inclusion. 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.

Instance tc_proper 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.

Instance clos_trans_morph A (R : relation A) (eqA : relation A) :
  Equivalence eqA ->
  Proper (eqA ==> eqA ==> iff) R ->
  Proper (eqA ==> eqA ==> iff) (clos_trans R).

Proof.
  intros.
  reduce. split; intros.
  revert y y0 H1 H2.
  induction H3; intros.
  rewrite H2, H3 in H1. now constructor.
  trans y. apply IHclos_trans1; eauto. reflexivity.
  apply IHclos_trans2; eauto. reflexivity.

  revert x x0 H1 H2.
  induction H3; intros.
  rewrite <- H2, <- H3 in H1. now constructor.
  trans y.
  apply IHclos_trans1; eauto. reflexivity.
  apply IHclos_trans2; eauto. reflexivity.
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.

Instance clos_equiv_incl A : Proper (inclusion ==> inclusion) (@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 [union]. *)

Instance union_inclusion A :
  Proper (inclusion ==> inclusion ==> inclusion) (@union A).

Proof. fo. Qed.

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

Instance union_same_rel A :
  Proper (same_rel ==> same_rel ==> same_rel) (@union A).

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Instance rtc_refl A (R : rel A) : Reflexive (R#).

Proof. fo. Qed.

Instance rtc_trans A (R : rel A) : Transitive (R#).

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

Instance clos_refl_trans_inclusion A :
  Proper (inclusion ==> inclusion) (@clos_refl_trans A).

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

Instance clos_refl_trans_same_rel A :
  Proper (same_rel ==> same_rel) (@clos_refl_trans A).

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

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

Proof. fo. 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 inclusion. induction 1. exists y. split. hyp. refl.
  destruct IHclos_trans1. destruct H1. exists x0. split. hyp.
  trans y. hyp. apply inclusion_elim with (R:=R!). apply tc_incl_rtc. hyp.
Qed.

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

Proof.
  unfold inclusion, 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 inclusion, 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. 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 inclusion, 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 inclusion. 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 inclusion. 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 inclusion. induction 2. apply H. hyp. refl. trans y; hyp. Qed.

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

Proof. unfold inclusion. 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 rtc_incl.
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). omega.
  rewrite H. apply h.
  intros k hk. apply hij. omega.
  induction n; intro h. refl. trans (f (n+i)).
  apply IHn. intros k hk. apply h. omega.
  apply rt_step. apply h. omega.
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.

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.

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

Instance transp_inclusion A : Proper (inclusion ==> inclusion) (@transp A).

Proof. fo. Qed.

Instance transp_same_rel A : Proper (same_rel ==> same_rel) (@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 inclusion. 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 inclusion. 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 inclusion_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 inclusion. 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 inclusion. 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 inclusion. intros. destruct H0. subst y. refl.
  apply inclusion_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 inclusion. 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 inclusion. 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 inclusion. 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 inclusion. 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 inclusion. 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.

  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.

Instance Rof_incl A B :
  Proper (inclusion ==> Logic.eq ==> inclusion) (@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.

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.

Instance rtc1_trans 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.

(*REMOVE?
Lemma incl_rt_rt_rt A (R : rel A) : R#1 @ R#1 << R#1.

Proof.
  intros x y [z [xRz zRy]]. induction xRz.
  trivial.
  apply rt1_trans with y0. hyp.
  apply IHxRz. 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 oz].
  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_trans 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_trans 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_trans 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_trans 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_trans with q. *)
(*   apply rtc1_trans with p. *)
(*   apply union_rel_rt1_right. hyp. *)
(*   apply union_rel_rt1_left. apply tc1_incl_rtc1. hyp.     *)
(*   hyp. *)
(* Qed. *)

(***********************************************************************)
(** Morphisms wrt [inclusion] and [same_rel] *)

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

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

Instance Reflexive_same_rel A : Proper (same_rel ==> impl) (@Reflexive A).

Proof. fo. Qed.

Instance Symmetric_same_rel A : Proper (same_rel ==> impl) (@Symmetric A).

Proof. fo. Qed.

Instance Transitive_same_rel A : Proper (same_rel ==> 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.

Instance Equivalence_same_rel A : Proper (same_rel ==> impl) (@Equivalence A).

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

Lemma Proper_inclusion_1 A1 B f :
  Proper (@inclusion A1 --> @inclusion B ==> impl)
  (fun R1 S => Proper (R1 ==> S) f).

Proof. fo. Qed.

Lemma Proper_inclusion_2 A1 A2 B f :
  Proper (@inclusion A1 --> @inclusion A2 --> @inclusion B ==> impl)
  (fun R1 R2 S => Proper (R1 ==> R2 ==> S) f).

Proof.
  intros R1 R1' R1'R1 R2 R2' R2'R2 S S' SS' hf x1 x1' x1x1' x2 x2' x2x2'.
  apply R1'R1 in x1x1'. apply R2'R2 in x2x2'. apply SS'. apply hf; hyp.
Qed.

Lemma Proper_inclusion_3 A1 A2 A3 B f : Proper
  (@inclusion A1 --> @inclusion A2 --> @inclusion A3 --> @inclusion B ==> impl)
  (fun R1 R2 R3 S => Proper (R1 ==> R2 ==> R3 ==> S) f).

Proof.
  intros R1 R1' R1'R1 R2 R2' R2'R2 R3 R3' R3'R3 S S' SS' hf
    x1 x1' x1x1' x2 x2' x2x2' x3 x3' x3x3'.
  apply R1'R1 in x1x1'. apply R2'R2 in x2x2'. apply R3'R3 in x3x3'.
  apply SS'. apply hf; hyp.
Qed.

Lemma Proper_inclusion_4 A1 A2 A3 A4 B f : Proper
  (@inclusion A1 --> @inclusion A2 --> @inclusion A3 --> @inclusion A4 -->
    @inclusion B ==> impl)
  (fun R1 R2 R3 R4 S => Proper (R1 ==> R2 ==> R3 ==> R4 ==> S) f).

Proof.
  intros R1 R1' R1'R1 R2 R2' R2'R2 R3 R3' R3'R3 R4 R4' R4'R4 S S' SS' hf
    x1 x1' x1x1' x2 x2' x2x2' x3 x3' x3x3' x4 x4' x4x4'.
  apply R1'R1 in x1x1'. apply R2'R2 in x2x2'. apply R3'R3 in x3x3'.
  apply R4'R4 in x4x4'. apply SS'. apply hf; hyp.
Qed.

Instance Proper2_proper A (E : rel A) :
  Proper (same_rel ==> 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.

(***********************************************************************)
(** 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_Proper : 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.

Instance opt_incl A : Proper (inclusion ==> inclusion) (@opt A).

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

Instance opt_proper 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_proper 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.
    (*COQ:rewrite <- xx', <- yy'.*)
    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.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Bool Reals Psatz.
From Coquelicot Require Import Coquelicot.
From mathcomp.ssreflect Require Import ssreflect.

Require Import Stdlib.
Require Import Xreal.
Require Import Basic.

Inductive interval : Set :=
  | Inan : interval
  | Ibnd (l u : ExtendedR) : interval.

Definition Xlower (xi : interval) : ExtendedR :=
  match xi with
  | Ibnd xl _ => xl
  | _ => Xnan
  end.

Definition Xupper (xi : interval) : ExtendedR :=
  match xi with
  | Ibnd _ xu => xu
  | _ => Xnan
  end.

Definition contains i v :=
  match i, v with
  | Ibnd l u, Xreal x =>
    match l with
    | Xreal r => Rle r x
    | Xnan => True
    end /\
    match u with
    | Xreal r => Rle x r
    | Xnan => True
    end
  | Inan, _ => True
  | _, Xnan => False
  end.

Lemma contains_connected :
  forall xi, connected (fun x => contains xi (Xreal x)).
Proof.
intros [|l u] a b Ha Hb x Hx.
exact I.
split.
destruct l as [|l].
exact I.
exact (Rle_trans _ _ _ (proj1 Ha) (proj1 Hx)).
destruct u as [|u].
exact I.
exact (Rle_trans _ _ _ (proj2 Hx) (proj2 Hb)).
Qed.

Lemma contains_Xnan :
  forall xi, contains xi Xnan <-> xi = Inan.
Proof.
intros xi.
now case xi ; split.
Qed.

Lemma contains_Inan :
  forall xi x, xi = Inan -> contains xi x.
Proof.
now intros xi x ->.
Qed.

Lemma contains_le :
  forall xl xu v,
  contains (Ibnd xl xu) v ->
  le_lower xl v /\ le_upper v xu.
Proof.
intros xl xu v.
case v.
intro.
elim H.
intros r.
case xl.
intro.
exact H.
intros l (Hl, Hu).
split.
exact (Ropp_le_contravar _ _ Hl).
exact Hu.
Qed.

Lemma le_contains :
  forall xl xu v,
  le_lower xl (Xreal v) -> le_upper (Xreal v) xu ->
  contains (Ibnd xl xu) (Xreal v).
Proof.
intros xl xu v.
case xl.
intros _ Hu.
exact (conj I Hu).
intros l Hl Hu.
split.
exact (Ropp_le_cancel _ _ Hl).
exact Hu.
Qed.

Definition subset xi yi :=
  match xi, yi with
  | Ibnd xl xu, Ibnd yl yu =>
    match xl, xu with
    | Xreal xl, Xreal xu => (xu < xl)%R
    | _, _ => False
    end
    \/ (le_lower yl xl /\ le_upper xu yu)
  | _, Inan => True
  | _, _ => False
  end.

Definition subset' xi yi :=
  forall x, contains xi x -> contains yi x.

Theorem subset_contains :
  forall xi yi,
  subset xi yi ->
  subset' xi yi.
Proof.
intros xi yi.
destruct yi as [|yl yu].
easy.
destruct xi as [|xl xu].
easy.
intros [H|H]; revert H.
{ case xl; [now simpl|]; intro rxl.
  case xu; [now simpl|]; intros rxu Hr [|x] H; [now simpl|].
  exfalso; apply (Rlt_irrefl rxl); revert Hr; apply Rle_lt_trans.
  elim H; apply Rle_trans. }
intros [H1 H2] [|v] Hv.
easy.
apply contains_le in Hv.
apply le_contains.
now apply le_lower_trans with (1 := H1).
now apply le_upper_trans with (2 := H2).
Qed.

Definition domain' P b :=
  forall x, contains b (Xreal x) -> P x.

Theorem bisect' :
  forall P xl xm xu,
  domain' P (Ibnd xl xm) ->
  domain' P (Ibnd xm xu) ->
  domain' P (Ibnd xl xu).
Proof.
intros P xl xm xu Hl Hu x H.
elim H.
case_eq xm ; intros.
apply Hu.
rewrite H0.
exact (conj I (proj2 H)).
case (Rle_dec x r) ; intros Hr.
apply Hl.
apply le_contains.
exact (proj1 (contains_le _ _ _ H)).
rewrite H0.
exact Hr.
apply Hu.
apply le_contains.
rewrite H0.
unfold le_lower.
simpl.
apply Ropp_le_contravar.
auto with real.
exact (proj2 (contains_le _ _ _ H)).
Qed.

Definition not_empty xi :=
  exists v, contains xi (Xreal v).

Lemma contains_lower :
  forall l u x,
  contains (Ibnd (Xreal l) u) x ->
  contains (Ibnd (Xreal l) u) (Xreal l).
Proof.
intros.
split.
apply Rle_refl.
destruct x as [|x].
elim H.
destruct u as [|u].
exact I.
apply Rle_trans with (1 := proj1 H) (2 := proj2 H).
Qed.

Lemma contains_upper :
  forall l u x,
  contains (Ibnd l (Xreal u)) x ->
  contains (Ibnd l (Xreal u)) (Xreal u).
Proof.
intros.
split.
destruct x as [|x].
elim H.
destruct l as [|l].
exact I.
apply Rle_trans with (1 := proj1 H) (2 := proj2 H).
apply Rle_refl.
Qed.

Module Type IntervalBasicOps.

Parameter bound_type : Type.
Parameter valid_lb : bound_type -> Prop.
Parameter valid_ub : bound_type -> Prop.
Parameter nan : bound_type.
Parameter convert_bound : bound_type -> ExtendedR.
Parameter type : Type.
Parameter convert : type -> interval.
Parameter zero : type.
Parameter nai : type.
Parameter empty : type.
Parameter bnd : bound_type -> bound_type -> type.
Parameter real : type -> bool.

Parameter valid_lb_real :
  forall b, convert_bound b = Xreal (proj_val (convert_bound b)) -> valid_lb b.

Parameter valid_ub_real :
  forall b, convert_bound b = Xreal (proj_val (convert_bound b)) -> valid_ub b.

Parameter valid_lb_nan : valid_lb nan.

Parameter valid_ub_nan : valid_ub nan.

Parameter bnd_correct :
  forall l u, valid_lb l -> valid_ub u ->
  convert (bnd l u) = Ibnd (convert_bound l) (convert_bound u).

Parameter zero_correct :
  convert zero = Ibnd (Xreal 0) (Xreal 0).

Parameter nai_correct :
  convert nai = Inan.

Parameter empty_correct :
  forall x, contains (convert empty) x -> False.

Parameter real_correct :
  forall xi, real xi = match convert xi with Inan => false | _ => true end.

Local Notation subset_ := subset.

Parameter subset : type -> type -> bool.

Parameter subset_correct :
  forall xi yi : type,
  subset xi yi = true -> subset_ (convert xi) (convert yi).

Parameter join : type -> type -> type.
Parameter meet : type -> type -> type.
Parameter sign_large : type -> Xcomparison.
Parameter sign_strict : type -> Xcomparison.

Parameter sign_large_correct :
  forall xi,
  match sign_large xi with
  | Xeq => forall x, contains (convert xi) x -> x = Xreal 0
  | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle (proj_val x) 0
  | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle 0 (proj_val x)
  | Xund => True
  end.

Parameter sign_strict_correct :
  forall xi,
  match sign_strict xi with
  | Xeq => forall x, contains (convert xi) x -> x = Xreal 0
  | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt (proj_val x) 0
  | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt 0 (proj_val x)
  | Xund => True
  end.

Parameter join_correct :
  forall xi yi v,
  contains (convert xi) v \/ contains (convert yi) v ->
  contains (convert (join xi yi)) v.

Parameter meet_correct :
  forall xi yi v,
  contains (convert xi) v -> contains (convert yi) v ->
  contains (convert (meet xi yi)) v.

Parameter meet_correct' :
  forall xi yi v,
  contains (convert (meet xi yi)) v ->
  contains (convert xi) v /\ contains (convert yi) v.

Parameter midpoint : type -> bound_type.

Parameter midpoint_correct :
  forall xi,
  (exists x, contains (convert xi) x) ->
  convert_bound (midpoint xi) = Xreal (proj_val (convert_bound (midpoint xi))) /\
  contains (convert xi) (convert_bound (midpoint xi)).

Parameter midpoint' : type -> type.

Parameter midpoint'_correct :
  forall xi,
  (forall x, contains (convert (midpoint' xi)) x -> contains (convert xi) x) /\
  (not_empty (convert xi) -> not_empty (convert (midpoint' xi))).

Parameter bisect : type -> type * type.

Parameter bisect_correct :
  forall xi x,
  contains (convert xi) x ->
  contains (convert (fst (bisect xi))) x \/ contains (convert (snd (bisect xi))) x.

Definition extension f fi := forall b x,
  contains (convert b) x -> contains (convert (fi b)) (f x).

Definition extension_2 f fi := forall ix iy x y,
  contains (convert ix) x ->
  contains (convert iy) y ->
  contains (convert (fi ix iy)) (f x y).

Parameter mask : type -> type -> type.

Parameter mask_correct : extension_2 Xmask mask.
Parameter mask_correct' :
  forall xi yi x,
  contains (convert xi) x ->
  contains (convert (mask xi yi)) x.

Parameter precision : Type.

Parameter wider : precision -> type -> type -> bool.

Parameter neg : type -> type.
Parameter abs : type -> type.
Parameter inv : precision -> type -> type.
Parameter sqr : precision -> type -> type.
Parameter sqrt : precision -> type -> type.
Parameter add : precision -> type -> type -> type.
Parameter sub : precision -> type -> type -> type.
Parameter mul : precision -> type -> type -> type.
Parameter div : precision -> type -> type -> type.
Parameter power_int : precision -> type -> Z -> type.
Parameter nearbyint : rounding_mode -> type -> type.

Parameter neg_correct : extension Xneg neg.
Parameter abs_correct : extension Xabs abs.
Parameter inv_correct : forall prec, extension Xinv (inv prec).
Parameter sqr_correct : forall prec, extension Xsqr (sqr prec).
Parameter sqrt_correct : forall prec, extension Xsqrt (sqrt prec).
Parameter add_correct : forall prec, extension_2 Xadd (add prec).
Parameter sub_correct : forall prec, extension_2 Xsub (sub prec).
Parameter mul_correct : forall prec, extension_2 Xmul (mul prec).
Parameter div_correct : forall prec, extension_2 Xdiv (div prec).
Parameter power_int_correct : forall prec n, extension (fun x => Xpower_int x n) (fun x => power_int prec x n).
Parameter nearbyint_correct : forall mode, extension (Xnearbyint mode) (nearbyint mode).

Parameter neg_correct' :
  forall xi x,
  contains (convert (neg xi)) (Xneg x) ->
  contains (convert xi) x.

Parameter cancel_add : precision -> type -> type -> type.
Parameter cancel_sub : precision -> type -> type -> type.

Parameter bounded : type -> bool.
Parameter lower_bounded : type -> bool.
Parameter upper_bounded : type -> bool.

Parameter lower_extent : type -> type.
Parameter upper_extent : type -> type.
Parameter whole : type.

Parameter lower_extent_correct :
  forall xi x y,
  contains (convert xi) (Xreal y) ->
  (x <= y)%R ->
  contains (convert (lower_extent xi)) (Xreal x).

Parameter upper_extent_correct :
  forall xi x y,
  contains (convert xi) (Xreal y) ->
  (y <= x)%R ->
  contains (convert (upper_extent xi)) (Xreal x).

Parameter whole_correct :
  forall x,
  contains (convert whole) (Xreal x).

Parameter lower_complement : type -> type.
Parameter upper_complement : type -> type.

Parameter lower_complement_correct :
  forall xi x y,
  contains (convert xi) (Xreal x) ->
  contains (convert (lower_complement xi)) (Xreal y) ->
  (y <= x)%R.

Parameter upper_complement_correct :
  forall xi x y,
  contains (convert xi) (Xreal x) ->
  contains (convert (upper_complement xi)) (Xreal y) ->
  (x <= y)%R.

Parameter lower : type -> bound_type.
Parameter upper : type -> bound_type.

Parameter lower_correct :
  forall xi : type,
  not_empty (convert xi) ->
  convert_bound (lower xi) = Xlower (convert xi).

Parameter valid_lb_lower :
  forall xi : type,
  not_empty (convert xi) ->
  valid_lb (lower xi).

Parameter upper_correct :
  forall xi : type,
  not_empty (convert xi) ->
  convert_bound (upper xi) = Xupper (convert xi).

Parameter valid_ub_upper :
  forall xi : type,
  not_empty (convert xi) ->
  valid_ub (upper xi).

Definition bounded_prop xi :=
  not_empty (convert xi) ->
  convert xi = Ibnd (convert_bound (lower xi)) (convert_bound (upper xi)).

Parameter lower_bounded_correct :
  forall xi,
  lower_bounded xi = true ->
  convert_bound (lower xi) = Xreal (proj_val (convert_bound (lower xi))) /\
  bounded_prop xi.

Parameter upper_bounded_correct :
  forall xi,
  upper_bounded xi = true ->
  convert_bound (upper xi) = Xreal (proj_val (convert_bound (upper xi))) /\
  bounded_prop xi.

Parameter bounded_correct :
  forall xi,
  bounded xi = true ->
  lower_bounded xi = true /\ upper_bounded xi = true.

Parameter fromZ_small : Z -> type.

Parameter fromZ_small_correct :
  forall v,
  (Z.abs v <= 256)%Z ->
  contains (convert (fromZ_small v)) (Xreal (IZR v)).

Parameter fromZ : precision -> Z -> type.

Parameter fromZ_correct :
  forall prec v, contains (convert (fromZ prec v)) (Xreal (IZR v)).

Definition propagate_l fi :=
  forall xi yi : type, convert xi = Inan -> convert (fi xi yi) = Inan.
Definition propagate_r fi :=
  forall xi yi : type, convert yi = Inan -> convert (fi xi yi) = Inan.

Parameter mask_propagate_l : propagate_l mask.
Parameter mask_propagate_r : propagate_r mask.
Parameter add_propagate_l : forall prec, propagate_l (add prec).
Parameter sub_propagate_l : forall prec, propagate_l (sub prec).
Parameter mul_propagate_l : forall prec, propagate_l (mul prec).
Parameter div_propagate_l : forall prec, propagate_l (div prec).
Parameter add_propagate_r : forall prec, propagate_r (add prec).
Parameter sub_propagate_r : forall prec, propagate_r (sub prec).
Parameter mul_propagate_r : forall prec, propagate_r (mul prec).
Parameter div_propagate_r : forall prec, propagate_r (div prec).

End IntervalBasicOps.

Module Type IntervalOps.

Include IntervalBasicOps.

Parameter pi : precision -> type.
Parameter cos : precision -> type -> type.
Parameter sin : precision -> type -> type.
Parameter tan : precision -> type -> type.
Parameter atan : precision -> type -> type.
Parameter exp : precision -> type -> type.
Parameter ln : precision -> type -> type.

Parameter pi_correct : forall prec, contains (convert (pi prec)) (Xreal PI).
Parameter cos_correct : forall prec, extension Xcos (cos prec).
Parameter sin_correct : forall prec, extension Xsin (sin prec).
Parameter tan_correct : forall prec, extension Xtan (tan prec).
Parameter atan_correct : forall prec, extension Xatan (atan prec).
Parameter exp_correct : forall prec, extension Xexp (exp prec).
Parameter ln_correct : forall prec, extension Xln (ln prec).

End IntervalOps.

Module IntervalBasicExt (I : IntervalBasicOps).

Definition propagate fi :=
  forall xi, I.convert xi = Inan -> I.convert (fi xi) = Inan.

Lemma propagate_extension :
  forall fi f, I.extension (Xbind f) fi -> propagate fi.
Proof.
intros fi f Hf xi H.
specialize (Hf xi Xnan).
rewrite H in Hf.
specialize (Hf I).
clear -Hf.
now destruct I.convert.
Qed.

Lemma neg_propagate : propagate I.neg.
Proof.
apply propagate_extension with (1 := I.neg_correct).
Qed.

Lemma inv_propagate : forall prec, propagate (I.inv prec).
Proof.
intros prec.
apply propagate_extension with (1 := I.inv_correct prec).
Qed.

Lemma sqrt_propagate : forall prec, propagate (I.sqrt prec).
Proof.
intros prec.
apply propagate_extension with (1 := I.sqrt_correct prec).
Qed.

Lemma power_int_propagate : forall prec n, propagate (fun x => I.power_int prec x n).
Proof.
intros prec n.
apply propagate_extension with (1 := I.power_int_correct prec n).
Qed.

Definition extension f fi :=
  forall (xi : I.type) (x : R),
  contains (I.convert xi) (Xreal x) ->
  contains (I.convert (fi xi)) (Xreal (f x)).

Definition extension_2 f fi :=
  forall (xi yi : I.type) (x y : R),
  contains (I.convert xi) (Xreal x) ->
  contains (I.convert yi) (Xreal y) ->
  contains (I.convert (fi xi yi)) (Xreal (f x y)).

Lemma neg_correct : extension Ropp I.neg.
Proof.
intros xi x.
now apply I.neg_correct.
Qed.

Lemma abs_correct : extension Rabs I.abs.
Proof.
intros xi x.
now apply I.abs_correct.
Qed.

Lemma inv_correct : forall prec, extension Rinv (I.inv prec).
Proof.
intros prec xi x Hx.
generalize (I.inv_correct prec xi _ Hx).
unfold Xinv', Xbind.
case is_zero ; try easy.
now case I.convert.
Qed.

Lemma sqr_correct : forall prec, extension Rsqr (I.sqr prec).
Proof.
intros prec xi x.
now apply I.sqr_correct.
Qed.

Lemma sqrt_correct : forall prec, extension sqrt (I.sqrt prec).
Proof.
intros prec xi x Hx.
generalize (I.sqrt_correct prec xi _ Hx).
unfold Xsqrt', Xbind.
case is_negative ; try easy.
Qed.

Lemma add_correct : forall prec, extension_2 Rplus (I.add prec).
Proof.
intros prec xi yi x y.
now apply I.add_correct.
Qed.

Lemma sub_correct : forall prec, extension_2 Rminus (I.sub prec).
Proof.
intros prec xi yi x y.
now apply I.sub_correct.
Qed.

Lemma mul_correct : forall prec, extension_2 Rmult (I.mul prec).
Proof.
intros prec xi yi x y.
now apply I.mul_correct.
Qed.

Lemma div_correct : forall prec, extension_2 Rdiv (I.div prec).
Proof.
intros prec xi yi x y Hx Hy.
generalize (I.div_correct prec _ _ _ _ Hx Hy).
simpl. unfold Xdiv'.
case is_zero ; try easy.
now case I.convert.
Qed.

Lemma nearbyint_correct :
  forall mode, extension (Rnearbyint mode) (I.nearbyint mode).
Proof.
intros mode xi x.
now apply I.nearbyint_correct.
Qed.

Lemma power_int_correct :
  forall prec n, extension (fun x => powerRZ x n) (fun xi => I.power_int prec xi n).
Proof.
intros prec n xi x Hx.
generalize (I.power_int_correct prec n xi _ Hx).
unfold Xpower_int, Xpower_int', Xbind.
destruct n as [|n|n] ; try easy.
case is_zero ; try easy.
now case I.convert.
Qed.

Lemma zero_correct : contains (I.convert I.zero) (Xreal 0).
Proof.
rewrite I.zero_correct.
split ; apply Rle_refl.
Qed.

Lemma contains_only_0 r :
  contains (I.convert I.zero) (Xreal r) -> r = 0%R.
Proof.
rewrite I.zero_correct.
intros [H1 H2].
now apply Rle_antisym.
Qed.

Lemma join_correct :
  forall ui vi u v x,
  contains (I.convert ui) (Xreal u) ->
  contains (I.convert vi) (Xreal v) ->
  (u <= x <= v)%R ->
  contains (I.convert (I.join ui vi)) (Xreal x).
Proof.
intros ui vi u v x Iu Iv [H1 H2].
assert (Hu := I.join_correct ui vi (Xreal u)).
assert (Hv := I.join_correct ui vi (Xreal v)).
destruct (I.convert (I.join ui vi)) as [|p q].
easy.
split.
destruct p as [|p].
easy.
apply Rle_trans with (2 := H1).
apply Hu.
now left.
destruct q as [|q].
easy.
apply Rle_trans with (1 := H2).
apply Hv.
now right.
Qed.

Lemma contains_RInt prec (f3 : R -> R) x1 x2 Y X1 X2 :
  ex_RInt f3 x1 x2->
  contains (I.convert X1) (Xreal x1) ->
  contains (I.convert X2) (Xreal x2) ->
  (forall x, (Rmin x1 x2 <= x <= Rmax x1 x2)%R -> contains (I.convert Y) (Xreal (f3 x))) ->
  contains (I.convert (I.mul prec (I.sub prec X2 X1) Y)) (Xreal (RInt f3 x1 x2)).
Proof.
move => Hf3_int HZx1 HZx2 Hext.
destruct (Req_dec x2 x1) as [H|H].
  rewrite H RInt_point /zero /= -(Rmult_0_l (f3 x1)) -(Rminus_diag_eq x2 x1) //.
  apply: mul_correct.
  exact: sub_correct.
  apply: Hext.
  exact: Rmin_Rmax_l.
have -> : (RInt f3 x1 x2 = (x2 - x1) * ((RInt f3 x1 x2) / (x2 - x1)))%R.
  rewrite /Rdiv (Rmult_comm _ (Rinv _)) -Rmult_assoc Rinv_r ?Rmult_1_l //.
  exact: Rminus_eq_contra.
apply: mul_correct.
exact: sub_correct.
wlog H': x1 x2 {H HZx1 HZx2} Hext Hf3_int / (x1 < x2)%R.
  intros H'.
  destruct (Rdichotomy _ _ H) as [H21|H12].
  rewrite -opp_RInt_swap.
  replace (-_/_)%R with (RInt f3 x2 x1 / (x1 - x2))%R by (field; lra).
  apply: H' H21.
  by rewrite Rmin_comm Rmax_comm.
  exact: ex_RInt_swap.
  exact: ex_RInt_swap.
  exact: H'.
case: (I.convert Y) Hext => // l u Hext.
apply: le_contains.
- rewrite /le_lower /le_upper /=.
  case: l Hext => //= rl Hext.
  apply: Ropp_le_contravar.
  apply: RInt_le_l => // x Hx.
  apply Hext.
  now rewrite -> Rmin_left, Rmax_right ; try apply Rlt_le.
- rewrite /le_upper /=.
  case: u Hext => //= ru Hext.
  apply: RInt_le_r => // x Hx.
  apply Hext.
  now rewrite -> Rmin_left, Rmax_right ; try apply Rlt_le.
Qed.

End IntervalBasicExt.

Module IntervalExt (I : IntervalOps).

Include (IntervalBasicExt I).

Lemma cos_correct : forall prec, extension cos (I.cos prec).
Proof.
intros prec xi x.
now apply I.cos_correct.
Qed.

Lemma sin_correct : forall prec, extension sin (I.sin prec).
Proof.
intros prec xi x.
now apply I.sin_correct.
Qed.

Lemma tan_correct : forall prec, extension tan (I.tan prec).
Proof.
intros prec xi x Hx.
generalize (I.tan_correct prec xi _ Hx).
unfold Xtan', Xbind.
case is_zero ; try easy.
now case I.convert.
Qed.

Lemma atan_correct : forall prec, extension atan (I.atan prec).
Proof.
intros prec xi x.
now apply I.atan_correct.
Qed.

Lemma exp_correct : forall prec, extension exp (I.exp prec).
Proof.
intros prec xi x.
now apply I.exp_correct.
Qed.

Lemma ln_correct : forall prec, extension ln (I.ln prec).
Proof.
intros prec xi x Hx.
generalize (I.ln_correct prec xi _ Hx).
unfold Xln', Xbind.
case is_positive ; try easy.
now case I.convert.
Qed.

End IntervalExt.


From Equations Require Import Equations.
Require Import List.

Inductive In {X} (x : X) : list X -> Type :=
| here {xs} : In x (x :: xs)
| there {y xs} : In x xs -> In x (y :: xs).
Derive Signature NoConfusion for In.
Notation " x ∈ xs " := (In x xs) (at level 70, xs at level 10).
Arguments here {X x xs}.
Arguments there {X x y xs} _.
Check (there here) : 26 ∈ (43 :: 26 :: 76 :: nil).

(* Does coq-equations mistake variable names sometimes? *)

Set Equations Debug.

Equations repl {A} (R : list A) prev (idx : prev ∈ R) (next : A) : list A :=
  repl (X :: XS) X here         next := next :: XS;
  repl (X :: XS) prev (there idx') next := X :: (repl XS prev idx' next).

Equations repl' {A} (R : list A) {prev} (idx : prev ∈ R) (next : A) : list A :=
  repl' (X :: XS) here         next := next :: XS;
  repl' (X :: XS) (there idx') next := X :: (repl' XS idx' next).


Require Import ZArith.
Require Export String.
From mathcomp Require Import all_ssreflect.
Require Import utils gen_map.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* -------------------------------------------------------------------- *)
Scheme Equality for Ascii.ascii.
(* ascii_beq :  Ascii.ascii ->  Ascii.ascii -> bool *)
(* ascii_eq_dec *)

Lemma ascii_eqP : Equality.axiom ascii_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_ascii_dec_bl.
  by apply: internal_ascii_dec_lb.
Qed.

Definition ascii_eqMixin := EqMixin ascii_eqP.
Canonical  ascii_eqType  := EqType Ascii.ascii ascii_eqMixin.

Definition ascii_choiceMixin := CanChoiceMixin Ascii.ascii_nat_embedding.
Canonical  ascii_choiceType  := ChoiceType Ascii.ascii ascii_choiceMixin.

Definition ascii_countMixin := CanCountMixin Ascii.ascii_nat_embedding.
Canonical  ascii_countType  := CountType Ascii.ascii ascii_countMixin.

Definition ascii_cmp (c c': Ascii.ascii) :=
  match c, c' with
  | Ascii.Ascii b1  b2  b3  b4  b5  b6  b7  b8,
    Ascii.Ascii b1' b2' b3' b4' b5' b6' b7' b8' =>
     Lex (bool_cmp b1 b1')
    (Lex (bool_cmp b2 b2')
    (Lex (bool_cmp b3 b3')
    (Lex (bool_cmp b4 b4')
    (Lex (bool_cmp b5 b5')
    (Lex (bool_cmp b6 b6')
    (Lex (bool_cmp b7 b7') (bool_cmp b8 b8')))))))
  end.

#[global]
Instance asciiO : Cmp ascii_cmp.
Proof.
  constructor=> [[]????????| []???????? []???????? | []????????][] ???????? /=;
    rewrite !Lex_lex.
  + by apply @cmp_sym; do !(apply LexO;[apply boolO | ]);apply boolO.
  + by move=> c;apply @cmp_ctrans; do !(apply LexO;[apply boolO | ]);apply boolO.
  do !move=> /lex_eq [] /= /(@cmp_eq _ _ boolO) ->.
  by move=> /(@cmp_eq _ _ boolO) ->.
Qed.

(* -------------------------------------------------------------------- *)
Scheme Equality for String.string.
(* string_beq is defined
   string_eq_dec is defined *)

Lemma string_eqP : Equality.axiom string_beq.
Proof.
  move=> x y;apply:(iffP idP).
  + by apply: internal_string_dec_bl.
  by apply: internal_string_dec_lb.
Qed.

Definition string_eqMixin := EqMixin string_eqP.
Canonical  string_eqType  := EqType string string_eqMixin.

Fixpoint string_cmp s1 s2 :=
  match s1, s2 with
  | EmptyString , String _  _  => Lt
  | EmptyString , EmptyString  => Eq
  | String c1 s1, String c2 s2 => Lex (ascii_cmp c1 c2) (string_cmp s1 s2)
  | String _  _ , EmptyString  => Gt
  end.

#[global]
Instance stringO: Cmp string_cmp.
Proof.
  constructor.
  + elim=> [ | c1 s1 Hs1] [ | c2 s2] //=.
    rewrite !Lex_lex;apply lex_sym. apply asciiO. apply Hs1.
  + move=> y x;elim:x y => [ | cx sx Hs] [ | cy sy] [ | cz sz] c //=; try by apply ctrans_Eq.
    + by apply ctrans_Lt. + by apply ctrans_Gt.
    rewrite !Lex_lex;apply lex_trans;[apply cmp_ctrans | apply Hs].
  elim=> [ | c1 s1 Hs1] [ | c2 s2] //=.
  by rewrite Lex_lex=> /lex_eq /= [] /(@cmp_eq _ _ asciiO) -> /Hs1 ->.
Qed.

(* -------------------------------------------------------------------- *)
(*
Definition a2P_app c n :=
  match c with
  | Ascii.Ascii b1 b2 b3 b4 b5 b6 b7 b8 =>
    b2P_app b1 (b2P_app b2 (b2P_app b3 (b2P_app b4
      (b2P_app b5 (b2P_app b6 (b2P_app b7 (b2P_app b8 n)))))))
  end.

Definition a2P c := a2P_app c xH.

Lemma a2P_appP c n : a2P_app c n = FMapPositive.append (a2P c) n.
Proof. by case: c=> * => /=;rewrite !b2P_appP -!appendA. Qed.

Lemma log_a2P c : log_inf (a2P c) = 8%Z.
Proof. by case: c=> * /=;rewrite !log_b2P_app. Qed.

Lemma a2P_app_inj c1 c2 n1 n2 : a2P_app c1 n1 = a2P_app c2 n2 -> c1 = c2 /\ n1 = n2.
Proof.
  case: c1 => ???? ????; case: c2 => ???? ???? /=.
  by do !(move=> /b2P_app_inj [] ->).
Qed.

Fixpoint s2P_app s n:=
  match s with
  | EmptyString => n
  | String c s => s2P_app s (a2P_app c n)
  end.

Definition s2P s := s2P_app s xH.

Lemma s2P_appP s n : s2P_app s n = FMapPositive.append (s2P s) n.
Proof.
  elim: s n => [ | c s Hs] n //=.
  by rewrite /s2P /= !Hs /= a2P_appP -!appendA.
Qed.

Lemma s2P_app_inj s1 s2 n1 n2:
  log_inf n1 = log_inf n2 ->
  s2P_app s1 n1 = s2P_app s2 n2 -> s1 = s2 /\ n1 = n2.
Proof.
  elim: s1 s2 n1 n2 => [ | c1 s1 Hs1] [ | c2 s2] //= n1 n2 Hlog.
  + move=> Heq;move:Hlog;rewrite Heq.
    rewrite s2P_appP a2P_appP !log_app log_a2P=> ?.
    by have ?:= log_inf_correct1 (s2P s2);omega.
  + move=> Heq;move:Hlog;rewrite -Heq.
    rewrite s2P_appP a2P_appP !log_app log_a2P=> ?.
    by have ?:= log_inf_correct1 (s2P s1);omega.
  move=> /Hs1 [].
  + by rewrite !a2P_appP !log_app !log_a2P Hlog.
  by move=> -> /a2P_app_inj [] -> ->.
Qed.

Lemma s2P_inj : injective s2P.
Proof. by move=> s1 s2;rewrite /s2P => /s2P_app_inj []. Qed.

Module InjString.

  Definition t := [eqType of string].

  Definition t2P := s2P.

  Definition t2P_inj := s2P_inj.

End InjString.
*)

Module CmpString.

  Definition t : eqType := [eqType of string].

  Definition cmp : t -> t -> comparison := string_cmp.

  Definition cmpO : Cmp cmp := stringO.

End CmpString.

Module Ms := Mmake CmpString.
Declare Scope mstring_scope.
Delimit Scope mstring_scope with ms.
Notation "m .[ x ]" := (@Ms.get _ m x) : mstring_scope.
Notation "m .[ x  <- v ]" := (@Ms.set _ m x v) : mstring_scope.
Arguments Ms.get T%type_scope m%mstring_scope k.
Arguments Ms.set T%type_scope m%mstring_scope k v.


From Hammer Require Import Hammer.

From ZornsLemma Require Export FunctionProperties.
From ZornsLemma Require Import DecidableDec.
Require Import Description.
Require Import Classical.

Section CSB.
Variable X Y:Type.
Variable f:X->Y.
Variable g:Y->X.
Hypothesis f_inj: injective f.
Hypothesis g_inj: injective g.

Inductive X_even: X->Prop :=
| not_g_img: forall x:X, (forall y:Y, g y <> x) -> X_even x
| g_Y_odd: forall y:Y, Y_odd y -> X_even (g y)
with Y_odd: Y->Prop :=
| f_X_even: forall x:X, X_even x -> Y_odd (f x).
Inductive X_odd: X->Prop :=
| g_Y_even: forall y:Y, Y_even y -> X_odd (g y)
with Y_even: Y->Prop :=
| not_f_img: forall y:Y, (forall x:X, f x <> y) -> Y_even y
| f_X_odd: forall x:X, X_odd x -> Y_even (f x).

Scheme X_even_coind := Minimality for X_even Sort Prop
with Y_odd_coind := Minimality for Y_odd Sort Prop.
Scheme X_odd_coind := Minimality for X_odd Sort Prop
with Y_even_coind := Minimality for Y_even Sort Prop.

Lemma even_odd_excl: forall x:X, ~(X_even x /\ X_odd x).
Proof. hammer_hook "CSB" "CSB.even_odd_excl".
intro.
assert (X_even x -> ~ X_odd x).
2:tauto.
pose proof (X_even_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H.
intuition.
destruct H1.
apply H0 with y.
reflexivity.
intuition.
inversion H2.
apply g_inj in H3.
apply H1.
rewrite <- H3.
assumption.
intuition.
inversion H2.
apply H3 with x0.
reflexivity.
apply f_inj in H3.
apply H1.
rewrite <- H3.
assumption.
Qed.

Lemma even_odd_excl2: forall y:Y, ~(Y_even y /\ Y_odd y).
Proof. hammer_hook "CSB" "CSB.even_odd_excl2".
intro.
assert (Y_odd y -> ~ Y_even y).
2:tauto.
pose proof (Y_odd_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H.
intuition.
destruct H1.
apply H0 with y0.
reflexivity.
intuition.
inversion H2.
apply g_inj in H3.
apply H1.
rewrite <- H3.
assumption.
intuition.
inversion H2.
apply H3 with x.
reflexivity.
apply f_inj in H3.
apply H1.
rewrite <- H3.
assumption.
Qed.

Definition finv: forall y:Y, (exists x:X, f x = y) ->
{ x:X | f x = y }.
intros.
apply constructive_definite_description.
destruct H.
exists x.
red; split.
assumption.
intros.
apply f_inj.
transitivity y; trivial.
symmetry; trivial.
Defined.

Definition ginv: forall x:X, (exists y:Y, g y = x) ->
{ y:Y | g y = x }.
intros.
apply constructive_definite_description.
destruct H.
exists x0.
red; split.
assumption.
intros.
apply g_inj.
transitivity x; trivial; symmetry; trivial.
Defined.

Definition ginv_odd: forall x:X, X_odd x ->
{ y:Y | g y = x }.
intros.
apply ginv.
destruct H.
exists y.
reflexivity.
Defined.

Definition finv_noteven: forall y:Y, ~ Y_even y ->
{ x:X | f x = y }.
intros.
apply finv.
apply NNPP.
red; intro.
contradict H.
constructor 1.
intro; red; intro.
apply H0.
exists x.
assumption.
Defined.

Definition CSB_bijection (x:X) : Y :=
match (classic_dec (X_odd x)) with
| left o => proj1_sig (ginv_odd x o)
| right _ => f x
end.
Definition CSB_bijection2 (y:Y) : X :=
match (classic_dec (Y_even y)) with
| left _ => g y
| right ne => proj1_sig (finv_noteven y ne)
end.

Lemma CSB_comp1: forall x:X, CSB_bijection2 (CSB_bijection x) = x.
Proof. hammer_hook "CSB" "CSB.CSB_comp1".
intro.
unfold CSB_bijection; case (classic_dec (X_odd x)).
intro.
destruct ginv_odd.
simpl.
unfold CSB_bijection2; case (classic_dec (Y_even x1)).
intro.
assumption.
intro.
destruct x0.
contradict n.
apply g_inj in e.
rewrite e.
assumption.
intro.
unfold CSB_bijection2; case (classic_dec (Y_even (f x))).
intro.
contradict n.
inversion y.
pose proof (H x).
contradict H1; reflexivity.
apply f_inj in H.
rewrite <- H.
assumption.
intro.
destruct finv_noteven.
simpl.
apply f_inj.
assumption.
Qed.

Lemma CSB_comp2: forall y:Y, CSB_bijection (CSB_bijection2 y) = y.
Proof. hammer_hook "CSB" "CSB.CSB_comp2".
intro.
unfold CSB_bijection2; case (classic_dec (Y_even y)).
intro.
unfold CSB_bijection; case (classic_dec (X_odd (g y))).
intro.
destruct ginv_odd.
simpl.
apply g_inj.
assumption.
intro.
contradict n.
constructor.
assumption.
intro.
destruct finv_noteven.
simpl.
unfold CSB_bijection; case (classic_dec (X_odd x)).
intro.
contradict n.
rewrite <- e.
constructor 2.
assumption.
trivial.
Qed.

Theorem CSB: exists h:X->Y, bijective h.
Proof. hammer_hook "CSB" "CSB.CSB".
exists CSB_bijection.
apply invertible_impl_bijective.
exists CSB_bijection2.
exact CSB_comp1.
exact CSB_comp2.
Qed.

End CSB.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruencesymmetric.
Require Export lemma__doublereverse.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__equalitysymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__layoff.
Require Export lemma__ray4.
Require Export lemma__rayimpliescollinear.
Require Export lemma__raystrict.
Require Export logic.
Require Export proposition__10.
Definition proposition__09 : forall A B C, (euclidean__axioms.nCol B A C) -> (exists X, (euclidean__defs.CongA B A X X A C) /\ (euclidean__defs.InAngle B A C X)).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (~(A = B)) as H0.
- intro H0.
assert (* Cut *) (B = A) as H1.
-- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric B A H0).
-- assert (* Cut *) (euclidean__axioms.Col B A C) as H2.
--- left.
exact H1.
--- apply (@euclidean__tactics.Col__nCol__False B A C H H2).
- assert (* Cut *) (~(A = C)) as H1.
-- intro H1.
assert (* Cut *) (euclidean__axioms.Col B A C) as H2.
--- right.
right.
left.
exact H1.
--- apply (@euclidean__tactics.Col__nCol__False B A C H H2).
-- assert (* Cut *) (exists E, (euclidean__defs.Out A C E) /\ (euclidean__axioms.Cong A E A B)) as H2.
--- apply (@lemma__layoff.lemma__layoff A C A B H1 H0).
--- destruct H2 as [E H3].
destruct H3 as [H4 H5].
assert (* Cut *) (~(B = E)) as H6.
---- intro H6.
assert (* Cut *) (euclidean__axioms.Col A B E) as H7.
----- right.
right.
left.
exact H6.
----- assert (* Cut *) (euclidean__axioms.Col A C E) as H8.
------ apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear A C E H4).
------ assert (* Cut *) (euclidean__axioms.Col E A B) as H9.
------- assert (* Cut *) ((euclidean__axioms.Col B A E) /\ ((euclidean__axioms.Col B E A) /\ ((euclidean__axioms.Col E A B) /\ ((euclidean__axioms.Col A E B) /\ (euclidean__axioms.Col E B A))))) as H9.
-------- apply (@lemma__collinearorder.lemma__collinearorder A B E H7).
-------- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H14.
------- assert (* Cut *) (euclidean__axioms.Col E A C) as H10.
-------- assert (* Cut *) ((euclidean__axioms.Col C A E) /\ ((euclidean__axioms.Col C E A) /\ ((euclidean__axioms.Col E A C) /\ ((euclidean__axioms.Col A E C) /\ (euclidean__axioms.Col E C A))))) as H10.
--------- apply (@lemma__collinearorder.lemma__collinearorder A C E H8).
--------- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H15.
-------- assert (* Cut *) (euclidean__axioms.neq A E) as H11.
--------- apply (@eq__ind__r euclidean__axioms.Point E (fun B0 => (euclidean__axioms.nCol B0 A C) -> ((~(A = B0)) -> ((euclidean__axioms.Cong A E A B0) -> ((euclidean__axioms.Col A B0 E) -> ((euclidean__axioms.Col E A B0) -> (euclidean__axioms.neq A E))))))) with (x := B).
----------intro H11.
intro H12.
intro H13.
intro H14.
intro H15.
exact H12.

---------- exact H6.
---------- exact H.
---------- exact H0.
---------- exact H5.
---------- exact H7.
---------- exact H9.
--------- assert (* Cut *) (euclidean__axioms.neq E A) as H12.
---------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A E H11).
---------- assert (* Cut *) (euclidean__axioms.Col A B C) as H13.
----------- apply (@euclidean__tactics.not__nCol__Col A B C).
------------intro H13.
apply (@euclidean__tactics.Col__nCol__False A B C H13).
-------------apply (@lemma__collinear4.lemma__collinear4 E A B C H9 H10 H12).

----------- assert (* Cut *) (euclidean__axioms.Col B A C) as H14.
------------ assert (* Cut *) ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A C B) /\ (euclidean__axioms.Col C B A))))) as H14.
------------- apply (@lemma__collinearorder.lemma__collinearorder A B C H13).
------------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H15.
------------ apply (@euclidean__tactics.Col__nCol__False B A C H H14).
---- assert (* Cut *) (exists F, (euclidean__axioms.BetS B F E) /\ (euclidean__axioms.Cong F B F E)) as H7.
----- apply (@proposition__10.proposition__10 B E H6).
----- destruct H7 as [F H8].
destruct H8 as [H9 H10].
assert (* Cut *) (B = B) as H11.
------ apply (@logic.eq__refl Point B).
------ assert (* Cut *) (F = F) as H12.
------- apply (@logic.eq__refl Point F).
------- assert (* Cut *) (euclidean__axioms.Cong A F A F) as H13.
-------- apply (@euclidean__axioms.cn__congruencereflexive A F).
-------- assert (* Cut *) (euclidean__axioms.Cong A B A E) as H14.
--------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A E B H5).
--------- assert (* Cut *) (euclidean__axioms.Cong E F B F) as H15.
---------- assert (* Cut *) ((euclidean__axioms.Cong E F B F) /\ (euclidean__axioms.Cong B F E F)) as H15.
----------- apply (@lemma__doublereverse.lemma__doublereverse F B F E H10).
----------- destruct H15 as [H16 H17].
exact H16.
---------- assert (* Cut *) (euclidean__axioms.Cong B F E F) as H16.
----------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B E F F H15).
----------- assert (* Cut *) (~(euclidean__axioms.Col B A F)) as H17.
------------ intro H17.
assert (* Cut *) (euclidean__axioms.Col B F E) as H18.
------------- right.
right.
right.
right.
left.
exact H9.
------------- assert (* Cut *) (euclidean__axioms.Col F B E) as H19.
-------------- assert (* Cut *) ((euclidean__axioms.Col F B E) /\ ((euclidean__axioms.Col F E B) /\ ((euclidean__axioms.Col E B F) /\ ((euclidean__axioms.Col B E F) /\ (euclidean__axioms.Col E F B))))) as H19.
--------------- apply (@lemma__collinearorder.lemma__collinearorder B F E H18).
--------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H20.
-------------- assert (* Cut *) (euclidean__axioms.Col F B A) as H20.
--------------- assert (* Cut *) ((euclidean__axioms.Col A B F) /\ ((euclidean__axioms.Col A F B) /\ ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col B F A) /\ (euclidean__axioms.Col F A B))))) as H20.
---------------- apply (@lemma__collinearorder.lemma__collinearorder B A F H17).
---------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H25.
--------------- assert (* Cut *) (euclidean__axioms.neq B F) as H21.
---------------- assert (* Cut *) ((euclidean__axioms.neq F E) /\ ((euclidean__axioms.neq B F) /\ (euclidean__axioms.neq B E))) as H21.
----------------- apply (@lemma__betweennotequal.lemma__betweennotequal B F E H9).
----------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H24.
---------------- assert (* Cut *) (euclidean__axioms.neq F B) as H22.
----------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B F H21).
----------------- assert (* Cut *) (euclidean__axioms.Col B E A) as H23.
------------------ apply (@euclidean__tactics.not__nCol__Col B E A).
-------------------intro H23.
apply (@euclidean__tactics.Col__nCol__False B E A H23).
--------------------apply (@lemma__collinear4.lemma__collinear4 F B E A H19 H20 H22).

------------------ assert (* Cut *) (euclidean__axioms.Col A C E) as H24.
------------------- apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear A C E H4).
------------------- assert (* Cut *) (euclidean__axioms.Col E A B) as H25.
-------------------- assert (* Cut *) ((euclidean__axioms.Col E B A) /\ ((euclidean__axioms.Col E A B) /\ ((euclidean__axioms.Col A B E) /\ ((euclidean__axioms.Col B A E) /\ (euclidean__axioms.Col A E B))))) as H25.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder B E A H23).
--------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H28.
-------------------- assert (* Cut *) (euclidean__axioms.Col E A C) as H26.
--------------------- assert (* Cut *) ((euclidean__axioms.Col C A E) /\ ((euclidean__axioms.Col C E A) /\ ((euclidean__axioms.Col E A C) /\ ((euclidean__axioms.Col A E C) /\ (euclidean__axioms.Col E C A))))) as H26.
---------------------- apply (@lemma__collinearorder.lemma__collinearorder A C E H24).
---------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H31.
--------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H27.
---------------------- apply (@lemma__raystrict.lemma__raystrict A C E H4).
---------------------- assert (* Cut *) (euclidean__axioms.neq E A) as H28.
----------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A E H27).
----------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H29.
------------------------ apply (@euclidean__tactics.not__nCol__Col A B C).
-------------------------intro H29.
apply (@euclidean__tactics.Col__nCol__False A B C H29).
--------------------------apply (@lemma__collinear4.lemma__collinear4 E A B C H25 H26 H28).

------------------------ assert (* Cut *) (euclidean__axioms.Col B A C) as H30.
------------------------- assert (* Cut *) ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A C B) /\ (euclidean__axioms.Col C B A))))) as H30.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B C H29).
-------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H31.
------------------------- apply (@euclidean__tactics.Col__nCol__False B A C H H30).
------------ assert (* Cut *) (euclidean__defs.Out A B B) as H18.
------------- apply (@lemma__ray4.lemma__ray4 A B B).
--------------right.
left.
exact H11.

-------------- exact H0.
------------- assert (* Cut *) (~(A = F)) as H19.
-------------- intro H19.
assert (* Cut *) (euclidean__axioms.Col B A F) as H20.
--------------- right.
right.
left.
exact H19.
--------------- apply (@H17 H20).
-------------- assert (* Cut *) (euclidean__defs.Out A F F) as H20.
--------------- apply (@lemma__ray4.lemma__ray4 A F F).
----------------right.
left.
exact H12.

---------------- exact H19.
--------------- assert (* Cut *) (euclidean__defs.CongA B A F C A F) as H21.
---------------- exists B.
exists F.
exists E.
exists F.
split.
----------------- exact H18.
----------------- split.
------------------ exact H20.
------------------ split.
------------------- exact H4.
------------------- split.
-------------------- exact H20.
-------------------- split.
--------------------- exact H14.
--------------------- split.
---------------------- exact H13.
---------------------- split.
----------------------- exact H16.
----------------------- apply (@euclidean__tactics.nCol__notCol B A F H17).
---------------- assert (* Cut *) (euclidean__defs.CongA C A F B A F) as H22.
----------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric B A F C A F H21).
----------------- assert (* Cut *) (euclidean__axioms.nCol C A F) as H23.
------------------ assert (exists U V u v, (euclidean__defs.Out A C U) /\ ((euclidean__defs.Out A F V) /\ ((euclidean__defs.Out A B u) /\ ((euclidean__defs.Out A F v) /\ ((euclidean__axioms.Cong A U A u) /\ ((euclidean__axioms.Cong A V A v) /\ ((euclidean__axioms.Cong U V u v) /\ (euclidean__axioms.nCol C A F)))))))) as H23 by exact H22.
assert (exists U V u v, (euclidean__defs.Out A C U) /\ ((euclidean__defs.Out A F V) /\ ((euclidean__defs.Out A B u) /\ ((euclidean__defs.Out A F v) /\ ((euclidean__axioms.Cong A U A u) /\ ((euclidean__axioms.Cong A V A v) /\ ((euclidean__axioms.Cong U V u v) /\ (euclidean__axioms.nCol C A F)))))))) as __TmpHyp by exact H23.
destruct __TmpHyp as [x H24].
destruct H24 as [x0 H25].
destruct H25 as [x1 H26].
destruct H26 as [x2 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
assert (exists U V u v, (euclidean__defs.Out A B U) /\ ((euclidean__defs.Out A F V) /\ ((euclidean__defs.Out A C u) /\ ((euclidean__defs.Out A F v) /\ ((euclidean__axioms.Cong A U A u) /\ ((euclidean__axioms.Cong A V A v) /\ ((euclidean__axioms.Cong U V u v) /\ (euclidean__axioms.nCol B A F)))))))) as H42 by exact H21.
assert (exists U V u v, (euclidean__defs.Out A B U) /\ ((euclidean__defs.Out A F V) /\ ((euclidean__defs.Out A C u) /\ ((euclidean__defs.Out A F v) /\ ((euclidean__axioms.Cong A U A u) /\ ((euclidean__axioms.Cong A V A v) /\ ((euclidean__axioms.Cong U V u v) /\ (euclidean__axioms.nCol B A F)))))))) as __TmpHyp0 by exact H42.
destruct __TmpHyp0 as [x3 H43].
destruct H43 as [x4 H44].
destruct H44 as [x5 H45].
destruct H45 as [x6 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
exact H41.
------------------ assert (* Cut *) (euclidean__defs.CongA C A F F A C) as H24.
------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA C A F H23).
------------------- assert (* Cut *) (euclidean__defs.CongA B A F F A C) as H25.
-------------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B A F C A F F A C H21 H24).
-------------------- assert (* Cut *) (euclidean__defs.InAngle B A C F) as H26.
--------------------- exists B.
exists E.
split.
---------------------- exact H18.
---------------------- split.
----------------------- exact H4.
----------------------- exact H9.
--------------------- exists F.
split.
---------------------- exact H25.
---------------------- exact H26.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e384m317_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* ******************************************************************************* *)
(** * Representable pseudofunctor, pseudotransformation, and modifications
    Niccolò Veltri, Niels van der Weide
    April 2019
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.Core.Examples.OpMorBicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.

Local Open Scope bicategory_scope.
Local Open Scope cat.

Section RepresentableFunctor.

Context {C : bicat}.
Variable (C_is_univalent_2_1 : is_univalent_2_1 C).

Definition pspsh := psfunctor (op1_bicat C) bicat_of_univ_cats.

Definition representable_data_cat (X Y : C) : univalent_category
  := univ_hom C_is_univalent_2_1 Y X.

Definition representable_data_fun (X Y Z : C) (f : op1_bicat C ⟦ Y, Z ⟧)
  : bicat_of_univ_cats ⟦ representable_data_cat X Y, representable_data_cat X Z ⟧.
Proof.
  simpl in f.
  use make_functor.
  - use make_functor_data.
    + intro g.
      exact (f · g).
    + intros g h.
      exact (lwhisker f).
  - split.
    + exact (lwhisker_id2 f).
    + intros g h k η φ.
      exact (! (lwhisker_vcomp f η φ)).
Defined.

Definition representable_data_nat (X Y Z : C) (f g : op1_bicat C ⟦ Y, Z ⟧)
  : f ==> g → representable_data_fun X Y Z f ==> representable_data_fun X Y Z g.
Proof.
  intro η.
  use make_nat_trans.
  - intro h.
    exact (rwhisker h η).
  - intros h k φ.
    exact (! (@vcomp_whisker C Z Y X f g h k η φ)).
Defined.

Definition representable_data (X : C) : psfunctor_data (op1_bicat C) bicat_of_univ_cats.
Proof.
  use make_psfunctor_data.
  - exact (representable_data_cat X).
  - exact (representable_data_fun X).
  - exact (representable_data_nat X).
  - intro Y.
    use make_nat_trans.
    + exact linvunitor.
    + abstract (intros f g η ;
                simpl in * ;
                rewrite lwhisker_hcomp ;
                apply linvunitor_natural).
  - intros Y Z W f g.
    use make_nat_trans.
    + intro h. simpl.
      cbn in *.
      apply lassociator.
    + intros h k η.
      simpl.
      apply lwhisker_lwhisker.
Defined.

Definition representable_laws (X : C) : psfunctor_laws (representable_data X).
Proof.
  repeat split; cbn.
  - intros Y Z f.
    use nat_trans_eq.
    + exact (pr2 C Z X).
    + intro g. cbn.
      apply id2_rwhisker.
  - intros Y Z f g h η φ.
    use nat_trans_eq.
    + exact (pr2 C Z X).
    + intro k. cbn.
      symmetry.
      apply rwhisker_vcomp.
  - intros Y Z f.
    use nat_trans_eq.
    + exact (pr2 C Z X).
    + intro g. cbn.
      rewrite <- vassocr.
      rewrite runitor_rwhisker.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      symmetry.
      apply lwhisker_id2.
  - intros Y Z f.
    use nat_trans_eq.
    + exact (pr2 C Z X).
    + intro g. cbn.
      rewrite linvunitor_assoc.
      refine (!(_@ _)).
      {
        apply maponpaths_2.
        rewrite <- vassocr.
        rewrite rassociator_lassociator.
        apply id2_right.
      }
      rewrite rwhisker_vcomp.
      rewrite linvunitor_lunitor.
      apply id2_rwhisker.
  - intros Y Z W V f g h.
    use nat_trans_eq.
    + exact (pr2 C V X).
    + intro k.
      cbn in *.
      rewrite id2_left.
      pose (pentagon_2 k f g h) as p.
      rewrite lwhisker_hcomp,rwhisker_hcomp.
      rewrite <- vassocr.
      exact (! p).
  - intros Y Z W f g h η.
    use nat_trans_eq.
    + exact (pr2 C W X).
    + intro k.
      cbn in *.
      apply rwhisker_rwhisker.
  - intros Y Z W f g h η.
    use nat_trans_eq.
    + exact (pr2 C W X).
    + intro k.
      cbn in *.
      symmetry.
      apply rwhisker_lwhisker.
Qed.

Definition representable_invertible_cells (X : C) : invertible_cells (representable_data X).
Proof.
  split.
  - intro Y.
    use is_nat_z_iso_to_is_invertible_2cell.
    intro f.
    simpl.
    apply is_inv2cell_to_is_z_iso.
    is_iso.
  - intros Y Z W f g.
    use is_nat_z_iso_to_is_invertible_2cell.
    intro h.
    simpl.
    apply is_inv2cell_to_is_z_iso.
    is_iso.
Defined.

Definition representable (X : C) : pspsh.
Proof.
  use make_psfunctor.
  - exact (representable_data X).
  - exact (representable_laws X).
  - exact (representable_invertible_cells X).
Defined.

End RepresentableFunctor.

Section RepresentableTransformation.

Context {C : bicat}{X Y : C}.
Variable (C_is_univalent_2_1 : is_univalent_2_1 C) (f : X --> Y).

Definition representable1_data :
  pstrans_data (representable C_is_univalent_2_1 X) (representable C_is_univalent_2_1 Y).
Proof.
  use make_pstrans_data.
  - intro Z.
    cbn.
    use make_functor.
    + use make_functor_data.
      -- intro g.
         exact (g · f).
      -- intros g h η.
         exact (rwhisker f η).
    + split.
      -- intro g.
         apply id2_rwhisker.
      -- intros g h k η φ.
         symmetry.
         apply rwhisker_vcomp.
  - intros Z W h.
    cbn.
    use make_invertible_2cell.
    + use make_nat_trans.
      -- intro k.
         apply lassociator.
      -- intros k l η.
         cbn in *.
         apply rwhisker_lwhisker.
    + use is_nat_z_iso_to_is_invertible_2cell.
      intro g.
      apply is_inv2cell_to_is_z_iso.
      simpl.
      is_iso.
Defined.

Definition representable1_is_pstrans : is_pstrans representable1_data.
Proof.
  repeat (apply tpair).
  - intros Z W g h η.
    use nat_trans_eq.
    { exact (pr2 C W Y). }
    intro k.
    simpl.
    symmetry.
    apply rwhisker_rwhisker.
  - intro Z.
    use nat_trans_eq.
    { exact (pr2 C Z Y). }
    intro h.
    cbn in *.
    rewrite !id2_left.
    rewrite linvunitor_assoc.
    rewrite <- vassocr.
    rewrite rassociator_lassociator.
    apply id2_right.
  - intros Z W V g h.
    use nat_trans_eq.
    { exact (pr2 C V Y). }
    intro k.
    cbn in *.
    rewrite id2_left , ! id2_right.
    symmetry.
    apply lassociator_lassociator.
Qed.

Definition representable1 :
  pstrans (representable C_is_univalent_2_1 X) (representable C_is_univalent_2_1 Y).
Proof.
  use make_pstrans.
  - exact representable1_data.
  - exact representable1_is_pstrans.
Defined.

End RepresentableTransformation.

Section RepresentableModification.

Context {C : bicat}{X Y : C}{f g : X --> Y}.
Variable (C_is_univalent_2_1 : is_univalent_2_1 C) (η : f ==> g).

Definition representable2_data
  : modification_data (representable1 C_is_univalent_2_1 f)
                      (representable1 C_is_univalent_2_1 g).
Proof.
  intro Z.
  use make_nat_trans.
  - intro h.
    simpl.
    exact (h ◃ η).
  - intros h k φ.
    simpl.
    apply vcomp_whisker.
Defined.

Definition representable2_is_modification
  : is_modification (σ := representable1 C_is_univalent_2_1 f) representable2_data.
Proof.
  intros Z W h.
  use nat_trans_eq.
  { exact (pr2 C W Y). }
  intro k.
  cbn in *.
  symmetry.
  apply lwhisker_lwhisker.
Qed.

Definition representable2 :
  modification (representable1 C_is_univalent_2_1 f) (representable1 C_is_univalent_2_1 g).
Proof.
  use make_modification.
  - apply representable2_data.
  - apply representable2_is_modification.
Defined.

End RepresentableModification.