(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Binary relations                                                        *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibBool LibLogic LibProd LibSum.
From SLF Require Export LibOperation.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Type of binary relations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Type of endorelation, i.e. homogeneous binary relations *)

(* --TODO: what would be a better name for [binary]? *)

Definition binary (A : Type) := A -> A -> Prop.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance Inhab_binary : forall A, Inhab (binary A).
Proof using. intros. apply (Inhab_of_val (fun _ _ => True)). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Extensionality *)

Lemma binary_ext : forall A (R1 R2:binary A),
  (forall x y, R1 x y <-> R2 x y) ->
  R1 = R2.
Proof using. extens*. Qed.

Instance Extensionality_binary : forall A,
  Extensionality (binary A).
Proof using. intros. apply (Extensionality_make (@binary_ext A)). Defined.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of relations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Reflexivity *)

Definition refl A (R:binary A) :=
  forall x, R x x.

Section Refl.
Variables (A : Type).
Implicit Types R : binary A.

Lemma refl_inv : forall x y R,
  refl R ->
  x = y ->
  R x y.
Proof using. intros_all. subst~. Qed.

End Refl.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Irreflexivity *)

Definition irrefl A (R:binary A) :=
  forall x, ~ (R x x).

Section Irrefl.
Variables (A : Type).
Implicit Types R : binary A.

Lemma irrefl_inv : forall x R,
  irrefl R ->
  R x x ->
  False.
Proof using. introv H P. apply* H. Qed.

Lemma irrefl_eq_forall_neq : forall R,
  irrefl R = (forall x y, R x y -> x <> y).
Proof using.
  unfold irrefl. extens. iff M.
  { introv H E. subst*. }
  { autos*. }
Qed.

Lemma irrefl_inv_neq : forall x y R,
  irrefl R ->
  R x y ->
  x <> y.
Proof using. introv H M. rewrite* irrefl_eq_forall_neq in H. Qed.

End Irrefl.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Symmetry *)

Definition sym A (R:binary A) :=
  forall x y, R x y -> R y x.

Section Sym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma sym_inv : forall x y R,
  sym R ->
  R x y ->
  R y x.
Proof using. introv Sy R1. apply* Sy. Qed.

Lemma sym_inv_eq : forall x y R,
  sym R ->
  R x y = R y x.
Proof using. unfold sym. extens*. Qed.

Lemma sym_eq_forall_eq : forall R,
  sym R = (forall x y, R x y = R y x).
Proof using.
  unfold sym. extens. iff M.
  { extens*. }
  { intros. rewrite* M. }
Qed.

End Sym.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Asymmetry *)

Definition asym A (R:binary A) :=
  forall x y, R x y -> ~ R y x.

Section Asym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma asym_eq_forall_false : forall R,
  asym R = (forall x y, R x y -> R y x -> False).
Proof using. unfold asym. extens*. Qed.

Lemma asym_inv : forall x y R,
  asym R ->
  R x y ->
  R y x ->
  False.
Proof using. introv H M1 M2. apply* H. Qed.

End Asym.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Antisymmetry *)

Definition antisym A (R:binary A) :=
  forall x y, R x y -> R y x -> x = y.

Section Antisym.
Variables (A : Type).
Implicit Types R : binary A.

Lemma antisym_eq_forall_eq : forall R,
  antisym R = (forall x y, R x y -> R y x -> x = y).
Proof using. unfold antisym. extens*. Qed.

Lemma antisym_inv : forall x y R,
  antisym R ->
  R x y ->
  R y x ->
  x <> y ->
  False.
Proof using. intros_all*. Qed.

End Antisym.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Antisymmetry with respect to an equivalence relation *)

Definition antisym_wrt A (E:binary A) R :=
  forall x y, R x y -> R y x -> E x y.

(* --LATER: lemmas *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Transitivity *)

Definition trans A (R:binary A) :=
  forall y x z, R x y -> R y z -> R x z.

Section Trans.
Variables (A : Type).
Implicit Types R : binary A.

Lemma trans_eq_forall_impl : forall R,
  trans R = (forall y x z, R x y -> R y z -> R x z).
Proof using. unfold trans. extens*. Qed.

Lemma trans_inv : forall y x z R,
  trans R ->
  R x y ->
  R y z ->
  R x z.
Proof using. introv Tr R1 R2. apply* Tr. Qed.

Lemma trans_inv_swap : forall y x z R,
  trans R ->
  R y z ->
  R x y ->
  R x z.
Proof using. introv Tr R1 R2. apply* Tr. Qed.

(** [trans] + [sym] *)

Definition trans_sym_ll := trans_inv.

Lemma trans_sym_lr : forall y x z R,
  trans R ->
  sym R ->
  R x y ->
  R z y ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_rr : forall y x z R,
  trans R ->
  sym R ->
  R y x ->
  R z y ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_rl : forall y x z R,
  trans R ->
  sym R ->
  R y x ->
  R y z ->
  R x z.
Proof using. introv Tr Sy R1 R2. apply* Tr. Qed.

End Trans.

Arguments trans_inv [A] y [x] [z] [R].
Arguments trans_inv_swap [A] y [x] [z] [R].
Arguments trans_sym_rr [A] y [x] [z] [R].
Arguments trans_sym_lr [A] y [x] [z] [R].
Arguments trans_sym_rl [A] y [x] [z] [R].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Equivalence relation *)

Record equiv A (R:binary A) :=
 { equiv_refl : refl R;
   equiv_sym : sym R;
   equiv_trans : trans R }.

Section Equiv.
Variables (A : Type).
Implicit Types R : binary A.

(* --LATER: lemmas *)

End Equiv.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inclusion *)

(* --LATER: see also typeclass [incl] *)

Definition rel_incl A B (R1 R2:A->B->Prop) :=
  forall x y, R1 x y -> R2 x y.

Section Incl.
Variables (A B : Type).
Implicit Types R : A->B->Prop.

Lemma rel_incl_eq_forall_impl : forall R1 R2,
  rel_incl R1 R2 = (forall x y, R1 x y -> R2 x y).
Proof using. auto. Qed.

Lemma refl_rel_incl :
  refl (@rel_incl A B).
  (* forall (R:A->B->Prop), rel_incl R R *)
Proof using. unfolds refl, rel_incl. autos*. Qed.

Lemma refl_rel_incl' : forall R,
  rel_incl R R.
Proof using. intros. applys refl_rel_incl. Qed.

Hint Resolve refl_rel_incl refl_rel_incl'.

Lemma antisym_rel_incl :
  antisym (@rel_incl A B).
  (* forall R1 R2, rel_incl R1 R2 -> rel_incl R2 R1 -> R1 = R2. *)
Proof using. unfolds rel_incl. extens*. Qed.
  (* See also extensionality_pred_2 from LibEqual *)

Lemma trans_rel_incl :
  trans (@rel_incl A B).
Proof using. unfold trans, rel_incl. autos*. Qed.
  (* forall R1 R2 R3, rel_incl R1 R2 -> rel_incl R2 R3 ->  rel_incl R1 R3. *)

End Incl.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Totality *)

Definition total A (R:binary A) :=
  forall x y, R x y \/ R y x.

Section Total.
Variables (A : Type).
Implicit Types R : binary A.

Lemma total_eq_forall_or : forall R,
  total R = (forall x y, R x y \/ R y x).
Proof using. auto. Qed.

Lemma total_inv : forall x y R,
  total R ->
  R x y \/ R y x.
Proof using. introv H. apply* H. Qed.

Lemma total_inv_not_l : forall x y R,
  total R ->
  ~ R x y ->
  R y x.
Proof using. introv H N. destruct* (H x y). Qed.

Lemma total_inv_not_r : forall x y R,
  total R ->
  ~ R y x ->
  R x y.
Proof using. introv H N. destruct* (H x y). Qed.

End Total.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Trichotomy *)

Inductive trichotomy A (R:binary A) : binary A :=
  | trichotomy_left : forall x y,
      R x y ->
      x <> y ->
      ~ R y x ->
      trichotomy R x y
  | trichotomy_eq : forall x,
      ~ R x x ->
      trichotomy R x x
  | trichotomy_right : forall x y,
      ~ R x y ->
      x <> y ->
      R y x ->
      trichotomy R x y.

Definition trichotomous A (R:binary A) :=
  forall x y, trichotomy R x y.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definedness *)

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

Section Defined.
Variables (A : Type).
Implicit Types R : binary A.

Lemma total_eq_forall_exists : forall R,
  defined R = (forall x, exists y, R x y).
Proof using. auto. Qed.

Lemma defined_inv : forall x R,
  defined R ->
  exists y, R x y.
Proof using. introv H. apply* H. Qed.

Lemma defined_inv_not : forall x R,
  defined R ->
  (forall y, ~ R x y) ->
  False.
Proof using. introv H N. forwards* (?&?): H. Qed.

End Defined.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Functionality *)

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

Section Functional.
Variables (A : Type).
Implicit Types R : binary A.

Lemma functional_eq_forall_eq : forall R,
  functional R = (forall x y z, R x y -> R x z -> y = z).
Proof using. auto. Qed.

Lemma functional_inv : forall x z y R,
  functional R ->
  R x y ->
  R x z ->
  y = z.
Proof using. introv H N1 N2. apply* H. Qed.

End Functional.

(* --TODO: define a tactic "functional_exploit R" that looks for two distinct
   assumptions in the goal of the form [R ?x ?y] and produces [functional R]
   as subgoal, and provides the equality [?y1 = ?y2]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Criteria for equality *)

Section Equality.
Variables (A : Type).
Implicit Types R : binary A.

(** If [R1] is defined, [R2] is functional, and [R1] is a subset of [R2],
    then [R1] equals [R2]. In that case, [R1] and [R2] represent the graph
    of a total function. *)

Lemma eq_of_incl_defined_functional : forall R1 R2,
  rel_incl R1 R2 ->
  defined R1 ->
  functional R2 ->
  R1 = R2.
Proof using.
  introv Hincl Hdef Hfun. extens. intros x y. iff M.
  { eauto. }
  { forwards (w'&M1): Hdef x.
    forwards M2: Hincl M1.
    forwards: Hfun M M2. subst*. }
Qed.

End Equality.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of the equality relation *)

(** These results are not in [LibEqual] because the definitions from
    [LibRelation] are not yet available from that file. *)

Section Eq.
Variables (A : Type).

Lemma refl_eq :
  refl (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma sym_eq :
  sym (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma trans_eq :
  trans (@eq A).
Proof using. intros_all; subst~. Qed.

Lemma equiv_eq :
  equiv (@eq A).
Proof using. intros. constructor; intros_all; subst~. Qed.

End Eq.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of the equality relation *)

(** These results are not in [LibLogic] because the definitions from
    [LibRelation] are not yet available from that file.
    See also [LibOrder] for a package of these properties. *)

Section Pred_incl.
Variables (A : Type).

Lemma refl_pred_incl :
  refl (@pred_incl A).
Proof using. unfold refl, pred_incl. autos*. Qed.

Lemma antisym_pred_incl :
  antisym (@pred_incl A).
Proof using. unfold antisym, pred_incl. extens*. Qed.

Lemma trans_pred_incl :
  trans (@pred_incl A).
Proof using. unfold trans, pred_incl. autos*. Qed.

End Pred_incl.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of the equivalence relation *)

(** These results are not in [LibLogic] because the definitions from
    [LibRelation] are not yet available from that file.
    See also [LibOrder] for a package of these properties. *)

Section Iff.

Lemma refl_iff :
  refl iff.
Proof using. unfold refl, iff. autos*. Qed.

Lemma antisym_iff :
  antisym iff.
Proof using. unfold antisym, iff. extens*. Qed.

Lemma trans_iff :
  trans iff.
Proof using. unfold trans, iff. autos*. Qed.

End Iff.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Basic constructions *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** The empty relation *)

(* --LATER: see also typeclass [empty] *)

Definition empty A : binary A :=
  fun x y => False.

Section Empty.
Variables (A : Type).
Implicit Types x y : A.

Lemma empty_eq : forall x y,
  empty x y = False.
Proof using. auto. Qed.

Lemma empty_inv : forall x y,
  empty x y ->
  False.
Proof using. auto. Qed.

Lemma functional_empty :
  functional (@empty A).
Proof using. unfolds* empty, functional. Qed.

End Empty.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Union of two relations  *)

(* --LATER: see also typeclass [union] *)

Definition union A (R1 R2:binary A) : binary A :=
  fun x y => R1 x y \/ R2 x y.

Section Union.
Variables (A : Type).
Implicit Types R : binary A.

Lemma union_l : forall R1 R2 x y,
  R1 x y ->
  union R1 R2 x y.
Proof using. unfold union. eauto. Qed.

Lemma union_r : forall R1 R2 x y,
  R2 x y ->
  union R1 R2 x y.
Proof using. unfold union. eauto. Qed.

Lemma rel_incl_union_l : forall R1 R2,
  rel_incl R1 (union R1 R2).
Proof using. unfold rel_incl, union. eauto. Qed.

Lemma rel_incl_union_r : forall R1 R2,
  rel_incl R2 (union R1 R2).
Proof using. unfold rel_incl, union. eauto. Qed.

Lemma refl_union_l : forall R1 R2,
  refl R1 ->
  refl (union R1 R2).
Proof using. unfold refl, union. eauto. Qed.

Lemma refl_union_r : forall R1 R2,
  refl R2 ->
  refl (union R1 R2).
Proof using. unfold refl, union. eauto. Qed.

Lemma comm_union :
  comm (@union A).
  (* forall R1 R2, union R1 R2 = union R2 R1. *)
Proof using. unfold union. extens*. Qed.

Lemma comm_union_args : forall R1 R2 x y,
  union R2 R1 x y ->
  union R1 R2 x y.
Proof using. intros. rewrite~ comm_union. Qed.

(** Union is functional provided disjoint domains *)
Lemma functional_union : forall R1 R2,
  functional R1 ->
  functional R2 ->
  (forall x y z, R1 x y -> R2 x z -> False) ->
  functional (union R1 R2).
Proof using.
  intros. unfold union. intros x y z Hxy Hxz.
  destruct Hxy; destruct Hxz; auto_false*.
Qed.

(* --TODO: generic definition of covariant? *)
Lemma covariant_union : forall R1 R2 S1 S2,
  rel_incl R1 S1 ->
  rel_incl R2 S2 ->
  rel_incl (union R1 R2) (union S1 S2).
Proof using. unfold rel_incl, union. autos*. Qed.

End Union.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Intersection of two relations  *)

(* --LATER: see also typeclass [inter] *)

Definition inter A (R1 R2:binary A) : binary A :=
  fun x y => R1 x y /\ R2 x y.

(* --LATER: add lemmas *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Complement of a relation *)

Definition compl A (R:binary A) : binary A :=
  fun x y => ~ R y x.

(* --LATER: add lemmas *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inverse of a relation *)

Definition inverse A (R:binary A) : binary A :=
  fun x y => R y x.

Section Inverse.
Variables (A : Type).
Implicit Types R : binary A.

Lemma inverse_eq_fun : forall R,
  inverse R = (fun x y => R y x).
Proof using. auto. Qed.

Lemma inverse_eq : forall R x y,
  inverse R x y = R y x.
Proof using. auto. Qed.

Lemma injective_inverse :
  injective (@inverse A).
Proof using.
  intros R1 R2 E. extens. intros x y.
  unfolds inverse. rewrite* (fun_eq_2 y x E).
Qed.

Lemma inverse_sym : forall R,
  sym R ->
  inverse R = R.
Proof using. intros. unfold inverse. extens*. Qed.

Lemma inverse_inverse : forall R,
  inverse (inverse R) = R.
Proof using. extens*. Qed.

Lemma inverse_eq_l : forall R2 R1,
  R1 = inverse R2 ->
  inverse R1 = R2.
Proof using. intros. apply injective_inverse. rewrite~ inverse_inverse. Qed.

Lemma inverse_eq_r : forall R2 R1,
  inverse R1 = R2 ->
  R1 = inverse R2.
Proof using. intros. apply injective_inverse. rewrite~ inverse_inverse. Qed.

Lemma refl_inverse : forall R,
  refl R ->
  refl (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma trans_inverse : forall R,
  trans R ->
  trans (inverse R).
Proof using. intros_all. unfolds inverse. eauto. Qed.

Lemma antisym_inverse : forall R,
  antisym R ->
  antisym (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma antisym_wrt_inverse : forall E R,
  antisym_wrt E R ->
  antisym_wrt E (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma asym_inverse : forall R,
  asym R ->
  asym (inverse R).
Proof using. intros_all. unfolds inverse. apply* H. Qed.

Lemma total_inverse : forall R,
  total R ->
  total (inverse R).
Proof using. intros_all. unfolds inverse. auto. Qed.

Lemma trichotomous_inverse : forall R,
  trichotomous R ->
  trichotomous (inverse R).
Proof using.
  introv H. intros x y. destruct (H x y).
  apply~ trichotomy_right.
  apply~ trichotomy_eq.
  apply~ trichotomy_left.
Qed.

(* TODO rename to equiv_inverse *)
Lemma inverse_equiv : forall A (E:binary A),
  equiv E ->
  equiv (inverse E).
Proof using.
  introv Equi. unfold inverse. constructor; intros_all;
    dintuition eauto.
Qed.

Lemma inverse_union : forall R1 R2,
  inverse (union R1 R2) = union (inverse R1) (inverse R2).
Proof using.
  unfold inverse, union. constructor; intros_all;
    dintuition eauto.
Qed.

End Inverse.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [preimage] *)

(** Preimage, a.k.a. inverse image *)

Definition rel_preimage (A B:Type) (R:binary B) (f:A->B) : binary A :=
  fun x y => R (f x) (f y).

(* --TODO: lemmas *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [rel_seq] *)

(** Composition of two relations, usually written [R1; R2]. *)

Definition rel_seq (A B C:Type) (R1:A->B->Prop) (R2:B->C->Prop) : A->C->Prop :=
  fun x z => exists y, R1 x y /\ R2 y z.

(** A relation [R] is functional if and only if [inverse R] composed
    with [R] is a subset of the diagonal relation [eq]. *)

Lemma functional_eq_seq_inverse_incl_eq : forall A (R:binary A),
  functional R = rel_incl (rel_seq (inverse R) R) eq.
Proof using.
  unfold functional, rel_incl, rel_seq, inverse. extens. iff M; jauto.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Turning a function into a relation. *)

Definition rel_fun A B (f:A->B) :=
  fun x y => (y = f x).

Section Rel_fun.
Variables (A : Type).
Implicit Types R : binary A.

(* --LATER: properties of [rel_fun] *)

End Rel_fun.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Products *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Pointwise product *)

Definition prod2 (A1 A2:Type)
  (R1:binary A1) (R2:binary A2)
   : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => match p1,p2 with (x1,x2),(y1,y2) =>
    R1 x1 y1 /\ R2 x2 y2 end.

Definition prod3 (A1 A2 A3:Type)
  (R1:binary A1) (R2:binary A2) (R3:binary A3)
   : binary (A1*A2*A3) :=
  prod2 (prod2 R1 R2) R3.

Definition prod4 (A1 A2 A3 A4:Type)
  (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
   : binary (A1*A2*A3*A4) :=
  prod2 (prod3 R1 R2 R3) R4.

(** Tactics *)

Tactic Notation "unfold_prod" :=
  unfold prod4, prod3, prod2.
Tactic Notation "unfolds_prod" :=
  unfold prod4, prod3, prod2 in *.

(** Equivalence *)

Lemma prod2_equiv : forall A1 A2 (E1:binary A1) (E2:binary A2),
  equiv E1 ->
  equiv E2 ->
  equiv (prod2 E1 E2).
Proof using.
  introv [R1 S1 T1] [R2 S2 T2]. constructor.
  { intros [x1 x2]. simple*. }
  { intros [x1 x2] [y1 y2]. simple*. }
  { intros [x1 x2] [y1 y2] [z1 z2]. simple*. }
Qed.

(* --LATER: other lemmas *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lexicographical product *)

Definition lexico2 {A1 A2} (R1:binary A1) (R2:binary A2)
   : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => let (x1,x2) := p1 in let (y1,y2) := p2 in
  (R1 x1 y1) \/ (x1 = y1) /\ (R2 x2 y2).

Definition lexico3 {A1 A2 A3}
   (R1:binary A1) (R2:binary A2) (R3:binary A3) : binary (A1*A2*A3) :=
  lexico2 (lexico2 R1 R2) R3.

Definition lexico4 {A1 A2 A3 A4}
   (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
   : binary (A1*A2*A3*A4) :=
  lexico2 (lexico3 R1 R2 R3) R4.

(** Tactics *)

Tactic Notation "unfold_lexico" :=
  unfold lexico4, lexico3, lexico2.
Tactic Notation "unfolds_lexico" :=
  unfold lexico4, lexico3, lexico2 in *.

(** Elimination *)

Section Lexico.
Variables (A1 A2 A3 A4:Type).
Variables (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4).

Lemma lexico2_1 : forall x1 x2 y1 y2,
  R1 x1 y1 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. left~. Qed.

Lemma lexico2_2 : forall x1 x2 y1 y2,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof using. intros. right~. Qed.

Lemma lexico3_1 : forall x1 x2 x3 y1 y2 y3,
  R1 x1 y1 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. left. left~. Qed.

Lemma lexico3_2 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intro. left. right~. Qed.

Lemma lexico3_3 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 ->
  x2 = y2 ->
  R3 x3 y3 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof using. intros. right~. Qed.

Lemma lexico4_1 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  R1 x1 y1 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. left~. Qed.

Lemma lexico4_2 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  R2 x2 y2 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. left. right~. Qed.

Lemma lexico4_3 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  x2 = y2 ->
  R3 x3 y3 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. left. right~. Qed.

Lemma lexico4_4 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 ->
  x2 = y2 ->
  x3 = y3 ->
  R4 x4 y4 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof using. intros. right~. Qed.

End Lexico.

(** Transitivity *)

Lemma trans_lexico2 : forall A1 A2
   (R1:binary A1) (R2:binary A2),
  trans R1 ->
  trans R2 ->
  trans (lexico2 R1 R2).
Proof using.
  introv Tr1 Tr2. intros [x1 x2] [y1 y2] [z1 z2] Rxy Ryz.
  simpls. destruct Rxy as [L1|[Eq1 L1]];
   destruct Ryz as [M2|[Eq2 M2]]; subst*.
Qed.

Lemma trans_lexico3 : forall A1 A2 A3
   (R1:binary A1) (R2:binary A2) (R3:binary A3),
  trans R1 ->
  trans R2 ->
  trans R3 ->
  trans (lexico3 R1 R2 R3).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ trans_lexico2. applys~ trans_lexico2.
Qed.

Lemma trans_lexico4 : forall A1 A2 A3 A4
   (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  trans R1 ->
  trans R2 ->
  trans R3 ->
  trans R4 ->
  trans (lexico4 R1 R2 R3 R4).
Proof using.
  introv Tr1 Tr2 Tr3. applys~ trans_lexico3. applys~ trans_lexico2.
Qed.

(** Inclusion *)

Lemma rel_incl_lexico2 : forall A1 A2
   (R1 R1':binary A1) (R2 R2':binary A2),
  rel_incl R1 R1' ->
  rel_incl R2 R2' ->
  rel_incl (lexico2 R1 R2) (lexico2 R1' R2').
Proof using.
  introv I1 I2. intros [x1 x2] [y1 y2] [H1|[H1 H2]].
  { left~. } { subst. right~. }
Qed.

(* --LATER: other lemmas *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Closures *)

(* --LATER: more lemmas about union and inter *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Reflexive closure  *)

Inductive rclosure A (R:binary A) : binary A :=
  | rclosure_once : forall x y,
      R x y ->
      rclosure R x y
  | rclosure_refl : forall x,
      rclosure R x x.

Section Rclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure.

(** Equivalent definition *)

Lemma rclosure_eq_fun : forall R,
  rclosure R = (fun x y => R x y \/ x = y).
Proof using. extens. iff M; destruct M; subst*. Qed.

Lemma rclosure_eq : forall R x y,
  rclosure R x y = (R x y \/ x = y).
Proof using. extens. iff M; destruct M; subst*. Qed.

Lemma rclosure_inv : forall R x y,
  rclosure R x y ->
  R x y \/ x = y.
Proof using. introv M; rewrite* rclosure_eq in M. Qed.

(** Properties *)

Lemma refl_rclosure : forall R,
  refl (rclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rclosure : forall R,
  sym R ->
  sym (rclosure R).
Proof using. unfolds sym. introv M N. destruct* N. Qed.

Lemma antisym_rclosure : forall R,
  antisym R ->
  antisym (rclosure R).
Proof using.
  unfolds antisym. introv M N1 N2.
  destruct N1; destruct N2; subst*.
Qed.

Lemma antisym_wrt_rclosure : forall E R,
  antisym_wrt E R ->
  antisym_wrt (rclosure E) (rclosure R).
Proof using.
  unfolds antisym_wrt. introv M N1 N2.
  destruct N1; destruct N2; subst*.
Qed.

Lemma trans_rclosure : forall R,
  trans R ->
  trans (rclosure R).
Proof using.
  unfolds trans. introv H M1 M2.
  destruct M1; destruct M2; subst*.
Qed.

Lemma total_rclosure : forall R,
  total R ->
  total (rclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rclosure_eq_of_refl : forall R,
  refl R ->
  rclosure R = R.
Proof using.
  unfolds refl. introv H. extens. iff M.
  { destruct M; subst*. } { auto. }
Qed.

Lemma rclosure_inverse_eq : forall R,
  rclosure (inverse R) = inverse (rclosure R).
Proof using. unfold inverse. extens. iff M; destruct* M. Qed.

(** Constructors *)

(** -- TODO: rename to
   rclosure_of_rclosure_step
   rclosure_of_step_rclosure
   trans_inv_rclosure_step
   trans_inv_step_rclosure *)

Lemma rclosure_trans_l : forall y x z R,
  trans R ->
  rclosure R x y ->
  R y z ->
  rclosure R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct M; subst*. Qed.

Lemma rclosure_trans_r : forall y x z R,
  trans R ->
  R x y ->
  rclosure R y z ->
  rclosure R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct N; subst*. Qed.

Lemma trans_rclosure_l : forall y x z R,
  trans R ->
  rclosure R x y ->
  R y z ->
  R x z.
Proof using. introv T M H. rewrite rclosure_eq in *. destruct M; subst*. Qed.

Lemma trans_rclosure_r : forall y x z R,
  trans R ->
  R x y ->
  rclosure R y z ->
  R x z.
Proof using. introv T M N. rewrite rclosure_eq in *. destruct N; subst*. Qed.

(** Negation *)

Lemma not_rclosure_inv : forall R x y,
  ~ rclosure R x y ->
  ~ R x y /\ x <> y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

Lemma not_rclosure_inv_rel : forall R x y,
  ~ rclosure R x y ->
  ~ R x y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

Lemma not_rclosure_inv_neq : forall R x y,
  ~ rclosure R x y ->
  x <> y.
Proof using. introv M. rewrite* rclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_rclosure : forall R,
  rel_incl R (rclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rclosure_of_rel : forall R x y,
  R x y ->
  rclosure R x y.
Proof using. intros. applys* rel_incl_rclosure. Qed.

Lemma covariant_rclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rclosure R1) (rclosure R2).
Proof using. introv H M. destruct* M. Qed.

Lemma rel_incl_rclosure_rclosure : forall R1 R2,
  rel_incl R1 (rclosure R2) ->
  rel_incl (rclosure R1) (rclosure R2).
Proof using. introv H M. destruct* M. Qed.

End Rclosure.

Hint Constructors rclosure : rclosure.
(* --LATER: here and later, add more hints *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Symmetric closure  *)

Inductive sclosure A (R:binary A) : binary A :=
  | sclosure_once : forall x y,
      R x y ->
      sclosure R x y
  | sclosure_sym : forall x y,
      sclosure R y x ->
      sclosure R x y.

Section Sclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors sclosure.

(** Equivalent definition *)

Lemma sclosure_eq : forall R x y,
  sclosure R x y = (R x y \/ R y x).
Proof using.
  extens. iff M.
  { induction* M. }
  { destruct M; subst*. }
Qed.

Lemma sclosure_inv : forall R x y,
  sclosure R x y ->
  R x y \/ R y x.
Proof using. introv M; rewrite* sclosure_eq in M. Qed.

(** Properties *)

Lemma refl_sclosure : forall R,
  refl R ->
  refl (sclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_sclosure : forall R,
  sym (sclosure R).
Proof using. unfolds sym. introv N. destruct* N. Qed.

Lemma total_sclosure : forall R,
  total R ->
  total (sclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma sclosure_eq_of_sym : forall R,
  sym R ->
  sclosure R = R.
Proof using.
  unfolds sym. introv H. extens. intros. rewrite sclosure_eq.
  iff M. { destruct M; subst*. } { auto. }
Qed.

Lemma sclosure_inverse_eq : forall R,
  sclosure (inverse R) = sclosure R.
Proof using.
  unfolds inverse. extens. intros. do 2 rewrite sclosure_eq. autos*.
Qed.

(** Negation *)

Lemma not_sclosure_inv : forall R x y,
  ~ sclosure R x y ->
  ~ R x y /\ ~ R y x.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

Lemma not_sclosure_inv_l : forall R x y,
  ~ sclosure R x y ->
  R x y ->
  False.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

Lemma not_sclosure_inv_r : forall R x y,
  ~ sclosure R x y ->
  R y x ->
  False.
Proof using. introv M. rewrite* sclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_sclosure : forall R,
  rel_incl R (sclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_sclosure : forall R,
  rel_incl (inverse R) (sclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_sclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (sclosure R1) (sclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_sclosure_sclosure : forall R1 R2,
  rel_incl R1 (sclosure R2) ->
  rel_incl (sclosure R1) (sclosure R2).
Proof using. introv H M. induction* M. Qed.

End Sclosure.

Hint Constructors sclosure : sclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Reflexive-symmetric closure  *)

Inductive rsclosure A (R:binary A) : binary A :=
  | rsclosure_once : forall x y,
      R x y ->
      rsclosure R x y
  | rsclosure_refl : forall x,
      rsclosure R x x
  | rsclosure_sym : forall x y,
      rsclosure R x y ->
      rsclosure R y x.

Section Rsclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rsclosure.

(** Equivalent definition *)

Lemma rsclosure_eq : forall R x y,
  rsclosure R x y = (R x y \/ R y x \/ x = y).
Proof using.
  extens. iff M.
  { induction* M. }
  { destruct M as [M|[M|M]]; subst*. }
Qed.

Lemma rsclosure_inv : forall R x y,
  rsclosure R x y ->
  R x y \/ R y x \/ x = y.
Proof using. introv M; rewrite* rsclosure_eq in M. Qed.

(** Properties *)

Lemma refl_rsclosure : forall R,
  refl (rsclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rsclosure : forall R,
  sym (rsclosure R).
Proof using. unfolds sym. introv N. destruct* N. Qed.

Lemma total_rsclosure : forall R,
  total R ->
  total (rsclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rsclosure_inverse_eq : forall R,
  rsclosure (inverse R) = rsclosure R.
Proof using.
  unfold inverse. extens. intros. do 2 rewrite rsclosure_eq. autos*.
Qed.

(** Negation *)

Lemma not_rsclosure_inv : forall R x y,
  ~ rsclosure R x y ->
  ~ R x y /\ ~ R y x /\ ~ x = y.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_l : forall R x y,
  ~ rsclosure R x y ->
  R x y ->
  False.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_r : forall R x y,
  ~ rsclosure R x y ->
  R y x ->
  False.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

Lemma not_rsclosure_inv_neq : forall R x y,
  ~ rsclosure R x y ->
  x <> y.
Proof using. introv M. rewrite* rsclosure_eq in M. Qed.

(** Inclusions *)

Lemma rel_incl_rsclosure : forall R,
  rel_incl R (rsclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_rsclosure : forall R,
  rel_incl (inverse R) (rsclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_rsclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rsclosure R1) (rsclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_rsclosure_rsclosure : forall R1 R2,
  rel_incl R1 (rsclosure R2) ->
  rel_incl (rsclosure R1) (rsclosure R2).
Proof using. introv H M. induction* M. Qed.

End Rsclosure.

Hint Constructors rsclosure : rsclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Transitive closure ( R+ ), defined as [R \o R*] *)

Inductive tclosure A (R:binary A) : binary A :=
  | tclosure_once : forall x y,
      R x y ->
      tclosure R x y
  | tclosure_trans : forall y x z,
      tclosure R x y ->
      tclosure R y z ->
      tclosure R x z.

Section Tclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors tclosure.

(** Properties *)

Lemma refl_tclosure : forall R,
  refl R ->
  refl (tclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_tclosure : forall R,
  sym R ->
  sym (tclosure R).
Proof using. unfolds sym. introv H N. induction* N. Qed.

Lemma trans_tclosure : forall R,
  trans (tclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_tclosure : forall R,
  total R ->
  total (tclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma tclosure_eq_of_trans : forall R,
  trans R ->
  tclosure R = R.
Proof using.
  unfolds trans. introv H. extens. iff M.
  { induction M; subst*. }
  { auto. }
Qed.

Lemma tclosure_inverse_eq : forall R,
  tclosure (inverse R) = inverse (tclosure R).
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma tclosure_l : forall R y x z,
  R x y ->
  tclosure R y z ->
  tclosure R x z.
Proof using. autos*. Qed.

Lemma tclosure_r : forall R y x z,
  tclosure R x y ->
  R y z ->
  tclosure R x z.
Proof using. autos*. Qed.

(** Inclusions *)

Lemma rel_incl_tclosure : forall R,
  rel_incl R (tclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_tclosure : forall A (R1 R2 : binary A),
  rel_incl R1 R2 ->
  rel_incl (tclosure R1) (tclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_tclosure_tclosure : forall R1 R2,
  rel_incl R1 (tclosure R2) ->
  rel_incl (tclosure R1) (tclosure R2).
Proof using. introv H M. induction* M. Qed.

(** Induction principle with steps at head or tail *)

Section Ind.

Inductive tclosure'l A (R:binary A) : binary A :=
  | tclosure'l_once : forall x y,
      R x y ->
      tclosure'l R x y
  | tclosure'l_step : forall y x z,
      R x y ->
      tclosure'l R y z ->
      tclosure'l R x z.

Lemma trans_tclosure'l : forall R,
  trans (tclosure'l R).
Proof using.
  Hint Constructors tclosure'l.
  intros R y x z M1. gen z. induction M1; introv M2; autos*.
Qed.

Lemma tclosure_eq_tclosure'l : forall R,
  tclosure R = tclosure'l R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_tclosure'l y. }
  { induction* M. }
Qed.

Lemma tclosure_ind_l : forall R (P : A -> A -> Prop),
  (forall x y, R x y -> P x y) ->
  (forall y x z, R x y -> tclosure R y z -> P y z -> P x z) ->
  (forall x y, tclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite tclosure_eq_tclosure'l in *. induction* M.
Qed.

Inductive tclosure'r A (R:binary A) : binary A :=
  | tclosure'r_once : forall x y,
      R x y ->
      tclosure'r R x y
  | tclosure'r_step : forall y x z,
      tclosure'r R x y ->
      R y z ->
      tclosure'r R x z.

Lemma trans_tclosure'r : forall R,
  trans (tclosure'r R).
Proof using.
  Hint Constructors tclosure'r.
  intros R y x z M1 M2. gen x. induction M2; introv M1; autos*.
Qed.

Lemma tclosure_eq_tclosure'r : forall R,
  tclosure R = tclosure'r R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_tclosure'r y. }
  { induction* M. }
Qed.

Lemma tclosure_ind_r : forall R (P : A -> A -> Prop),
  (forall x y, R x y -> P x y) ->
  (forall y x z, tclosure R x y -> P x y -> R y z -> P x z) ->
  (forall x y, tclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite tclosure_eq_tclosure'r in *. induction* M.
Qed.

(* --LATER: can these induction principles be proved directly? *)

End Ind.

(** Inversion principle with steps at head or tail *)

Lemma tclosure_inv_l : forall R x z,
  tclosure R x z ->
  (R x z) \/ (exists y, R x y /\ tclosure R y z).
Proof using. intros R. applys* tclosure_ind_l. Qed.

Lemma tclosure_inv_r : forall R x z,
  tclosure R x z ->
  (R x z) \/ (exists y, tclosure R x y /\ R y z).
Proof using. intros R. applys* tclosure_ind_r. Qed.

End Tclosure.

Hint Resolve tclosure_once tclosure_l tclosure_r
  : rtclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Reflexive-transitive closure ( R* ) *)

Inductive rtclosure A (R:binary A) : binary A :=
  | rtclosure_once : forall x y,
      R x y ->
      rtclosure R x y
  | rtclosure_refl : forall x,
      rtclosure R x x
  | rtclosure_trans : forall y x z,
      rtclosure R x y ->
      rtclosure R y z ->
      rtclosure R x z.

Section Rtclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rtclosure.

(** Properties *)

Lemma refl_rtclosure : forall R,
  refl (rtclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rtclosure : forall R,
  sym R ->
  sym (rtclosure R).
Proof using. unfolds sym. introv M N. induction* N. Qed.

Lemma trans_rtclosure : forall R,
  trans (rtclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_rtclosure : forall R,
  total R ->
  total (rtclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma tclosure_eq_of_refl_trans : forall R,
  refl R ->
  trans R ->
  rtclosure R = R.
Proof using.
  unfolds refl, trans. introv H1 H2. extens. iff M.
  { induction M; subst*. }
  { autos*. }
Qed.

Lemma rtclosure_inverse_eq : forall R,
  rtclosure (inverse R) = inverse (rtclosure R).
Proof using. unfold inverse. extens. iff M; induction* M. Qed.

(** Constructors *)

Lemma rtclosure_l : forall R y x z,
  R x y ->
  rtclosure R y z ->
  rtclosure R x z.
Proof using. autos*. Qed.

Lemma rtclosure_r : forall R y x z,
  rtclosure R x y ->
  R y z ->
  rtclosure R x z.
Proof using. autos*. Qed.

(* Same as above, reformulated to make [eauto] faster *)
Lemma rtclosure_r' : forall R y x z,
  R y z ->
  rtclosure R x y ->
  rtclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_rtclosure : forall R,
  rel_incl R (rtclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_rtclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rtclosure R1) (rtclosure R2).
Proof using. unfolds rel_incl. introv H M. induction* M. Qed.

(* --TODO: find better name for this one and similar *)
Lemma rel_incl_rtclosure_rtclosure : forall R1 R2,
  rel_incl R1 (rtclosure R2) ->
  rel_incl (rtclosure R1) (rtclosure R2).
Proof using. unfolds rel_incl. introv H M. induction* M. Qed.

Lemma rel_incl_union_rtclosure : forall R1 R2,
  rel_incl (union (rtclosure R1) (rtclosure R2))
           (rtclosure (union R1 R2)).
Proof using.
  hint rel_incl_union_l, rel_incl_union_r. introv [M|M].
  { applys* covariant_rtclosure R1. }
  { applys* covariant_rtclosure R2. }
Qed.

(** Negation *)

Lemma not_rtclosure_inv_neq : forall R x y,
  ~ rtclosure R x y ->
  x <> y.
Proof using. introv M E. subst. induction* M. Qed.

(** Induction principle with steps at head or tail *)

Section Ind.

Inductive rtclosure'l A (R:binary A) : binary A :=
  | rtclosure'l_refl : forall x,
      rtclosure'l R x x
  | rtclosure'l_step : forall y x z,
      R x y ->
      rtclosure'l R y z ->
      rtclosure'l R x z.

Lemma trans_rtclosure'l : forall R,
  trans (rtclosure'l R).
Proof using.
  Hint Constructors rtclosure'l.
  intros R y x z M1. gen z. induction M1; introv M2; autos*.
Qed.

Lemma rtclosure_eq_rtclosure'l : forall R,
  rtclosure R = rtclosure'l R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_rtclosure'l y. }
  { induction* M. }
Qed.

Lemma rtclosure_ind_l : forall R (P : A -> A -> Prop),
  (forall x, P x x) ->
  (forall y x z, R x y -> rtclosure R y z -> P y z -> P x z) ->
  (forall x y, rtclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite rtclosure_eq_rtclosure'l in *. induction* M.
Qed.

Inductive rtclosure'r A (R:binary A) : binary A :=
  | rtclosure'r_refl : forall x,
      rtclosure'r R x x
  | rtclosure'r_step : forall y x z,
      rtclosure'r R x y ->
      R y z ->
      rtclosure'r R x z.

Lemma trans_rtclosure'r : forall R,
  trans (rtclosure'r R).
Proof using.
  Hint Constructors rtclosure'r.
  intros R y x z M1 M2. gen x. induction M2; introv M1; autos*.
Qed.

Lemma rtclosure_eq_rtclosure'r : forall R,
  rtclosure R = rtclosure'r R.
  (* --LATER: tclosure'l = tclosure. *)
Proof using.
  extens. intros x y. iff M.
  { induction* M. applys* trans_rtclosure'r y. }
  { induction* M. }
Qed.

Lemma rtclosure_ind_r : forall R (P : A -> A -> Prop),
  (forall x, P x x) ->
  (forall y x z, rtclosure R x y -> P x y -> R y z -> P x z) ->
  (forall x y, rtclosure R x y -> P x y).
Proof using.
  introv H1 H2 M. rewrite rtclosure_eq_rtclosure'r in *. induction* M.
Qed.

End Ind.

(** Inversion principle with steps at head or tail *)

Lemma rtclosure_inv_l : forall R x z,
  rtclosure R x z ->
  (x = z) \/ (exists y, R x y /\ rtclosure R y z).
Proof using. intros R. applys* rtclosure_ind_l. Qed.

Lemma rtclosure_inv_r : forall R x z,
  rtclosure R x z ->
  (x = z) \/ (exists y, rtclosure R x y /\ R y z).
Proof using. intros R. applys* rtclosure_ind_r. Qed.

End Rtclosure.

Hint Resolve rtclosure_refl rtclosure_once
  rtclosure_l rtclosure_r' : rtclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Symmetric-transitive closure *)

Inductive stclosure A (R:binary A) : binary A :=
  | stclosure_once : forall x y,
      R x y ->
      stclosure R x y
  | stclosure_sym : forall x y,
      stclosure R x y ->
      stclosure R y x
  | stclosure_trans : forall y x z,
      stclosure R x y ->
      stclosure R y z ->
      stclosure R x z.

Section Stclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors stclosure.

(** Properties *)

Lemma refl_stclosure : forall R,
  refl R ->
  refl (stclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_stclosure : forall R,
  sym (stclosure R).
Proof using. unfolds sym. introv N. induction* N. Qed.

Lemma trans_stclosure : forall R,
  trans (stclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_stclosure : forall R,
  total R ->
  total (stclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma stclosure_eq_of_sym_trans : forall R,
  sym R ->
  trans R ->
  stclosure R = R.
Proof using.
  unfolds sym, trans. introv H1 H2. extens. iff M.
  { induction M; subst*. }
  { autos*. }
Qed.

Lemma stclosure_inverse_eq : forall R,
  stclosure (inverse R) = inverse (stclosure R).
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma stclosure_l : forall R y x z,
  R x y ->
  stclosure R y z ->
  stclosure R x z.
Proof using. autos*. Qed.

Lemma stclosure_r : forall R y x z,
  stclosure R x y ->
  R y z ->
  stclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_stclosure : forall R,
  rel_incl R (stclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma covariant_stclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (stclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_stclosure_stclosure : forall R1 R2,
  rel_incl R1 (stclosure R2) ->
  rel_incl (stclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

End Stclosure.

Hint Constructors stclosure : stclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Reflexive-symmetric-transitive closure *)

Inductive rstclosure A (R:binary A) : binary A :=
  | rstclosure_once : forall x y,
      R x y ->
      rstclosure R x y
  | rstclosure_refl : forall x,
      rstclosure R x x
  | rstclosure_sym : forall x y,
      rstclosure R x y ->
      rstclosure R y x
  | rstclosure_trans : forall y x z,
      rstclosure R x y ->
      rstclosure R y z ->
      rstclosure R x z.

Section Rstclosure.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rstclosure.

(** Properties *)

Lemma refl_rstclosure : forall R,
  refl (rstclosure R).
Proof using. unfolds* refl. Qed.

Lemma sym_rstclosure : forall R,
  sym (rstclosure R).
Proof using. unfolds* sym. Qed.

Lemma trans_rstclosure : forall R,
  trans (rstclosure R).
Proof using. unfolds* trans. Qed.

Lemma total_rstclosure : forall R,
  total R ->
  total (rstclosure R).
Proof using.
  unfolds total. introv H. intros x y. destruct* (H x y).
Qed.

Lemma rstclosure_eq_of_refl_sym_trans : forall R,
  refl R ->
  sym R ->
  trans R ->
  rstclosure R = R.
Proof using.
  unfolds refl, sym, trans. introv H. extens. iff M.
  { induction M; subst*. }
  { auto. }
Qed.

Lemma rstclosure_inverse_eq : forall R,
  rstclosure (inverse R) = rstclosure R.
Proof using.
  unfolds inverse. extens. intros x y. iff M; induction* M.
Qed.

(** Constructors *)

Lemma rstclosure_l : forall R y x z,
  R x y ->
  rstclosure R y z ->
  rstclosure R x z.
Proof using. autos*. Qed.

Lemma rstclosure_r : forall R y x z,
  rstclosure R x y ->
  R y z ->
  rstclosure R x z.
Proof using. autos*. Qed.

(** Inclusion *)

Lemma rel_incl_rstclosure : forall R,
  rel_incl R (rstclosure R).
Proof using. unfolds* rel_incl. Qed.

Lemma rel_incl_inverse_rstclosure : forall R,
  rel_incl (inverse R) (rstclosure R).
Proof using. unfolds* rel_incl, inverse. Qed.

Lemma covariant_rstclosure : forall R1 R2,
  rel_incl R1 R2 ->
  rel_incl (rstclosure R1) (rstclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_rstclosure_rstclosure : forall R1 R2,
  rel_incl R1 (rstclosure R2) ->
  rel_incl (rstclosure R1) (rstclosure R2).
Proof using. introv H M. induction* M. Qed.

Lemma rel_incl_union_rstclosure : forall R1 R2,
  rel_incl (union (rstclosure R1) (rstclosure R2))
           (rstclosure (union R1 R2)).
Proof using.
  hint rel_incl_union_l, rel_incl_union_r. introv [M|M].
  { applys* covariant_rstclosure R1. }
  { applys* covariant_rstclosure R2. }
Qed.

End Rstclosure.

Hint Constructors rstclosure : rstclosure.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Relationship between closures *)

Section ClosuresRel.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rtclosure rsclosure stclosure rstclosure.

(** [rclosure] to [rtclosure] *)

Lemma rtclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rtclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rtclosure : forall R,
  rel_incl (rclosure R) (rtclosure R).
Proof using. intros. applys* rtclosure_of_rclosure. Qed.

(** [tclosure] to [rtclosure] *)

Lemma rtclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  rtclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_rtclosure : forall R,
  rel_incl (tclosure R) (rtclosure R).
Proof using. intros. applys* rtclosure_of_tclosure. Qed.

(** [rclosure] to [rsclosure] *)

Lemma rsclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rsclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rsclosure : forall R,
  rel_incl (rclosure R) (rsclosure R).
Proof using. intros. applys* rsclosure_of_rclosure. Qed.

(** [sclosure] to [rsclosure] *)

Lemma rsclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  rsclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_sclosure_rsclosure : forall R,
  rel_incl (sclosure R) (rsclosure R).
Proof using. intros. applys* rsclosure_of_sclosure. Qed.

(** [sclosure] to [stclosure] *)

Lemma stclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  stclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_slosure_rsclosure : forall R,
  rel_incl (sclosure R) (stclosure R).
Proof using. intros. applys* stclosure_of_sclosure. Qed.

(** [tclosure] to [stclosure] *)

Lemma stclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  stclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_stclosure : forall R,
  rel_incl (tclosure R) (stclosure R).
Proof using. intros. applys* stclosure_of_tclosure. Qed.

(** [rclosure] to [rstclosure] *)

Lemma rstclosure_of_rclosure : forall R x y,
  rclosure R x y ->
  rstclosure R x y.
Proof using. intros. destruct* H. Qed.

Lemma rel_incl_rclosure_rstclosure : forall R,
  rel_incl (rclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rclosure. Qed.

(** [sclosure] to [rstclosure] *)

Lemma rstclosure_of_sclosure : forall R x y,
  sclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_sclosure_rstclosure : forall R,
  rel_incl (sclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_sclosure. Qed.

(** [tclosure] to [tstclosure] *)

Lemma rstclosure_of_tclosure : forall R x y,
  tclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_tclosure_rstclosure : forall R,
  rel_incl (tclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_tclosure. Qed.

(** [rsclosure] to [rstclosure] *)

Lemma rstclosure_of_rsclosure : forall R x y,
  rsclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_rsclosure_rstclosure : forall R,
  rel_incl (rsclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rsclosure. Qed.

(** [rtclosure] to [rstclosure] *)

Lemma rstclosure_of_rtclosure : forall R x y,
  rtclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_rtclosure_rstclosure : forall R,
  rel_incl (rtclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_rtclosure. Qed.

(** [stclosure] to [rstclosure] *)

Lemma rstclosure_of_stclosure : forall R x y,
  stclosure R x y ->
  rstclosure R x y.
Proof using. intros. induction* H. Qed.

Lemma rel_incl_stclosure_rstclosure : forall R,
  rel_incl (stclosure R) (rstclosure R).
Proof using. intros. applys* rstclosure_of_stclosure. Qed.

End ClosuresRel.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Iterated closures *)

Section IterClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure sclosure tclosure
  rtclosure rsclosure stclosure rstclosure.
Hint Resolve sym_tclosure sym_sclosure sym_rclosure
  sym_rtclosure sym_rsclosure sym_rtclosure sym_rstclosure.

Lemma rclosure_sclosure_eq_rsclosure : forall R,
  rclosure (sclosure R) = rsclosure R.
Proof using.
  extens. intros x y. iff M.
  { destruct* M. { applys* rsclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma sclosure_rclosure_eq_rsclosure : forall R,
  sclosure (rclosure R) = rsclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rsclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma rclosure_tclosure_eq_rtclosure : forall R,
  rclosure (tclosure R) = rtclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rtclosure_of_tclosure. } }
  { induction* M. { destruct IHM1; destruct IHM2; autos*. } }
Qed.

Lemma tclosure_rclosure_eq_rtclosure : forall R,
  tclosure (rclosure R) = rtclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rtclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma tclosure_sclosure_eq_stclosure : forall R,
  tclosure (sclosure R) = stclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* stclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma rclosure_stclosure_eq_rstclosure : forall R,
  rclosure (stclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_stclosure. } }
  { induction* M.
    { destruct IHM; autos*. }
    { destruct IHM1; destruct IHM2; autos*. } }
Qed.

Lemma stclosure_rclosure_eq_rstclosure : forall R,
  stclosure (rclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_rclosure. } }
  { induction* M. }
Qed.

Lemma rtclosure_sclosure_eq_rstclosure : forall R,
  rtclosure (sclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_sclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

Lemma tclosure_rsclosure_eq_rstclosure : forall R,
  tclosure (rsclosure R) = rstclosure R.
Proof using.
  extens. intros x y. iff M.
  { induction* M. { applys* rstclosure_of_rsclosure. } }
  { induction* M. { applys* sym_inv. } }
Qed.

End IterClosures.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Other lemmas -- TODO *)

Section EquivClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors rclosure sclosure tclosure rsclosure stclosure.

Lemma rsclosure_eq_union_rclosure_sclosure : forall R,
  rsclosure R = union (rclosure R) (sclosure R).
Proof using.
  extens. intros x y. unfold union. iff M.
  { induction* M. destruct* IHM as [H|H]. destruct* H. }
  { destruct* M as [H|H]. destruct* H. applys* rsclosure_of_sclosure. }
Qed.

Lemma rtclosure_eq_union_rclosure_tclosure : forall R,
  rtclosure R = union (rclosure R) (tclosure R).
Proof using.
  extens. intros x y. unfold union. iff M.
  { induction* M. destruct IHM1 as [H1|H1]; destruct IHM2 as [H2|H2].
     { destruct H1; destruct* H2. }
     { destruct* H1. }
     { destruct* H2. }
     { autos*. } }
  { destruct* M.
    { applys* rtclosure_of_rclosure. }
    { applys* rtclosure_of_tclosure. } }
Qed.

Lemma rtclosure_inv_rclosure_or_tclosure : forall R x y,
  rtclosure R x y ->
  x = y \/ tclosure R x y.
Proof using.
  introv M. rewrite rtclosure_eq_union_rclosure_tclosure in M.
  destruct M as [M|M]. { destruct* M. } { auto. }
Qed.

Lemma stclosure_eq_rstclosure_of_refl : forall R,
  refl R ->
  stclosure R = rstclosure R.
Proof using.
  introv H. extens. intros x y. iff M.
  { applys* rstclosure_of_stclosure. }
  { induction* M. }
Qed.

(* --LATER: many lemmas like the above? *)

(* --TODO: rename this lemma *)
Lemma rel_incl_tclosure_stclosure_l : forall R1 R2,
  rel_incl R1 (stclosure R2) ->
  rel_incl (tclosure R1) (stclosure R2).
Proof using. introv H M. induction* M. Qed.

(* --LATER: many lemmas like the above? *)

End EquivClosures.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Mixed transitivity between closures *)

Section MixedClosures.
Variables (A : Type).
Implicit Types R : binary A.
Hint Constructors tclosure.

Lemma tclosure_of_rtclosure_l : forall R x y z,
  rtclosure R x y ->
  R y z ->
  tclosure R x z.
Proof using.
  introv H M. destruct (rtclosure_inv_rclosure_or_tclosure H).
  { subst*. }
  { applys* tclosure_r. }
Qed.

Lemma tclosure_of_rtclosure_r : forall R x y z,
  R x y ->
  rtclosure R y z ->
  tclosure R x z.
Proof using.
  introv M H. destruct (rtclosure_inv_rclosure_or_tclosure H).
  { subst*. }
  { applys* tclosure_l. }
Qed.

Lemma tclosure_of_rtclosure_tclosure : forall R y x z,
  rtclosure R x y ->
  tclosure R y z ->
  tclosure R x z.
Proof using.
  introv H M. destruct (rtclosure_inv_rclosure_or_tclosure H); subst*.
Qed.

Lemma tclosure_of_tclosure_rtclosure : forall R y x z,
  tclosure R x y ->
  rtclosure R y z ->
  tclosure R x z.
Proof using.
  introv M H. destruct (rtclosure_inv_rclosure_or_tclosure H); subst*.
Qed.

End MixedClosures.

(* --LATER: similar lemmas relating [rstclosure] and [stclosure] *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Irreflexive restriction of a relation *)

Definition strict A (R:binary A) : binary A :=
  fun x y => R x y /\ x <> y.

Section Strict.
Variables (A : Type).
Implicit Types R : binary A.
Hint Unfold strict.

Lemma strict_eq_fun : forall R,
  strict R = (fun x y => R x y /\ x <> y).
Proof using. auto. Qed.

Lemma strict_eq : forall R x y,
  strict R x y = (R x y /\ x <> y).
Proof using. auto. Qed.

Lemma inverse_strict : forall R,
  inverse (strict R) = strict (inverse R).
Proof using. intros. unfold inverse, strict. extens*. Qed.

Lemma trans_strict_l : forall y x z R,
  trans R ->
  strict R x y ->
  R y z ->
  R x z.
Proof using. introv T (E&H) H'; subst*. Qed.

Lemma trans_strict_r : forall y x z R,
  trans R ->
  R x y ->
  strict R y z ->
  R x z.
Proof using. introv T H (E&H'); subst*. Qed.

Lemma irrefl_strict : forall R,
  irrefl (strict R).
Proof using. unfold strict, irrefl. intros. rew_logic*. Qed.

Lemma antisym_strict : forall R,
  antisym R ->
  antisym (strict R).
Proof using. unfolds* antisym, strict. Qed.

Lemma trans_strict : forall R,
  trans R ->
  antisym R ->
  trans (strict R).
Proof using.
  introv T S. unfold strict. introv [H1 H2] [H3 H4]. split.
  { apply* T. }
  { intros K. subst. apply H2. apply~ S. }
Qed.

Lemma strict_rclosure : forall R,
  irrefl R ->
  strict (rclosure R) = R.
Proof using.
  unfold strict. extens. intros x y. iff (K1&K2) K.
  { destruct* K1. }
  { split. { left*. } { apply* irrefl_inv_neq. } }
Qed.

Lemma rclosure_strict : forall R,
  refl R ->
  rclosure (strict R) = R.
Proof using.
  Hint Constructors rclosure.
  unfold strict. extens. intros x y. iff K.
  { destruct K; subst*. }
  { tests: (x = y); subst*. }
Qed.

End Strict.

(* **********************************************************************

    Function to relation *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inclusion of a function in a relation *)

(** [fun_in_rel f R] asserts that input-output pairs of [f] are
    included in the relation [R]. *)

Definition fun_in_rel A B (f:A->B) (R:A->B->Prop) :=
  forall x, R x (f x).

Section Fun_in_rel.
Variables (A B : Type).
Implicit Type f : A->B.
Implicit Type R : A->B->Prop.

Lemma defined_of_fun_in_rel : forall f R,
  fun_in_rel f R ->
  defined R.
Proof using. unfolds* fun_in_rel, defined. Qed.

(** The relation built from a function [f] is included in a relation
    [R] iff the function [f] is included in [R] *)

Lemma rel_incl_rel_fun_eq_fun_in_rel : forall f R,
  rel_incl (rel_fun f) R = fun_in_rel f R.
Proof using.
  extens. unfold rel_fun, fun_in_rel. iff H; intros x; specializes H x.
  { applys* H. }
  { intros y Hy. subst~. }
Qed.

End Fun_in_rel.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inclusion of a relation in a function *)

(** [rel_in_fun R f] asserts that input-output pairs of [R]
    are input-output for [f]. *)

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

Section Rel_in_fun.
Variables (A B : Type).
Implicit Type f : A->B.
Implicit Type R : A->B->Prop.

Lemma functional_of_rel_in_fun : forall R f,
  rel_in_fun R f ->
  functional R.
Proof using.
  unfold rel_in_fun, functional. introv M N1 N2.
  lets: M N1. lets: M N2. congruence.
Qed.

(* If the relation [R] is functional and if [f] is included in [R],
   then [R] is included in [f], i.e., they coincide. *)

Lemma rel_in_fun_of_fun_in_rel_functional : forall f R,
  fun_in_rel f R ->
  functional R ->
  rel_in_fun R f.
Proof using.
  introv h1 h2. intros a b H. forwards M: h1 a. forwards*: h2 H M.
Qed.

End Rel_in_fun.

(* 2021-08-11 15:24 *)


Require Import Setoid Coq.Classes.Morphisms Basics List PeanoNat Coq.Logic.FinFun Coq.omega.Omega Psatz Coq.Sorting.Mergesort Coq.Structures.Orders Coq.Logic.FinFun Coq.Program.Equality dec.

Reserved Notation "X '⊓' Y" (at level 39, left associativity).
Reserved Notation "X '⊔' Y" (at level 40, left associativity).
Reserved Notation " x '===' y " (at level 70, no associativity).
Reserved Notation " x '=/=' y " (at level 70, no associativity).
Reserved Notation "⊤".
Reserved Notation "⊥".
Reserved Notation "X '⊑' Y" (at level 70, no associativity).

Class lattice (A : Set) :=
  Lattice {
      join: A -> A -> A where "X '⊔' Y" := (join X Y);
      meet: A -> A -> A where "X '⊓' Y" := (meet X Y);
      top: A where "⊤" := @top;
      bot: A where "⊥" := @bot;
      eq: A -> A -> Prop where "x '===' y" := (eq x y)
        and "x '=/=' y" := (complement eq x y)
        and "X '⊑' Y" := (X ⊔ Y === Y);
      eq_equiv :> Equivalence eq;
      meet_symmetry: forall a b : A, a ⊓ b === b ⊓ a;
      join_symmetry: forall a b   : A,  a ⊔ b === b ⊔ a;
      join_assoc   : forall a b c : A,  a ⊔ (b ⊔ c) === (a ⊔ b) ⊔ c;
      join_absorp : forall a b   : A,  a ⊔ (a ⊓ b) === a;
      meet_assoc   : forall a b c : A,  a ⊓ (b ⊓ c) === (a ⊓ b) ⊓ c;
      meet_absorp : forall a b   : A,  a ⊓ (a ⊔ b) === a;
      join_bot: forall a     : A, bot ⊔ a === a;
      join_top: forall a     : A, ⊤ ⊔ a === ⊤;
                               meet_bot: forall a     : A, bot ⊓ a === bot;
      meet_top: forall a     : A, ⊤ ⊓ a === a;
      join_compat: forall x1 y1 x2 y2, x1 === x2 -> y1 === y2 -> x1 ⊔ y1 === x2 ⊔ y2;
      meet_compat: forall x1 y1 x2 y2, x1 === x2 -> y1 === y2 -> x1 ⊓ y1 === x2 ⊓ y2;
      flowsto_compat_right: forall x y z, x === y -> z ⊑ y -> z ⊑ x;
      flowsto_compat_left: forall x y z, x === y -> y ⊑ z -> x ⊑ z
    }.

Notation "X '⊓' Y" := (meet X Y)(at level 39, left associativity).
Notation "X '⊔' Y" := (join X Y) (at level 40, left associativity).
Notation "x '===' y" := (eq x y) (at level 70, no associativity).
Notation "x '=/=' y" := (complement eq x y) (at level 70, no associativity).
Notation "⊤" := top.
Notation "⊥" := bot.

Definition flowsto {A : Set} `{lattice A} (a b : A) := a ⊔ b === b.
Notation "X '⊑' Y" := (flowsto X Y) (at level 70, no associativity).

Arguments flowsto _ _ : simpl nomatch.
Arguments join _ _ : simpl nomatch.
Arguments meet _ _ : simpl nomatch.

Hint Resolve meet_symmetry join_symmetry join_assoc meet_assoc meet_absorp join_absorp join_top join_bot meet_top meet_bot eq_equiv.

Section LatticeProperties.
  Context {A : Set} `{lattice A}.

  Global Add Parametric Relation : A eq
      reflexivity proved by (@Equivalence_Reflexive A eq eq_equiv)
      symmetry proved by (@Equivalence_Symmetric A eq eq_equiv)
      transitivity proved by (@Equivalence_Transitive A eq eq_equiv)
        as eq_rel.
  Hint Resolve eq_rel : typeclass_instances.

  Class Morphism2 (f : A -> A -> A) :=
    {
      compat2: forall (x1 y1 x2 y2 : A), x1 === x2 -> y1 === y2 -> f x1 y1 === f x2 y2
    }.

  Class MorphismR (f : A -> A -> Prop) :=
    {
      compatR: forall (x1 y1 x2 y2 : A), x1 === x2 -> y1 === y2 -> f x1 y1 <-> f x2 y2
    }.

  Global Instance eq_rewrite2_Proper (f : A -> A -> A) `{Morphism2 f}:
    Proper (eq ==> eq ==> eq) f.
  Proof.
    intros x1 y1 H_eq1 x2 y2 H_eq2.
    eapply compat2; eassumption.
  Qed.
  Hint Resolve eq_rewrite2_Proper : typeclass_instances.

  Global Instance eq_rewrite3_Proper (f : A -> A -> Prop) `{MorphismR f}:
    Proper (eq ==> eq ==> flip impl) f.
  Proof.
    intros x1 y1 H_eq1 x2 y2 H_eq2.
    unfold flip.
    intro.
    eapply compatR; eassumption.
  Qed.
  Hint Resolve eq_rewrite3_Proper : typeclass_instances.

  Global Instance join_inst: Morphism2 join := { compat2 := join_compat }.
  Global Instance meet_inst: Morphism2 meet := { compat2 := meet_compat }.
  Hint Resolve join_inst : typeclass_instances.
  Hint Resolve meet_inst : typeclass_instances.

  Lemma idem_join:
    forall a, a ⊔ a === a.
  Proof.
    intros.
    rewrite <- (meet_absorp a a) at 2.
    eauto.
  Qed.
  Hint Resolve idem_join.

  Lemma idem_meet:
    forall a, a ⊓ a === a.
  Proof.
    intros.
    rewrite <- (join_absorp a a) at 2.
    eauto.
  Qed.
  Hint Resolve idem_meet.

  Lemma flowsto_refl: forall a, a ⊑ a.
  Proof. unfold flowsto. eauto. Qed.
  Hint Resolve flowsto_refl.

  Global Instance flowsto_Proper: forall (a : A), Proper (flowsto --> flip impl) (flowsto a).
  Proof.
    intros.
    intros x y ? ?.
    unfold flowsto in *.
    unfold flip in *.
    rewrite <- H0.
    rewrite -> join_assoc.
    rewrite -> H1.
    reflexivity.
  Qed.

  Lemma flowsto_trans:
    forall a b c, a ⊑ b -> b ⊑ c -> a ⊑ c.
  Proof.
    intros.
    rewrite <- H1.
    assumption.
  Qed.

  Global Instance flowsto_preorder_inst: PreOrder flowsto.
  constructor.
  - eauto.
  - unfold Transitive.
    intros.
    eauto using flowsto_trans.
  Defined.
  Hint Resolve flowsto_preorder_inst : typeclass_instances.

  Add Parametric Relation: A flowsto
      reflexivity proved by flowsto_refl
      transitivity proved by flowsto_trans
        as flowsto_rel.

  Hint Extern 1 (?a ⊑ ?c) =>
  match goal with
  | [H: a ⊑ ?b |- _] => apply (flowsto_trans a b c)
  | [H: ?b ⊑ c |- _] => apply (flowsto_trans a b c)
  end.

  Lemma anti_sym:
    forall a b, a ⊑ b -> b ⊑ a -> a === b.
  Proof.
    intros a b H1 H2.
    unfold flowsto in *.
    rewrite <- H1.
    rewrite -> join_symmetry.
    rewrite -> H2.
    reflexivity.
  Qed.

  Lemma flowsto_not:
    forall ℓ₁ ℓ₂ ℓ₃, ℓ₁ ⊑ ℓ₂ -> not (ℓ₁ ⊑ ℓ₃) -> not (ℓ₂ ⊑ ℓ₃).
  Proof.
    intros ℓ₁ ℓ₂ ℓ₃ H1 H2.
    intro H_absurd.
    contradiction (flowsto_trans _ _ _ H1 H_absurd).
  Qed.
  Hint Resolve flowsto_not.

  Lemma flowsto_join:
    forall a b, a ⊑ a ⊔ b.
  Proof.
    intros.
    unfold flowsto.
    rewrite -> join_assoc.
    rewrite -> idem_join.
    reflexivity.
  Qed.
  Hint Resolve flowsto_join.

  Lemma meet_join_consistent:
    forall a b, a ⊓ b === a <-> a ⊔ b === b.
  Proof.
    intros.
    split; intros.
    - assert (b === b ⊔ (b ⊓ a)).
      {
        rewrite -> (join_absorp b a).
        reflexivity.
      }
      assert (b ⊔ (b ⊓ a) === b ⊔ a).
      {
        rewrite -> meet_symmetry.
        rewrite -> H0.
        reflexivity.
      }
      rewrite -> join_symmetry.
      rewrite <- H2.
      rewrite <- H1.
      reflexivity.
    - assert (a === a ⊓ (a ⊔ b)).
      {
        rewrite -> (meet_absorp a b).
        reflexivity.
      }
      assert (a ⊓ (a ⊔ b) === a ⊓ b).
      {
        rewrite -> H0.
        reflexivity.
      }
      rewrite <- H2.
      symmetry.
      assumption.
  Qed.

  Global Instance flowsto_proper_join: Proper (flowsto ==> flowsto ==> flowsto) join.
  Proof.
    intros x y ? z ? ?.
    unfold flowsto in *.
    rewrite -> join_assoc.
    rewrite <- (join_symmetry z x).
    rewrite <- (join_assoc z x y).
    rewrite -> H0.
    rewrite -> (join_symmetry z y).
    rewrite <- join_assoc.
    rewrite -> H1.
    reflexivity.
  Qed.
  Hint Resolve flowsto_proper_join : typeclass_instances.

  Global Instance flowsto_proper_meet: Proper (flowsto ==> flowsto ==> flowsto) meet.
  Proof.
    intros x y ? z ? ?.
    unfold flowsto in *.
    rewrite <- meet_join_consistent in *.
    rewrite -> meet_assoc.
    rewrite <- (meet_symmetry z x).
    rewrite <- (meet_assoc z x y).
    rewrite -> H0.
    rewrite -> (meet_symmetry z x).
    rewrite <- meet_assoc.
    rewrite -> H1.
    reflexivity.
  Qed.
  Hint Resolve flowsto_proper_meet : typeclass_instances.

  Lemma flowsto_meet:
    forall a b, a ⊓ b ⊑ a.
  Proof.
    intros.
    unfold flowsto.
    rewrite -> meet_symmetry.
    rewrite <- meet_join_consistent.
    rewrite <- meet_assoc.
    rewrite -> idem_meet.
    reflexivity.
  Qed.
  Hint Resolve flowsto_meet.

  Class MorphismUR (f : A -> Prop) :=
    {
      compatUR: forall (x y : A), x === y -> f y <-> f x
    }.

  Global Instance eq_rewrite4_Proper (f : A -> Prop) `{MorphismUR f}:
    Proper (eq ==> flip impl) f.
  Proof.
    firstorder.
  Qed.
  Hint Resolve eq_rewrite4_Proper : typeclass_instances.

  Global Instance flowsto_inst: MorphismR (fun a b => a ⊔ b === b).
  Proof.
    constructor.
    intros.
    split; intros.
    - symmetry in H0.
      eapply (flowsto_compat_right y2 y1 x2); eauto.
      firstorder.
      symmetry in H1.
      eapply (flowsto_compat_left x2 x1 y1); eauto.
    - symmetry in H1.
      eapply (flowsto_compat_left x1 x2 y1); eauto.
      symmetry in H1.
      eapply (flowsto_compat_right y1 y2 x2); eauto.
  Qed.
  Hint Resolve flowsto_inst : typeclass_instances.

  Lemma join_flowsto_implies_flowsto:
    forall ℓ₁ ℓ₂ ℓ₃,
      join ℓ₁ ℓ₂ ⊑ ℓ₃ -> ℓ₁ ⊑ ℓ₃ /\ ℓ₂ ⊑ ℓ₃.
  Proof.
    intros.
    assert (ℓ₁ ⊑ join ℓ₁ ℓ₂) by apply flowsto_join.
    assert (ℓ₂ ⊑ join ℓ₁ ℓ₂).
    {
      rewrite -> (join_symmetry ℓ₁ ℓ₂).
      eapply flowsto_join.
    }
    split; eapply flowsto_trans; eauto.
  Qed.

  Lemma meet_flowsto_implies_flowsto:
    forall ℓ₁ ℓ₂ ℓ₃,
      ℓ₁ ⊑ ℓ₂ ⊓ ℓ₃ -> ℓ₁ ⊑ ℓ₂ /\ ℓ₁ ⊑ ℓ₃.
  Proof.
    intros.
    assert (meet ℓ₂ ℓ₃ ⊑ ℓ₂) by eauto.
    assert (meet ℓ₂ ℓ₃ ⊑ ℓ₃) by (rewrite -> meet_symmetry; apply flowsto_meet).
    split; eapply flowsto_trans; eauto.
  Qed.

  Ltac destruct_join_flowsto :=
    match goal with
      [H: join ?a ?b ⊑ ?c |- _] => destruct (join_flowsto_implies_flowsto a b c H); clear H
    end.

  Lemma not_flowsto_implies_not_join_flowsto:
    forall a b c, ~ a ⊑ c -> ~ b ⊑ c -> ~ a ⊔ b ⊑ c.
  Proof.
    intros.
    intro.
    rewrite <- H2 in *.
    contradiction H0.
    eauto.
  Qed.

  Lemma implies_join_flowsto:
    forall a b c, a ⊑ c -> b ⊑ c -> a ⊔ b ⊑ c.
  Proof.
    intros.
    unfold flowsto in *.
    rewrite <- join_assoc.
    rewrite -> H1.
    assumption.
  Qed.
  Hint Resolve implies_join_flowsto.

  Lemma implies_meet_flowsto:
    forall c a b, c ⊑ a -> c ⊑ b -> c ⊑ a ⊓ b.
  Proof.
    intros.
    eapply meet_join_consistent in H0.
    eapply meet_join_consistent in H1.
    rewrite <- H0.
    rewrite <- H1.
    eapply meet_join_consistent.
    rewrite -> meet_assoc.
    repeat rewrite <- meet_assoc.
    rewrite -> (meet_assoc a a b).
    rewrite -> idem_meet.
    rewrite -> (meet_symmetry a b).
    rewrite -> (meet_assoc b b a).
    rewrite -> idem_meet.
    reflexivity.
  Qed.
  Hint Resolve implies_meet_flowsto.

  Lemma join_is_increasing:
    forall a b c, a ⊑ b -> a ⊑ b ⊔ c.
  Proof.
    intros.
    unfold flowsto in *.
    rewrite -> join_assoc.
    rewrite -> H0.
    reflexivity.
  Qed.
  Hint Resolve join_is_increasing.

  Lemma meet_is_decreasing:
    forall a b c, a ⊑ b -> a ⊓ c ⊑ b.
  Proof.
    intros.
    eapply meet_join_consistent.
    eapply meet_join_consistent in H0.
    rewrite <- meet_assoc.
    rewrite -> (meet_symmetry c b).
    rewrite -> meet_assoc.
    rewrite -> H0.
    reflexivity.
  Qed.
  Hint Resolve meet_is_decreasing.

  Lemma top_is_top:
    forall a, a ⊑ ⊤.
  Proof.
    intros.
    unfold flowsto in *.
    rewrite <- join_symmetry.
    eauto.
  Qed.
  Hint Resolve top_is_top.

  Lemma flowsto_top_is_top:
    forall a, ⊤ ⊑ a -> a === ⊤.
  Proof.
    intros a H_flows.
    unfold flowsto in *.
    rewrite -> join_top in H_flows.
    symmetry.
    assumption.
  Qed.
  Hint Resolve flowsto_top_is_top.

  Lemma bot_flowsto_is_bot:
    forall a, a ⊑ ⊥ -> a === ⊥.
  Proof.
    intros a H_flows.
    unfold flowsto in *.
    rewrite -> join_symmetry in H_flows.
    rewrite -> join_bot in H_flows.
    assumption.
  Qed.
  Hint Resolve bot_flowsto_is_bot.

  Lemma flowsto_dec:
    is_dec_rel eq -> forall a b, { a ⊑ b } + { ~ (a ⊑ b) }.
  Proof.
    intros.
    eapply H0.
  Qed.

End LatticeProperties.

Section ProductLattice.

  Context {A B : Set} `{lattice A} `{lattice B}.

  Definition eq_prod (ab1 ab2 : A * B) : Prop :=
    match ab1, ab2 with
      (a1, b1), (a2, b2) => a1 === a2 /\ b1 === b2
    end.
  Local Hint Unfold eq_prod.

  Lemma eq_prod_equiv:
    @Equivalence (A * B) eq_prod.
  Proof.
    unfold equiv.
    constructor.
    - unfold Reflexive.
      intros.
      destruct x as [a b].
      unfold eq.
      split; reflexivity.
    - unfold symmetric.
      intros [a1 b1] [a2 b2].
      intros [H1 H2].
      symmetry in H1.
      symmetry in H2.
      split; assumption.
    - intros [a1 b1] [a2 b2] [a3 b3] [H1 H2] [H3 H4].
      split.
      + rewrite -> H1; assumption.
      + rewrite -> H2; assumption.
  Qed.

  Definition meet_prod (x y : A * B) :=
    match x, y with
      (a1, b1), (a2, b2) => (a1 ⊓ a2, b1 ⊓ b2)
    end.

  Definition join_prod (x y : A * B) :=
    match x, y with
      (a1, b1), (a2, b2) => (a1 ⊔ a2, b1 ⊔ b2)
    end.
  Local Hint Unfold meet_prod join_prod.

  Global Instance product_lattice: lattice (A * B).
  eapply (Lattice _ join_prod meet_prod (⊤, ⊤) (⊥, ⊥) eq_prod).
  - eapply eq_prod_equiv.
  - intros [a1 b1] [a2 b2].
    simpl.
    split; eauto.
  - intros [a1 b1] [a2 b2].
    simpl.
    split; eauto.
  - intros [a1 b1] [a2 b2] [a3 b3].
    split; eauto.
  - intros [a1 b1] [a2 b2].
    split; eauto.
  - intros [a1 b1] [a2 b2] [a3 b3].
    split; eauto.
  - intros [a1 b1] [a2 b2].
    split; eauto.
  - intros [a b].
    split; eauto.
  - intros [a b].
    split; eauto.
  - intros [a b].
    split; eauto.
  - intros [a b].
    split; eauto.
  - intros [a1 b1] [a2 b2] [a3 b3] [a4 b4] [H1 H2] [H3 H4].
    unfold eq_prod, join_prod.
    rewrite -> H1.
    rewrite -> H3.
    rewrite -> H2.
    rewrite -> H4.
    split; reflexivity.
  - intros [a1 b1] [a2 b2] [a3 b3] [a4 b4] [H1 H2] [H3 H4].
    simpl.
    rewrite -> H1.
    rewrite -> H3.
    rewrite -> H2.
    rewrite -> H4.
    split; reflexivity.
  - intros [a1 b1] [a2 b2] [a3 b3] [H1 H2] [H3 H4].
    simpl.
    rewrite -> H1.
    rewrite -> H2.
    rewrite -> H3.
    rewrite -> H4.
    split; reflexivity.
  - intros [a1 b1] [a2 b2] [a3 b3] [H1 H2] [H3 H4].
    simpl.
    rewrite -> H1.
    rewrite -> H2.
    rewrite -> H3.
    rewrite -> H4.
    split; reflexivity.
  Defined.
  Hint Resolve product_lattice : typeclass_instances.

End ProductLattice.

(* An example lattice consisting of two points: L ⊑ H *)
Section LHLattice.

  Inductive LH :=
  | L: LH
  | H: LH.

  Definition meet_LH (a b : LH) :=
    match a with
    | L => L
    | H => b
    end.

  Definition join_LH (a b : LH) :=
    match a with
    | L => b
    | H => H
    end.

  Global Instance LH_lattice : lattice LH.
  Proof.
    eapply (Lattice LH join_LH meet_LH H L Logic.eq).
    - eapply eq_equivalence.
    - intros. destruct a; destruct b; reflexivity.
    - intros. destruct a; destruct b; reflexivity.
    - intros. destruct a; destruct b; destruct c; reflexivity.
    - intros a b; destruct a; destruct b; reflexivity.
    - intros a b c. destruct a; destruct b; destruct c; reflexivity.
    - intros a b. destruct a; destruct b; reflexivity.
    - constructor.
    - reflexivity.
    - reflexivity.
    - reflexivity.
    - congruence.
    - congruence.
    - congruence.
    - congruence.
  Defined.
  Hint Resolve LH_lattice : typeclass_instances.

End LHLattice.

Section FunLattice.

  Context {A B : Set} `{lattice B}.

  Definition fun_lattice_eq (f g : A -> B) :=
    forall (x : A), f x === g x.
  Local Hint Unfold fun_lattice_eq.

  Definition fun_lattice_join (f g : A -> B): A -> B :=
    fun x => f x ⊔ g x.
  Local Hint Unfold fun_lattice_join.

  Definition fun_lattice_meet (f g : A -> B): A -> B :=
    fun x => f x ⊓ g x.
  Local Hint Unfold fun_lattice_meet.

  Global Instance fun_lattice: lattice (A -> B).
  intros.
  eapply (Lattice (A -> B) fun_lattice_join fun_lattice_meet (fun _ => ⊤) (fun _ => ⊥) fun_lattice_eq).
  - constructor.
    + intros f x.
      reflexivity.
    + intros f g H.
      intro x.
      symmetry.
      eauto.
    + intros f g h ? ? x.
      transitivity (g x); eauto.
  - intros.
    intro x.
    unfold fun_lattice_meet.
    eauto.
  - intros f g x.
    unfold fun_lattice_join.
    eauto.
  - intros f g h.
    unfold fun_lattice_join.
    eauto.
  - intros f g h.
    unfold fun_lattice_join, fun_lattice_meet.
    eauto.
  - intros f g h.
    unfold fun_lattice_meet.
    eauto.
  - intros f g h.
    unfold fun_lattice_join, fun_lattice_meet.
    eauto.
  - intros.
    unfold fun_lattice_join.
    eauto.
  - intros.
    unfold fun_lattice_join.
    eauto.
  - intros.
    unfold fun_lattice_meet.
    eauto.
  - intros.
    unfold fun_lattice_meet.
    eauto.
  - intros.
    intros.
    unfold fun_lattice_join.
    intro.
    rewrite -> join_compat by eauto.
    reflexivity.
  - intros.
    intros.
    unfold fun_lattice_meet.
    intro.
    rewrite -> meet_compat by eauto.
    reflexivity.
  - intros.
    unfold fun_lattice_join.
    intro.
    rewrite -> flowsto_compat_right by eauto.
    reflexivity.
  - intros.
    unfold fun_lattice_join.
    intro.
    rewrite -> flowsto_compat_left by eauto.
    reflexivity.
  Defined.
  Hint Resolve fun_lattice : typeclass_instances.

End FunLattice.

Section DistributiveLattice.

  Context {A : Set}.

  Class distr_lattice (A : Set) :=
    DistrLattice {
        is_lattice :> lattice A;
        distr_meet_join: forall a b c, a ⊓ (b ⊔ c) === (a ⊓ b) ⊔ (a ⊓ c)
      }.

  Context `{distr_lattice A}.

  Lemma distr_join_meet:
    forall (a b c : A),
      a ⊔ (b ⊓ c) === (a ⊔ b) ⊓ (a ⊔ c).
  Proof.
    intros.
    rewrite -> distr_meet_join.
    rewrite -> (meet_symmetry _ a).
    rewrite -> meet_absorp.
    rewrite -> (meet_symmetry (a ⊔ b)).
    rewrite -> distr_meet_join.
    rewrite -> join_assoc.
    rewrite -> (meet_symmetry c).
    rewrite -> join_absorp.
    rewrite -> meet_symmetry.
    reflexivity.
  Qed.

  Lemma distr_meet_join_right:
    forall (a b c : A), (b ⊔ c) ⊓ a === (b ⊓ a) ⊔ (c ⊓ a).
  Proof.
    intros.
    rewrite -> meet_symmetry.
    rewrite -> (meet_symmetry b).
    rewrite -> (meet_symmetry c).
    eapply distr_meet_join.
  Qed.

  Lemma distr_join_meet_right:
    forall (a b c : A),
      (b ⊓ c) ⊔ a === (b ⊔ a) ⊓ (c ⊔ a).
  Proof.
    intros.
    rewrite -> join_symmetry.
    rewrite -> (join_symmetry b).
    rewrite -> (join_symmetry c).
    eapply distr_join_meet.
  Qed.

  Global Instance LH_distr_lattice : distr_lattice LH.
  Proof.
    econstructor.
    intros.
    destruct a; destruct b; destruct c; reflexivity.
  Qed.

  Lemma modular:
    forall (a b x : A),
      a ⊑ b -> a ⊔ (x ⊓ b) === (a ⊔ x) ⊓ b.
  Proof.
    intros.
    rewrite -> distr_meet_join_right.
    unfold flowsto in H1.
    eapply meet_join_consistent in H1.
    rewrite -> H1.
    reflexivity.
  Qed.

End DistributiveLattice.

Section WordLattice.
  Context {A D : Set}.

  Inductive Word :=
    Var: D -> Word
  | Lit: A -> Word
  | Join: Word -> Word -> Word
  | Meet: Word -> Word -> Word.
  Hint Constructors Word.

  Reserved Notation "'〚' x '〛' f" (at level 30, f at next level).

  Fixpoint eval `{lattice A} (f : D -> A) (x : Word) : A :=
    match x with
      Var n => f n
    | Lit a => a
    | Join x y => 〚x〛f ⊔ 〚y〛f
    | Meet x y => 〚x〛f ⊓ 〚y〛f
    end
  where "'〚' x '〛' f" := (eval f x).

  Definition eq_word `{lattice A} (x y : Word) :=
    forall (f : D -> A), 〚x〛f === 〚y〛f.
  Local Hint Unfold eq_word.

  Infix "≡" := eq_word (at level 70, no associativity).

  Definition join_word (x y : Word) := Join x y.
  Definition meet_word (x y : Word) := Meet x y.

  Infix "∪" := Join (at level 40, left associativity).
  Infix "∩" := Meet (at level 40, left associativity).

  Definition flowsto_word `{lattice A} (x y : Word) :=
    x ∪ y ≡ y.
  Hint Unfold flowsto_word.

  Infix "⊆" := (flowsto_word) (at level 70, no associativity).

  Lemma monotonicity `{lattice A}:
    forall (f1 f2 : D -> A) w,
      f1 ⊑ f2 ->
      〚w〛f1 ⊑ 〚w〛f2.
  Proof.
    intros.
    induction w.
    - simpl.
      eapply H1.
    - reflexivity.
    - simpl.
      rewrite -> IHw1.
      rewrite -> IHw2.
      reflexivity.
    - simpl.
      rewrite -> IHw1.
      rewrite -> IHw2.
      reflexivity.
  Qed.

  Lemma join_monotonicity `{distr_lattice A}:
    forall (f1 f2 : D -> A) w,
      〚w〛f1 ⊔〚w〛f2 ⊑ 〚w〛(f1 ⊔ f2).
  Proof.
    intros.
    induction w.
    - simpl.
      unfold fun_lattice_join.
      reflexivity.
    - simpl.
      rewrite -> idem_join.
      reflexivity.
    - simpl.
      rewrite <- IHw1.
      rewrite <- IHw2.
      rewrite -> (join_symmetry (〚 w1 〛 f2) (〚 w2 〛 f2)).
      rewrite <- join_assoc.
      rewrite -> (join_assoc (〚 w2 〛 f1) (〚 w2 〛 f2) (〚 w1 〛 f2)).
      rewrite -> (join_symmetry (〚 w2 〛 f1 ⊔ 〚 w2 〛 f2) (〚 w1 〛 f2)).
      rewrite -> join_assoc.
      reflexivity.
    - simpl.
      rewrite <- IHw1.
      rewrite <- IHw2.
      rewrite -> distr_meet_join, distr_meet_join_right, distr_meet_join_right.
      repeat rewrite <- join_assoc.
      rewrite -> (join_symmetry (〚 w1 〛 f1 ⊓ 〚 w2 〛 f2)).
      rewrite -> (join_symmetry (〚 w1 〛 f2 ⊓ 〚 w2 〛 f1)).
      repeat rewrite -> join_assoc.
      do 2 eapply join_is_increasing.
      reflexivity.
  Qed.

  Lemma meet_monotonicity `{distr_lattice A}:
    forall (f1 f2 : D -> A) w,
      〚w〛(f1 ⊓ f2) ⊑ 〚w〛f1 ⊓〚w〛f2.
  Proof.
    intros.
    induction w.
    - simpl.
      unfold fun_lattice_meet.
      reflexivity.
    - simpl.
      rewrite -> idem_meet.
      reflexivity.
    - simpl.
      replace fun_lattice_meet with (@meet (D -> A) _) by reflexivity.
      rewrite -> distr_meet_join, distr_meet_join_right, distr_meet_join_right.
      rewrite -> IHw1.
      rewrite <- IHw2.
      repeat rewrite <- join_assoc.
      rewrite -> (join_symmetry (〚 w1 〛 f1 ⊓ 〚 w2 〛 f2)).
      rewrite -> (join_assoc (〚 w2 〛 f1 ⊓ 〚 w1 〛 f2)).
      rewrite -> (join_symmetry (〚 w2 〛 f1 ⊓ 〚 w1 〛 f2)).
      repeat rewrite -> join_assoc.
      do 2 eapply join_is_increasing.
      reflexivity.
    - simpl.
      replace fun_lattice_meet with (@meet (D -> A) _) by reflexivity.
      rewrite -> IHw1.
      rewrite -> IHw2.
      repeat rewrite <- meet_assoc.
      rewrite -> (meet_assoc (〚 w2 〛 f1)).
      rewrite -> (meet_symmetry (〚 w2 〛 f1) (〚 w1 〛 f2)).
      repeat rewrite -> meet_assoc.
      reflexivity.
  Qed.

  Global Instance eq_words_eq `{lattice A}: Equivalence eq_word.
  Proof.
    constructor.
    - intros x f.
      reflexivity.
    - intros x y ? f.
      symmetry.
      eauto.
    - intros x y z ? ? f.
      transitivity (〚y〛f); eauto.
  Qed.

  Global Instance flowsto_word_preorder `{lattice A}: PreOrder flowsto_word.
  Proof.
    constructor.
    - intro.
      intro f.
      simpl.
      rewrite -> idem_join.
      reflexivity.
    - intros x y z ? ? f.
      specialize (H1 f).
      specialize (H2 f).
      simpl in *.
      rewrite <- H2.
      rewrite -> join_assoc.
      rewrite -> H1.
      reflexivity.
  Qed.

  Lemma meet_flowsto_word `{lattice A}:
    forall (w1 w2 : Word),
      w1 ∩ w2 ⊆ w1.
  Proof.
    intros.
    intros ?.
    simpl in *.
    rewrite -> join_symmetry.
    rewrite -> join_absorp.
    reflexivity.
  Qed.
  Hint Resolve meet_flowsto_word.

  Lemma join_flowsto_word `{lattice A}:
    forall (w1 w2 : Word),
      w1 ⊆ w1 ∪ w2.
  Proof.
    intros.
    intros ?.
    simpl in *.
    rewrite -> join_assoc.
    rewrite -> idem_join.
    reflexivity.
  Qed.
  Hint Resolve join_flowsto_word.

  Lemma meet_symmetry_word `{lattice A}:
    forall (w1 w2 : Word),
      w1 ∩ w2 ≡ w2 ∩ w1.
  Proof.
    intros.
    intro f.
    simpl.
    eauto.
  Qed.

  Lemma join_symmetry_word `{lattice A}:
    forall (w1 w2 : Word),
      w1 ∪ w2 ≡ w2 ∪ w1.
  Proof.
    intros.
    intro f.
    simpl.
    eauto.
  Qed.

  Global Instance proper_eq_word_flowsto `{lattice A}:
    Proper (eq_word ==> eq_word ==> flip impl) flowsto_word.
  Proof.
    intros x y ? z w ? ?.
    intro.
    specialize (H1 f).
    specialize (H2 f).
    specialize (H3 f).
    simpl in *.
    rewrite -> H1.
    rewrite -> H2.
    assumption.
  Qed.
  Hint Resolve proper_eq_word_flowsto : typeclass_instances.

  Global Instance eval_preserves_eq_proper `{lattice A} (f: D -> A):
    Proper (eq_word ==> eq) (eval f).
  Proof.
    intros x y ?.
    eapply H1.
  Defined.
  Hint Resolve eval_preserves_eq_proper : typeclass_instances.

  Global Instance join_preserves_eq_word `{lattice A}:
    Proper (eq_word ==> eq_word ==> eq_word) Join.
  Proof.
    intros x1 x2 ? y1 y2 ? f.
    simpl.
    rewrite -> H1.
    rewrite -> H2.
    reflexivity.
  Defined.

  Global Instance meet_preserves_eq_word `{lattice A}:
    Proper (eq_word ==> eq_word ==> eq_word) Meet.
  Proof.
    intros x1 x2 ? y1 y2 ? f.
    simpl.
    rewrite -> H1.
    rewrite -> H2.
    reflexivity.
  Defined.

  Hint Resolve join_preserves_eq_word meet_preserves_eq_word : typeclass_instances.

  Instance word_lattice `{lattice A} : lattice Word.
  Proof.
    econstructor.
    - eapply eq_words_eq.
    - eapply meet_symmetry_word.
    - eapply join_symmetry_word.
    - intros.
      intro.
      simpl.
      eapply join_assoc.
    - intros.
      intro.
      simpl.
      eapply join_absorp.
    - intros.
      intro.
      simpl.
      eapply meet_assoc.
    - intros.
      intro.
      eapply meet_absorp.
    - intros.
      instantiate (1 := Lit bot).
      intro.
      simpl.
      eapply join_bot.
    - intros.
      instantiate (1 := Lit top).
      intro.
      simpl.
      eapply join_top.
    - intros.
      intro.
      simpl.
      eapply meet_bot.
    - intros.
      intro.
      simpl.
      eapply meet_top.
    - intros.
      intro.
      simpl.
      rewrite -> H1.
      rewrite -> H2.
      reflexivity.
    - intros.
      intro.
      simpl.
      rewrite -> H1.
      rewrite -> H2.
      reflexivity.
    - intros.
      rewrite -> H1.
      assumption.
    - intros.
      rewrite -> H1.
      assumption.
  Qed.

End WordLattice.


Require Import HoTT.
From HoTT.Categories Require Import
     Category Functor NaturalTransformation FunctorCategory.
From GR.bicategories Require Import
     bicategory.bicategory
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.constant
     lax_transformation.lax_transformation
     lax_transformation.transformation_category.

Definition right_unit_assoc_inv
           {C : BiCategory}
           {X Y Z : C}
           (g : C⟦Y, Z⟧) (f : C⟦X,Y⟧)
  : right_unit (g · f) ∘ assoc_inv g f (id₁ X) = g ◅ right_unit f.
Proof.
  rewrite right_unit_assoc.
  rewrite !vcomp_assoc.
  rewrite assoc_left.
  apply vcomp_right_identity.
Qed.

Definition pseudo_cone
           `{Funext}
           {D C : BiCategory}
           (F : LaxFunctor D C)
           `{is_pseudo _ _ F}
           (Y : C)
  : Type
  := LaxTransformation (lax_constant Y) F.

Section ConeData.
  Context `{Funext}
          {D C : BiCategory}.
  Variable (F : LaxFunctor D C)
           (Y : C).
  Context `{is_pseudo _ _ F}.
  Variable (cone : pseudo_cone F Y).

  Definition maps (X : D) : C⟦Y, F X⟧
    := laxcomponent_of cone X.

  Definition commutes {X₁ X₂ : D} (f : D⟦X₁,X₂⟧)
    : (F ₁ f) · maps X₁ ==> maps X₂
    := right_unit (maps X₂) ∘ laxnaturality_of cone f.

  Definition commutes_natural
             {X₁ X₂ : D}
             {f g : D⟦X₁,X₂⟧}
             (α : f ==> g)
    : commutes g ∘ (F ₂ α) * id₂ (maps X₁) = commutes f.
  Proof.
    unfold commutes.
    rewrite !vcomp_assoc.
    f_ap.
    pose (laxnaturality_natural cone α) as p.
    rewrite hcomp_id₂, vcomp_left_identity in p.
    exact p.
  Qed.

  Definition commutes_unit
             (X : D)
    : commutes (id₁ X) ∘ Fid F X * id₂ (maps X) = left_unit (maps X).
  Proof.
    unfold commutes.
    pose (transformation_unit cone X) as p.
    cbn in p.
    rewrite hcomp_id₂, vcomp_left_identity in p.
    rewrite !vcomp_assoc.
    rewrite p ; clear p.
    rewrite <- !vcomp_assoc.
    rewrite right_unit_left.
    apply vcomp_left_identity.
  Qed.

  Definition commutes_assoc
             {X₁ X₂ X₃ : D}
             (g : D⟦X₂,X₃⟧) (f : D⟦X₁,X₂⟧)
    : commutes (g · f) ∘ Fcomp₁ F g f * id₂ (maps X₁)
      =
      (commutes g)
        ∘ (id₂ (F ₁ g) * commutes f)
        ∘ assoc (F ₁ g) (F ₁ f) (maps X₁).
  Proof.
    unfold commutes.
    rewrite !vcomp_assoc.
    rewrite (transformation_assoc cone f g).
    rewrite <- !vcomp_assoc.
    cbn.
    rewrite <- triangle_l.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite assoc_right.
    rewrite vcomp_left_identity.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite <- interchange.
    rewrite vcomp_left_identity.
    rewrite <- !vcomp_assoc.
    rewrite right_unit_natural.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite right_unit_assoc_inv.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite <- interchange.
    rewrite vcomp_left_identity.
    reflexivity.
  Qed.
End ConeData.