Require Import Omega.
Require Import Min.
Require Import Max.

Require Import set.
Require Import minmax.

(** * Indexed Calculus *)

(** ** Definition *)

(** *** Terms *)

(** Terms are written [a] or [b]. They are all indexed with a fuel (or
index) [k] which is the first argument of each construct.
*)
Inductive term : Set :=

(** Variables [Var k x], abstractions [Lam k a], and applications [App
k a b] are constructs related to arrow computational types.
*)
| Var (k : nat) (x : nat)
| Lam (k : nat) (a : term)
| App (k : nat) (a : term) (b : term)

(** Pairs [Pair k a b], and projections [Fst k a] and [Snd k a] are
constructs related to product computational types.
*)
| Unit (k : nat)
| Pair (k : nat) (a : term) (b : term)
| Fst (k : nat) (a : term)
| Snd (k : nat) (a : term)

(* sum *)
| Absurd (k : nat) (a : term)
| Inl (k : nat) (a : term)
| Inr (k : nat) (a : term)
| Match (k : nat) (a : term) (bl : term) (br : term)

(** Finally, generalizations [Gen k a] and instantiations [Inst k a]
are related to incoherent polymorphic types, which are computational.
Generalization is a weak reduction abstraction although it does not
bind anything.
*)
| Gen (k : nat) (a : term)
| Inst (k : nat) (a : term)
.

(** *** Functions *)

(** We define a few manipulations of indices and terms. The term
[map_fuel f a] has the same structure as the [a], but where each index
[k] has been modified to [f k]. We lift predicates form indices to
terms in [unary_fuel] for unary predicates and [binary_fuel] for
binary predicates. For binary predicates, the two terms have to share
a common structure.
*)
Definition map_fuel (f : nat -> nat) := fix g a :=
  match a with
    | Var k x => Var (f k) x
    | Lam k a => Lam (f k) (g a)
    | App k a b => App (f k) (g a) (g b)
    | Unit k => Unit (f k)
    | Pair k a b => Pair (f k) (g a) (g b)
    | Fst k a => Fst (f k) (g a)
    | Snd k a => Snd (f k) (g a)
    | Absurd k a => Absurd (f k) (g a)
    | Inl k a => Inl (f k) (g a)
    | Inr k a => Inr (f k) (g a)
    | Match k a bl br => Match (f k) (g a) (g bl) (g br)
    | Gen k a => Gen (f k) (g a)
    | Inst k a => Inst (f k) (g a)
  end.

Definition unary_fuel f := fix g a :=
  match a with
    | Var k x => f k
    | Lam k a => f k /\ g a
    | App k a b => f k /\ g a /\ g b
    | Unit k => f k
    | Pair k a b => f k /\ g a /\ g b
    | Fst k a => f k /\ g a
    | Snd k a => f k /\ g a
    | Absurd k a => f k /\ g a
    | Inl k a => f k /\ g a
    | Inr k a => f k /\ g a
    | Match k a bl br => f k /\ g a /\ g bl /\ g br
    | Gen k a => f k /\ g a
    | Inst k a => f k /\ g a
  end.

Definition binary_fuel f := fix g a b :=
  match a, b with
    | Var j x, Var k y => f j k /\ x = y
    | Lam j a, Lam k b => f j k /\ g a b
    | App j a1 a2, App k b1 b2 => f j k /\ g a1 b1 /\ g a2 b2
    | Unit j, Unit k => f j k
    | Pair j a1 a2, Pair k b1 b2 => f j k /\ g a1 b1 /\ g a2 b2
    | Fst j a, Fst k b => f j k /\ g a b
    | Snd j a, Snd k b => f j k /\ g a b
    | Absurd j a, Absurd k b => f j k /\ g a b
    | Inl j a, Inl k b => f j k /\ g a b
    | Inr j a, Inr k b => f j k /\ g a b
    | Match j a al ar, Match k b bl br => f j k /\ g a b /\ g al bl /\ g ar br
    | Gen j a, Gen k b => f j k /\ g a b
    | Inst j a, Inst k b => f j k /\ g a b
    | _, _ => False
  end.

(** We define a few common instantiations of these last three
functions. The function [lower k] updates to [k] the indices greater
than [k]. The binary predicate [le_term a b] holds when the term [a]
is pointwise less or equal than the term [b]. Finally, the predicates
[term_le a k], [term_lt a k], and [term_ge a k] say when the indices
of the term [a] are all less or equal, less than, and greater or equal
than [k], respectively.
*)
Definition lower k := map_fuel (fun j => min j k).
Definition le_term := binary_fuel le.
Definition term_le a k := unary_fuel (fun j => j <= k) a.
Definition term_lt a k := unary_fuel (fun j => j < k) a.
Definition term_ge a k := unary_fuel (fun j => j >= k) a.
Hint Unfold lower le_term term_le term_lt term_ge.

Ltac destruct_binary a H :=
  destruct a; simpl in H; try (exfalso; exact H);
  match type of H with
    | _ /\ _ /\ _ /\ _ => destruct H as [? [? [? ?]]]
    | _ /\ _ /\ _ => destruct H as [? [? ?]]
    | _ /\ _ => destruct H
    | _ => idtac
  end.

(** We define a function to traverse terms and operating on its
variables. The term [traverse f i a] has the same structure as [a] but
for its variables [Var k x] that become [f k x i]. The level [i]
indicates how deep we are in the term: it is incremented each time we
cross a binder. The only binder of the Indexed Calculus is [Lam] and
it binds only one term, so the recursive call uses the level [1 + i].
*)
Definition traverse f := fix g i a :=
  match a with
  | Var k x => f k x i
  | Lam k a => Lam k (g (1 + i) a)
  | App k a b => App k (g i a) (g i b)
  | Unit k => Unit k
  | Pair k a b => Pair k (g i a) (g i b)
  | Fst k a => Fst k (g i a)
  | Snd k a => Snd k (g i a)
  | Absurd k a => Absurd k (g i a)
  | Inl k a => Inl k (g i a)
  | Inr k a => Inr k (g i a)
  | Match k a bl br => Match k (g i a) (g (1 + i) bl) (g (1 + i) br)
  | Gen k a => Gen k (g i a)
  | Inst k a => Inst k (g i a)
  end.

(** We define the lifting function [lift] and substitution function
[subst] using the [traverse] function with the [lift_idx] and
[subst_idx] functions, respectively. The term [lift d i a] has the
same structure as [a] but the variables greater or equal than [i] are
incremented by [d]. The term [subst b i a] has the same structure as
[a] but the variables greater than [i] are decremented by one and the
variables equal to [i] are replaced with [b] lifted by [i] from level
[0] and lowered with the index [k] of the variable. This lowering is
necessary for lemma [lower_subst] and [subst_lower].
*)
Definition lift_idx d k x i := Var k (if le_gt_dec i x then d + x else x).
Definition lift d := traverse (lift_idx d).
Definition shift := lift 1.
Hint Unfold lift_idx lift shift.

Definition subst_idx b k x i :=
  match lt_eq_lt_dec x i with
    | inleft (left _)  => Var k x
    | inleft (right _) => lower k (lift x 0 b)
    | inright _        => Var k (x - 1)
  end.
Definition subst b := traverse (subst_idx b).
Hint Unfold subst_idx subst.

Ltac subst_lift_var := repeat (match goal with
    | |- context[subst_idx] => unfold subst_idx
    | |- context[lift_idx] => unfold lift_idx
    | |- context[lt_eq_lt_dec ?x ?y] => destruct (lt_eq_lt_dec x y) as [[?|?]|?]; try (exfalso; omega); simpl; auto
    | |- context[le_gt_dec ?x ?y] => destruct (le_gt_dec x y); try (exfalso; omega); simpl; auto
  end).

Definition set := @set term.

(** *** Reduction *)

(** Evaluation contexts [Ctx] contain all one-hole contexts of depth
one, but for [Gen]. This gives us strong reduction for all constructs
but [Gen], because the only role [Gen] is to block reduction. The
meaning of [Ctx] is given by the [fill] function. The term [fill c k
a] wraps the term [a] under the context [c] with index [k].
*)
Inductive Ctx : Set :=
| CtxLam
| CtxApp1 (b : term)
| CtxApp2 (a : term)
| CtxPair1 (b : term)
| CtxPair2 (a : term)
| CtxFst
| CtxSnd
| CtxAbsurd
| CtxInl
| CtxInr
| CtxMatch1 (bl : term) (br : term)
| CtxMatch2 (a : term) (br : term)
| CtxMatch3 (a : term) (bl : term)
(* NO CtxGen! *)
| CtxInst
.

Definition fill c k a :=
  match c with
    | CtxLam => Lam k a
    | CtxApp1 b => App k a b
    | CtxApp2 b => App k b a
    | CtxPair1 b => Pair k a b
    | CtxPair2 b => Pair k b a
    | CtxFst => Fst k a
    | CtxSnd => Snd k a
    | CtxAbsurd => Absurd k a
    | CtxInl => Inl k a
    | CtxInr => Inr k a
    | CtxMatch1 b1 b2 => Match k a b1 b2
    | CtxMatch2 b1 b2 => Match k b1 a b2
    | CtxMatch3 b1 b2 => Match k b1 b2 a
    | CtxInst => Inst k a
  end.

(** The reduction relation [red] has the usual rule of the Lambda
Calculus modulo the notion of indices. The indices of redex nodes of
the left-hand side of the reduction rule have to be strictly positive.
The right-hand side of the reduction rule is lowered by the minimum of
these first indices minus one. For example, the usual beta-reduction
rule:

[[
  red (App (Lam a) b) (subst b 0 a)
]]

becomes:

[[
  red (App (1 + k') (Lam (1 + k) a) b)
      (lower (min k' k) (subst b 0 a))
]]

Similarly for the context rule RedCtx which lowers the index (which
had to be strictly positive) of context node by one.

This index-manipulation is very brutal: it simplifies greatly the
proof of strong normalization [wf_der] in [Fnormalization_v] of the
untyped Indexed Calculus, but breaks confluence and some other
reduction related properties that we have in the Lambda Calculus.
*)
Inductive red : term -> term -> Prop :=
| RedCtx : forall k a a' c, red a a' -> red (fill c (1 + k) a) (fill c k a')
| RedApp : forall k k' a b, red (App (1 + k') (Lam (1 + k) a) b) (lower (min k' k) (subst b 0 a))
| RedFst : forall k k' a b, red (Fst (1 + k') (Pair (1 + k) a b)) (lower (min k' k) a)
| RedSnd : forall k k' a b, red (Snd (1 + k') (Pair (1 + k) a b)) (lower (min k' k) b)
| RedInl : forall k k' a bl br, red (Match (1 + k') (Inl (1 + k) a) bl br) (lower (min k' k) (subst a 0 bl))
| RedInr : forall k k' a bl br, red (Match (1 + k') (Inr (1 + k) a) bl br) (lower (min k' k) (subst a 0 br))
| RedInst : forall k k' a, red (Inst (1 + k') (Gen (1 + k) a)) (lower (min k' k) a)
.

(** *** Errors and valid terms *)

(** In order to define the notions of errors and valid terms, we need
to define the notions of neutral terms and head normal forms. Neutral
terms [N] are either variables and destructors, while head normal
forms [CN] are constructors.
*)
Definition N : set := fun a =>
  match a with
    | Var _ _ => True
    | Lam _ _ => False
    | App _ _ _ => True
    | Unit _ => False
    | Pair _ _ _ => False
    | Fst _ _ => True
    | Snd _ _ => True
    | Absurd _ _ => True
    | Inl _ _ => False
    | Inr _ _ => False
    | Match _ _ _ _ => True
    | Gen _ _ => False
    | Inst _ _ => True
  end.

Definition CN : set := fun a =>
  match a with
    | Var _ _ => False
    | Lam _ _ => True
    | App _ _ _ => False
    | Unit _ => True
    | Pair _ _ _ => True
    | Fst _ _ => False
    | Snd _ _ => False
    | Absurd _ _ => False
    | Inl _ _ => True
    | Inr _ _ => True
    | Match _ _ _ _ => False
    | Gen _ _ => True
    | Inst _ _ => False
  end.
Hint Unfold N CN.

(** Neutral terms and head normal forms partition the set of terms. A
term is either neutral or in head normal form.
*)
Lemma N_dec : forall a, {CN a} + {N a}.
Proof. destruct a; simpl; auto. Qed.

Lemma CN_N : forall a, CN a -> N a -> False.
Proof. destruct a; auto. Qed.

(** Head normal forms are preserved by substitution, reduction, and
lifting of binary predicates, such as [le_term].
*)
Lemma CN_subst : forall a, CN a -> forall b i, CN (subst b i a).
Proof.
induction a; simpl; intros; auto.
subst_lift_var.
Qed.

Lemma CN_red : forall a b, red a b -> CN a -> CN b.
Proof.
induction 1; intros CNa; simpl in CNa; try (exfalso; exact CNa).
destruct c; simpl in *; auto.
Qed.

Lemma CN_le_term : forall a b, le_term a b -> CN a -> CN b.
Proof.
induction a; simpl; intros b ab CNa; try (exfalso; exact CNa);
destruct_binary b ab; simpl; exact I.
Qed.

(** We define predicates to know when a term is not the constructor of
the arrow type, the product type, or the pi type. And we show that
they are stable by substitution and lifting of binary predicates.
*)
Definition NotArr a := forall k' a', a <> Lam k' a'.
Definition NotProd a := forall k' a' b', a <> Pair k' a' b'.
Definition NotSum a := forall k' a', a <> Inl k' a' /\ a <> Inr k' a'.
Definition NotPi a := forall k' a', a <> Gen k' a'.
Hint Unfold NotArr NotProd NotSum NotPi.

Lemma NotArr_subst : forall a, CN a -> NotArr a -> forall b i, NotArr (subst b i a).
Proof.
induction a; simpl; intro CNa; try (exfalso; exact CNa);
intros; intro k'; intros; intro Heq; auto; inversion Heq; clear Heq; subst.
apply (H k' a eq_refl).
Qed.

Lemma NotArr_le_term : forall a b, le_term a b -> NotArr a -> NotArr b.
Proof.
induction a; simpl; intros b ab NAa; destruct_binary b ab;
intros k' a' Heq; inversion Heq; subst.
apply (NAa k a eq_refl).
Qed.

Lemma NotProd_subst : forall a, CN a -> NotProd a -> forall b i, NotProd (subst b i a).
Proof.
induction a; simpl; intro CNa; try (exfalso; exact CNa);
intros; intro k'; intros; intro Heq; auto; inversion Heq; clear Heq; subst.
apply (H k' a1 a2 eq_refl).
Qed.

Lemma NotProd_le_term : forall a b, le_term a b -> NotProd a -> NotProd b.
Proof.
induction a; simpl; intros b ab NPa; destruct_binary b ab;
intros k' a' b' Heq; inversion Heq; subst.
apply (NPa k a1 a2 eq_refl).
Qed.

Lemma NotSum_subst : forall a, CN a -> NotSum a -> forall b i, NotSum (subst b i a).
Proof.
induction a; simpl; intro CNa; try (exfalso; exact CNa);
intros; intro k'; intros; split; intro Heq; auto; inversion Heq; clear Heq; subst.
apply (proj1 (H k' a) eq_refl).
apply (proj2 (H k' a) eq_refl).
Qed.

Lemma NotSum_le_term : forall a b, le_term a b -> NotSum a -> NotSum b.
Proof.
induction a; simpl; intros b ab NAa; destruct_binary b ab;
intros k' a'; split; intros Heq; inversion Heq; subst.
apply (proj1 (NAa k a) eq_refl).
apply (proj2 (NAa k a) eq_refl).
Qed.

Lemma NotPi_subst : forall a, CN a -> NotPi a -> forall b i, NotPi (subst b i a).
Proof.
induction a; simpl; intro CNa; try (exfalso; exact CNa);
intros; intro k'; intros; intro Heq; auto; inversion Heq; clear Heq; subst.
apply (H k' a eq_refl).
Qed.

Lemma NotPi_le_term : forall a b, le_term a b -> NotPi a -> NotPi b.
Proof.
induction a; simpl; intros b ab NAa; destruct_binary b ab;
intros k' a'; intros Heq; inversion Heq; subst.
apply (NAa k a eq_refl).
Qed.

(** We can now define the set of errors [Err]. An error is either an
immediate error or an error under any evaluation context. An immediate
error happens when a destructor is applied to a wrong constructor. For
example, the term [App k a b] is an error if the term [a] is a
constructor which is not of the arrow type, because [App] is the
destructor of the arrow type.
*)
Inductive Err : set :=
| ErrCtx : forall k e c, Err e -> Err (fill c k e)
| ErrApp : forall k a b, CN a -> NotArr a -> Err (App k a b)
| ErrFst : forall k a, CN a -> NotProd a -> Err (Fst k a)
| ErrSnd : forall k a, CN a -> NotProd a -> Err (Snd k a)
| ErrAbsurd : forall k a, CN a -> Err (Absurd k a)
| ErrMatch : forall k a bl br, CN a -> NotSum a -> Err (Match k a bl br)
| ErrInst : forall k a, CN a -> NotPi a -> Err (Inst k a)
.

(** Valid terms are simply the complementary of errors. We write [NV]
for neutral valid terms.
*)
Definition V : set := Cmp Err.
Hint Unfold V.

Definition NV : set := Inter N V.

(** ** Properties *)

(** Variables are valid neutral terms. Term abstraction are valid if
their body is valid too. Pairs are valid if their components are valid
too.
*)
Lemma V_Var : forall {k n}, V (Var k n).
Proof.
intros k n Herr; inversion Herr.
destruct c; inversion H.
Qed.

Lemma NV_Var : forall {k n}, NV (Var k n).
Proof. split; [exact I|apply V_Var]. Qed.

Lemma V_Unit : forall {k}, V (Unit k).
Proof.
intros k Herr; inversion Herr; auto.
destruct c; inversion H; clear H; subst; auto.
Qed.

Lemma V_Lam : forall {k a}, V a -> V (Lam k a).
Proof.
intros k a H Herr; inversion Herr; auto.
destruct c; inversion H0; clear H0; subst; auto.
Qed.

Lemma V_Pair : forall {k a b}, V a -> V b -> V (Pair k a b).
Proof.
intros k a b Ha Hb Herr; inversion Herr; auto.
destruct c; inversion H; clear H; subst; auto.
Qed.

Lemma V_Inl : forall {k a}, V a -> V (Inl k a).
Proof.
intros k a H Herr; inversion Herr; auto.
destruct c; inversion H0; clear H0; subst; auto.
Qed.

Lemma V_Inr : forall {k a}, V a -> V (Inr k a).
Proof.
intros k a H Herr; inversion Herr; auto.
destruct c; inversion H0; clear H0; subst; auto.
Qed.

(** Neutral terms behave like variables with respect to validity. When
a term is valid after subsittution by a neutral, then it was also
valid before the substitution.
*)
Lemma V_subst_N : forall a b, N b -> forall i, V (subst b i a) -> V a.
Proof.
intros a b Nb; induction a; intros i Va;
try (intros Errb; inversion Errb; clear Errb; subst);
try match goal with
  | H : fill ?c _ _ = _ |- _ => destruct c; inversion H; clear H; subst
end;
try match goal with
  | IH : forall _, _ -> V ?a
  , H : Err ?a |- _ => eapply IH; [|exact H]; intro; apply Va; simpl
end.
(* 20: CtxLam *)
  replace (Lam k (subst b (S i) a)) with (fill CtxLam k (subst b (S i) a)) by reflexivity.
  apply ErrCtx; eauto.
(* 19: CtxApp1 *)
  replace (App k (subst b i a1) (subst b i a2))
    with (fill (CtxApp1 (subst b i a2)) k (subst b i a1)) by reflexivity.
  apply ErrCtx; eauto.
(* 18: CtxApp2 *)
  replace (App k (subst b i a1) (subst b i a2))
    with (fill (CtxApp2 (subst b i a1)) k (subst b i a2)) by reflexivity.
  apply ErrCtx; eauto.
(* 17: App *)
  apply Va; simpl.
  apply ErrApp.
  apply CN_subst; auto.
  apply NotArr_subst; auto.
(* 16: CtxPair1 *)
  replace (Pair k (subst b i a1) (subst b i a2))
    with (fill (CtxPair1 (subst b i a2)) k (subst b i a1)) by reflexivity.
  apply ErrCtx; eauto.
(* 15: CtxPair2 *)
  replace (Pair k (subst b i a1) (subst b i a2))
    with (fill (CtxPair2 (subst b i a1)) k (subst b i a2)) by reflexivity.
  apply ErrCtx; eauto.
(* 14: CtxFst *)
  replace (Fst k (subst b i a)) with (fill CtxFst k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 13: Fst *)
  apply Va; simpl.
  apply ErrFst.
  apply CN_subst; auto.
  apply NotProd_subst; auto.
(* 12: CtxSnd *)
  replace (Snd k (subst b i a)) with (fill CtxSnd k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 11: Snd *)
  apply Va; simpl.
  apply ErrSnd.
  apply CN_subst; auto.
  apply NotProd_subst; auto.
(* 10: CtxAbsurd *)
  replace (Absurd k (subst b i a)) with (fill CtxAbsurd k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 9: Absurd *)
  apply Va; simpl.
  apply ErrAbsurd.
  apply CN_subst; auto.
(* 8: CtxInl *)
  replace (Inl k (subst b i a)) with (fill CtxInl k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 7: CtxInr *)
  replace (Inr k (subst b i a)) with (fill CtxInr k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 6: CtxMatch1 *)
  replace (Match k (subst b i a1) (subst b (S i) a2) (subst b (S i) a3))
    with (fill (CtxMatch1 (subst b (S i) a2) (subst b (S i) a3)) k (subst b i a1)) by reflexivity.
  apply ErrCtx; eauto.
(* 5: CtxMatch2 *)
  replace (Match k (subst b i a1) (subst b (S i) a2) (subst b (S i) a3))
    with (fill (CtxMatch2 (subst b i a1) (subst b (S i) a3)) k (subst b (S i) a2)) by reflexivity.
  apply ErrCtx; eauto.
(* 4: CtxMatch3 *)
  replace (Match k (subst b i a1) (subst b (S i) a2) (subst b (S i) a3))
    with (fill (CtxMatch3 (subst b i a1) (subst b (S i) a2)) k (subst b (S i) a3)) by reflexivity.
  apply ErrCtx; eauto.
(* 3: Match *)
  apply Va; simpl.
  apply ErrMatch.
  apply CN_subst; auto.
  apply NotSum_subst; auto.
(* 2: CtxInst *)
  replace (Inst k (subst b i a)) with (fill CtxInst k (subst b i a)) by reflexivity.
  apply ErrCtx; eauto.
(* 1: Gen *)
  apply Va; simpl.
  apply ErrInst.
  apply CN_subst; auto.
  apply NotPi_subst; auto.
Qed.

(** We now have some commutation and fusion lemma about lifting,
substitution, reduction and indices functions and predicates.
*)
Lemma lift_0 : forall a i, lift 0 i a = a.
Proof. induction a; intros i; simpl; [subst_lift_var|..]; f_equal; auto. Qed.

Lemma unary_fuel_1 : forall (f g : nat -> Prop), (forall j, f j -> g j) ->
  forall a, unary_fuel f a -> unary_fuel g a.
Proof.
intros f g fg; induction a; simpl; intros H;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
end; auto); auto.
Qed.

Lemma unary_fuel_2 : forall (g f1 f2 : nat -> Prop), (forall j, f1 j -> f2 j -> g j) ->
  forall a, unary_fuel f1 a -> unary_fuel f2 a -> unary_fuel g a.
Proof.
intros g f1 f2 fg; induction a; simpl; intros H1 H2;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
end; auto); auto.
Qed.

Lemma unary_fuel_map : forall (f : nat -> Prop) upd,
  (forall k, f k -> f (upd k)) ->
  forall a, unary_fuel f a -> unary_fuel f (map_fuel upd a).
Proof.
intros f upd fupd; induction a; intros H; simpl in *;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
end; auto); auto.
Qed.

Lemma unary_fuel_map_trivial : forall (f : nat -> Prop) upd,
  (forall k, f (upd k)) -> forall a, unary_fuel f (map_fuel upd a).
Proof.
intros f upd fupd; induction a; simpl in *;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
end; auto); auto.
Qed.

Lemma map_fuel_lift : forall d f a i,
  map_fuel f (lift d i a) = lift d i (map_fuel f a).
Proof. intros d f a; induction a; intros i; simpl; f_equal; auto. Qed.

Lemma lower_lift : forall d k a i,
  lower k (lift d i a) = lift d i (lower k a).
Proof. intros d k a i; apply map_fuel_lift. Qed.

Lemma lower_lower : forall k k' a, lower k (lower k' a) = lower (min k' k) a.
Proof. induction a; simpl; f_equal; auto; rewrite min_assoc; reflexivity. Qed.

Lemma lower_subst : forall b k a i,
  lower k (subst b i a) = subst b i (lower k a).
Proof.
intros b k a; induction a; intros i; simpl; f_equal; auto.
unfold subst_idx; destruct (lt_eq_lt_dec x i) as [[?|?]|?]; simpl; auto.
rewrite lower_lower; reflexivity.
Qed.

Lemma lift_lift : forall a d i j l, lift d (j + l) (lift (i + j) l a) = lift (i + d + j) l a.
Proof.
induction a; intros d i j l; simpl; auto; [| |f_equal; auto ..].
(* Var *) subst_lift_var; f_equal; omega.
(* Lam *) f_equal; rewrite plus_n_Sm; apply IHa.
(* Match2 *) rewrite plus_n_Sm; auto.
(* Match3 *) rewrite plus_n_Sm; auto.
Qed.

Lemma lift_subst : forall a b d i j,
  lift d j (subst b (i + j) a) = subst b (i + d + j) (lift d j a).
Proof.
induction a; intros b d i j; simpl; auto; [| |f_equal; auto..].
(* Var *)
  subst_lift_var; [|f_equal; omega].
  rewrite <- lower_lift; f_equal.
  replace j with (j + 0) by omega; subst.
  rewrite lift_lift.
  f_equal; omega.
(* Lam *)
  f_equal; rewrite plus_n_Sm; rewrite IHa; f_equal; omega.
(* Match2 *)
  rewrite plus_n_Sm; rewrite IHa2; f_equal; omega.
(* Match2 *)
  rewrite plus_n_Sm; rewrite IHa3; f_equal; omega.
Qed.

Lemma subst_lift : forall a b d i l,
  subst b (i + l) (lift (d + 1 + i) l a) = lift (d + i) l a.
Proof.
induction a; intros b d i l; simpl; auto; [| |f_equal; auto..].
(* Var *) subst_lift_var; f_equal; omega.
(* Lam *) f_equal; rewrite plus_n_Sm; rewrite IHa; auto.
(* Match2 *) rewrite plus_n_Sm; auto.
(* Match3 *) rewrite plus_n_Sm; auto.
Qed.

Lemma subst_lift_0 : forall a b, subst b 0 (lift 1 0 a) = a.
Proof. intros a b; pose proof (subst_lift a b 0 0 0); simpl in *; rewrite H; apply lift_0. Qed.

Lemma subst_subst : forall a b bd d i,
  subst bd (d + i) (subst b i a) = subst (subst bd d b) i (subst bd (1 + d + i) a).
Proof.
induction a; intros b bd d i; simpl; auto;
try solve [f_equal; first [rewrite IHa|rewrite IHa1|rewrite IHa2]; reflexivity].
(* Var *)
  subst_lift_var.
  (* *)
    rewrite <- lower_subst; f_equal.
    replace (subst bd d) with (subst bd (d + 0)) by (f_equal; omega).
    rewrite lift_subst; f_equal; omega.
  (* *)
    rewrite <- lower_subst; f_equal.
    replace i with (i + 0) by omega.
    replace x with (d + 1 + i) by omega.
    rewrite subst_lift.
    f_equal; omega.
(* Lam *)
  f_equal.
  rewrite plus_n_Sm.
  rewrite IHa; reflexivity.
(* Match *)
  f_equal.
  rewrite IHa1; reflexivity.
  rewrite plus_n_Sm; rewrite IHa2; reflexivity.
  rewrite plus_n_Sm; rewrite IHa3; reflexivity.
Qed.

Lemma subst_subst_0 : forall a b bd d,
  subst bd d (subst b 0 a) = subst (subst bd d b) 0 (subst bd (1 + d) a).
Proof.
intros.
replace d with (d + 0) by omega.
rewrite subst_subst; repeat f_equal; omega.
Qed.

Lemma subst_subst_0_0 : forall a b bd,
  subst bd 0 (subst b 0 a) = subst (subst bd 0 b) 0 (subst bd 1 a).
Proof. intros; rewrite subst_subst_0; repeat f_equal; omega. Qed.

Lemma binary_fuel_map : forall (op : nat -> nat -> Prop) upd' upd,
  (forall k' k, op k' k -> op (upd' k') (upd k)) ->
  forall a' a, binary_fuel op a' a -> binary_fuel op (map_fuel upd' a') (map_fuel upd a).
Proof.
intros op upd' upd H a'.
induction a'; intros; destruct_binary a H0; simpl; auto.
Qed.

Lemma binary_fuel_map_trivial : forall (op : nat -> nat -> Prop) upd,
  (forall k, op (upd k) k) ->
  forall a, binary_fuel op (map_fuel upd a) a.
Proof. intros op upd H a; induction a; simpl; auto. Qed.

Lemma binary_fuel_trans : forall (op : nat -> nat -> Prop),
  (forall k1 k2 k3, op k1 k2 -> op k2 k3 -> op k1 k3) ->
  forall a1 a2 a3, binary_fuel op a1 a2 -> binary_fuel op a2 a3 -> binary_fuel op a1 a3.
Proof.
intros op H a1.
induction a1; intros; destruct_binary a2 H0; destruct_binary a3 H1; simpl;
repeat split; first [omega|eauto].
Qed.

Lemma binary_fuel_refl : forall (op : nat -> nat -> Prop),
  (forall k, op k k) -> forall a, binary_fuel op a a.
Proof. intros op H a; induction a; simpl; try split; first [omega|eauto]. Qed.

Lemma le_term_lower : forall k' k a' a, k' <= k -> le_term a' a ->
  le_term (lower k' a') (lower k a).
Proof. intros; apply binary_fuel_map; intros; auto; minmax. Qed.

Lemma le_term_lower_trivial : forall k a, le_term (lower k a) a.
Proof. intros; apply binary_fuel_map_trivial; intros; minmax. Qed.

Lemma binary_fuel_lift : forall op d a' a i, binary_fuel op a' a ->
  binary_fuel op (lift d i a') (lift d i a).
Proof. induction a'; intros; destruct_binary a H; subst; simpl; auto. Qed.

Lemma le_term_subst : forall a' a b' b i, le_term b' b -> le_term a' a ->
  le_term (subst b' i a') (subst b i a).
Proof.
induction a'; intros; destruct_binary a H0; subst; simpl; auto.
(* Var *)
  unfold subst_idx.
  destruct (lt_eq_lt_dec x0 i) as [[?|?]|?]; subst; simpl; auto.
  rewrite 2 lower_lift.
  apply binary_fuel_lift.
  apply binary_fuel_map; auto.
  intros; minmax.
Qed.

Lemma le_term_red : forall a a' b', le_term a' a -> red a' b' -> exists b, red a b /\ le_term b' b.
Proof.
intros a a' b' lea Hred'; generalize a lea; clear a lea.
induction Hred'; intros; [destruct c|..]; destruct_binary a0 lea;
try match goal with
  | [ H1 : forall _, le_term ?a _ -> _
    , H2 : le_term ?a _ |- _ ] => destruct (H1 _ H2) as [? [? ?]]; clear H1 H2
end;
try match goal with
  | [ H : S _ <= ?k |- _ ] => destruct k; [inversion H|]
end.
(* 20: CtxLam *)
  exists (Lam k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxLam); auto.
(* 19: CtxApp1 *)
  exists (App k0 x a0_2); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_1 x (CtxApp1 a0_2)); auto.
(* 18: CtxApp2 *)
  exists (App k0 a0_1 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_2 x (CtxApp2 a0_1)); auto.
(* 17: CtxPair1 *)
  exists (Pair k0 x a0_2); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_1 x (CtxPair1 a0_2)); auto.
(* 16: CtxPair2 *)
  exists (Pair k0 a0_1 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_2 x (CtxPair2 a0_1)); auto.
(* 15: CtxFst *)
  exists (Fst k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxFst); auto.
(* 14: CtxSnd *)
  exists (Snd k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxSnd); auto.
(* 13: CtxAbsurd *)
  exists (Absurd k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxAbsurd); auto.
(* 12: CtxInl *)
  exists (Inl k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxInl); auto.
(* 11: CtxInr *)
  exists (Inr k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxInr); auto.
(* 10: CtxMatch1 *)
  exists (Match k0 x a0_2 a0_3); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_1 x (CtxMatch1 a0_2 a0_3)); auto.
(* 9: CtxMatch2 *)
  exists (Match k0 a0_1 x a0_3); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_2 x (CtxMatch2 a0_1 a0_3)); auto.
(* 8: CtxMatch3 *)
  exists (Match k0 a0_1 a0_2 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0_3 x (CtxMatch3 a0_1 a0_2)); auto.
(* 7: CtxInst *)
  exists (Inst k0 x); split; [|simpl; repeat split; first [omega|auto]].
  apply (RedCtx k0 a0 x CtxInst); auto.
(* 6: App *)
  destruct_binary a0_1 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) (subst a0_2 0 a0_1)).
  split; [apply RedApp|].
  apply le_term_lower; [minmax|].
  apply le_term_subst; assumption.
(* 5: Fst *)
  destruct_binary a0 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) a0_1).
  split; [apply RedFst|].
  apply le_term_lower; [minmax|assumption].
(* 4: Snd *)
  destruct_binary a0 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) a0_2).
  split; [apply RedSnd|].
  apply le_term_lower; [minmax; omega|assumption].
(* 3: Inl *)
  destruct_binary a0_1 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) (subst a0_1 0 a0_2)).
  split; [apply RedInl|].
  apply le_term_lower; [minmax|].
  apply le_term_subst; assumption.
(* 2: Inr *)
  destruct_binary a0_1 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) (subst a0_1 0 a0_3)).
  split; [apply RedInr|].
  apply le_term_lower; [minmax|].
  apply le_term_subst; assumption.
(* 1: Inst *)
  destruct_binary a0 H0.
  destruct k1; [inversion H0|].
  exists (lower (min k0 k1) a0).
  split; [apply RedInst|].
  apply le_term_lower; [minmax; omega|assumption].
Qed.

Lemma term_ge_dec : forall a k, term_ge a (1 + k) -> term_ge a k.
Proof.
intros a k H.
eapply unary_fuel_1; [|apply H].
simpl; intros; omega.
Qed.

Lemma term_ge_lower : forall k k', k' >= k -> forall a, term_ge a k -> term_ge (lower k' a) k.
Proof.
intros k k' kk' a H.
eapply unary_fuel_map; [|apply H].
intros; apply min_glb; omega.
Qed.

Lemma unary_fuel_traverse : forall (f : nat -> Prop) g, (forall k x i, f k -> unary_fuel f (g k x i)) ->
  forall a i, unary_fuel f a -> unary_fuel f (traverse g i a).
Proof.
intros f g fg; induction a; intros i H; simpl in *;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
  | |- _ >= _ => omega
end; auto); auto.
Qed.

Lemma unary_fuel_lift : forall f d a i, unary_fuel f a -> unary_fuel f (lift d i a).
Proof.
intros f d a i H.
apply unary_fuel_traverse; [|apply H].
intros k x l fk; subst_lift_var.
Qed.

Lemma term_ge_lift : forall d a k i, term_ge a k -> term_ge (lift d i a) k.
Proof. intros d a k i H; apply unary_fuel_lift; apply H. Qed.

Lemma unary_fuel_subst : forall (f : nat -> Prop), (forall j k, f j -> f k -> f (min j k)) ->
  forall a b i, unary_fuel f a -> unary_fuel f b -> unary_fuel f (subst b i a).
Proof.
intros f Hf a b i Ha Hb.
apply unary_fuel_traverse; [|apply Ha].
intros k x l fk; subst_lift_var.
apply unary_fuel_map; auto.
apply unary_fuel_lift; apply Hb.
Qed.

Lemma term_ge_subst : forall a k b i, term_ge a k -> term_ge b k -> term_ge (subst b i a) k.
Proof.
intros a k b i Ha Hb.
apply unary_fuel_subst; auto.
intros j1 j2; apply min_glb.
Qed.

Lemma unary_fuel_red : forall (f g : nat -> Prop),
  (forall k, f (S k) -> g k) -> (forall k, f k -> g k) -> (forall j k, g j -> g k -> g (min j k)) ->
  forall a b, red a b -> unary_fuel f a -> unary_fuel g b.
Proof.
intros f g HS Hinc Hmin a b Hred; induction Hred; [destruct c|..]; simpl; intros Ha;
repeat (match goal with
  | H : unary_fuel f ?a |- unary_fuel g ?a => apply unary_fuel_1 with (f := f); [apply Hinc|apply H]
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
  | |- _ >= _ => omega
end; auto); auto.
(* App *)
  apply unary_fuel_map; [|apply unary_fuel_subst]; auto; apply unary_fuel_1 with (f := f); auto.
(* Fst *) apply unary_fuel_map; auto; apply unary_fuel_1 with (f := f); auto.
(* Snd *) apply unary_fuel_map; auto; apply unary_fuel_1 with (f := f); auto.
(* Inl *)
  apply unary_fuel_map; [|apply unary_fuel_subst]; auto; apply unary_fuel_1 with (f := f); auto.
(* Inr *)
  apply unary_fuel_map; [|apply unary_fuel_subst]; auto; apply unary_fuel_1 with (f := f); auto.
(* Inst *) apply unary_fuel_map; auto; apply unary_fuel_1 with (f := f); auto.
Qed.

Lemma term_ge_red : forall a b k, red a b -> term_ge a (1 + k) -> term_ge b k.
Proof.
intros a b k Hred Ha.
eapply unary_fuel_red; [| | |apply Hred|apply Ha]; intros.
(* *) simpl in H; omega.
(* *) simpl in H; omega.
(* *) apply min_glb; omega.
Qed.

Lemma term_le_red : forall a b k, red a b -> term_le a k -> term_le b k.
Proof.
intros a b k Hred Ha.
eapply unary_fuel_red; [| | |apply Hred|apply Ha]; intros.
(* *) simpl in H; omega.
(* *) simpl in H; omega.
(* *) minmax.
Qed.

Lemma red_0 : forall a b, term_lt a 0 -> red a b -> False.
Proof.
intros a b H Hred; induction Hred; [destruct c|..]; simpl in *;
repeat (match goal with
  | H : _ < 0 |- _ => inversion H
  | H : _ /\ _ |- _ => destruct H
end; auto); auto.
Qed.

Lemma term_lt_red : forall a b k, red a b -> term_lt a k -> term_lt b k.
Proof.
intros a b k Hred Ha.
destruct k; [exfalso; eapply red_0; eauto|].
eapply unary_fuel_1; [|apply (term_le_red a b k Hred); eapply unary_fuel_1; [|apply Ha]];
instantiate; simpl; intros j H; omega.
Qed.

Lemma red_subst : forall a a' b, red a a' -> forall i, red (subst b i a) (subst b i a').
Proof.
intros a a' b Hred; induction Hred; [destruct c|..]; intros i; simpl.
(* 20: CtxLam *)
  eapply RedCtx with (k := k) (c := CtxLam); auto.
(* 19: CtxApp1 *)
  eapply RedCtx with (k := k) (c := CtxApp1 (subst b i b0)); auto.
(* 18: CtxApp2 *)
  eapply RedCtx with (k := k) (c := CtxApp2 (subst b i a0)); auto.
(* 17: CtxPair1 *)
  eapply RedCtx with (k := k) (c := CtxPair1 (subst b i b0)); auto.
(* 16: CtxPair2 *)
  eapply RedCtx with (k := k) (c := CtxPair2 (subst b i a0)); auto.
(* 15: CtxFst *)
  eapply RedCtx with (k := k) (c := CtxFst); auto.
(* 14: CtxSnd *)
  eapply RedCtx with (k := k) (c := CtxSnd); auto.
(* 13: CtxAbsurd *)
  eapply RedCtx with (k := k) (c := CtxAbsurd); auto.
(* 12: CtxInl *)
  eapply RedCtx with (k := k) (c := CtxInl); auto.
(* 11: CtxInr *)
  eapply RedCtx with (k := k) (c := CtxInr); auto.
(* 10: CtxMatch1 *)
  eapply RedCtx with (k := k) (c := CtxMatch1 (subst b (S i) bl) (subst b (S i) br)); auto.
(* 9: CtxMatch2 *)
  eapply RedCtx with (k := k) (c := CtxMatch2 (subst b i a0) (subst b (S i) br)); auto.
(* 8: CtxMatch3 *)
  eapply RedCtx with (k := k) (c := CtxMatch3 (subst b i a0) (subst b (S i) bl)); auto.
(* 7: CtxInst *)
  eapply RedCtx with (k := k) (c := CtxInst); auto.
(* 6: App *) rewrite <- lower_subst; rewrite subst_subst_0; apply RedApp.
(* 5: Fst *) rewrite <- lower_subst; apply RedFst.
(* 4: Snd *) rewrite <- lower_subst; apply RedSnd.
(* 3: Inl *) rewrite <- lower_subst; rewrite subst_subst_0; apply RedInl.
(* 2: Inr *) rewrite <- lower_subst; rewrite subst_subst_0; apply RedInr.
(* 1: Inst *) rewrite <- lower_subst; apply RedInst.
Qed.

Lemma subst_lower : forall a b i k, subst (lower k b) i (lower k a) = subst b i (lower k a).
Proof.
induction a; intros b i k0; simpl; [|f_equal; auto..].
(* Var *)
  subst_lift_var.
  rewrite <- lower_lift.
  rewrite lower_lower.
  f_equal.
  rewrite min_r; auto.
  apply le_min_r.
Qed.

Lemma red_lower : forall a b k, red a b ->
  exists b', red (lower (1 + k) a) b' /\ le_term (lower k b) b'.
Proof.
intros a b k Hred; induction Hred; [destruct c; destruct IHHred as [? [? ?]]|..]; simpl lower.
(* 20: CtxLam *)
  exists (Lam (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxLam); auto.
(* 19: CtxApp1 *)
  exists (App (min k0 k) x (lower (S k) b)); simpl; repeat split; auto.
  apply RedCtx with (c := CtxApp1 (lower (S k) b)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 18: CtxApp2 *)
  exists (App (min k0 k) (lower (S k) a0) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxApp2 (lower (S k) a0)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 17: CtxPair1 *)
  exists (Pair (min k0 k) x (lower (S k) b)); simpl; repeat split; auto.
  apply RedCtx with (c := CtxPair1 (lower (S k) b)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 16: CtxPair2 *)
  exists (Pair (min k0 k) (lower (S k) a0) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxPair2 (lower (S k) a0)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 15: CtxFst *)
  exists (Fst (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxFst); auto.
(* 14: CtxSnd *)
  exists (Snd (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxSnd); auto.
(* 13: CtxAbsurd *)
  exists (Absurd (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxAbsurd); auto.
(* 12: CtxInl *)
  exists (Inl (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxInl); auto.
(* 11: CtxInr *)
  exists (Inr (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxInr); auto.
(* 10: CtxMatch1 *)
  exists (Match (min k0 k) x (lower (S k) bl) (lower (S k) br)); simpl; repeat split; auto.
  apply RedCtx with (c := CtxMatch1 (lower (S k) bl) (lower (S k) br)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 9: CtxMatch2 *)
  exists (Match (min k0 k) (lower (S k) a0) x (lower (S k) br)); simpl; repeat split; auto.
  apply RedCtx with (c := CtxMatch2 (lower (S k) a0) (lower (S k) br)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 8: CtxMatch3 *)
  exists (Match (min k0 k) (lower (S k) a0) (lower (S k) bl) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxMatch3 (lower (S k) a0) (lower (S k) bl)); auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
  apply le_term_lower; auto; apply binary_fuel_refl; auto.
(* 7: CtxInst *)
  exists (Inst (min k0 k) x); simpl; repeat split; auto.
  apply RedCtx with (c := CtxInst); auto.
(* 6: App *)
  eexists; split; [apply RedApp|].
  rewrite subst_lower; rewrite <- lower_subst.
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
(* 5: Fst *)
  eexists; split; [apply RedFst|].
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
(* 4: Snd *)
  eexists; split; [apply RedSnd|].
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
(* 3: Inl *)
  eexists; split; [apply RedInl|].
  rewrite subst_lower; rewrite <- lower_subst.
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
(* 2: Inr *)
  eexists; split; [apply RedInr|].
  rewrite subst_lower; rewrite <- lower_subst.
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
(* 1: Inst *)
  eexists; split; [apply RedInst|].
  rewrite 2 lower_lower; (apply le_term_lower; [|apply binary_fuel_refl; auto]); minmax.
Qed.

Lemma term_le_lower : forall a k, term_le a k -> a = lower k a.
Proof.
induction a; intros ? H; simpl in *;
repeat (match goal with
  | |- context [min _ _] => rewrite min_l
  | H1 : _ /\ _ |- _ => destruct H1
  | IHa : forall _,_ -> _ = _ |- _ => rewrite <- IHa; clear IHa
end; auto); auto.
Qed.

Lemma term_le_max : forall a k j, term_le a k -> term_le a (max j k).
Proof.
intros; eapply unary_fuel_1; [|apply H]; instantiate; simpl; intros.
eapply le_trans; [apply H0|]; minmax.
Qed.

Lemma term_le_exists : forall a, exists k, term_le a k.
Proof.
induction a; repeat (match goal with
  | IHa : exists _, term_le _ _ |- _ => destruct IHa; clear IHa end).
(* 13: Var *) exists k; simpl; auto.
(* 12: Lam *)
  exists (max k x); simpl; split; [minmax|].
  apply term_le_max; assumption.
(* 11: App *)
  exists (max k (max x x0)); simpl; split; [|split].
  minmax.
  repeat (apply term_le_max); assumption.
  apply term_le_max; rewrite max_comm.
  apply term_le_max; assumption.
(* 10: Unit *)
  exists k; simpl; omega.
(* 9: Pair *)
  exists (max k (max x x0)); simpl; split; [|split].
  apply le_max_l.
  repeat (apply term_le_max); assumption.
  apply term_le_max; rewrite max_comm.
  apply term_le_max; assumption.
(* 8: Fst *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 7: Snd *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 6: Absurd *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 5: Inl *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 4: Inr *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 3: Match *)
  exists (max k (max x (max x0 x1))); simpl; repeat split.
  apply le_max_l.
  repeat (apply term_le_max); assumption.
  apply term_le_max; apply term_le_max; rewrite max_comm.
  apply term_le_max; assumption.
  apply term_le_max; rewrite max_comm; apply term_le_max; assumption.
(* 2: Gen *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
(* 1: Inst *)
  exists (max k x); simpl; split.
  apply le_max_l.
  apply term_le_max; assumption.
Qed.

Lemma term_lt_exists : forall a, exists k, term_lt a k.
Proof.
intros a; destruct (term_le_exists a).
exists (1 + x).
eapply unary_fuel_1; [|apply H].
simpl; intros j ?; omega.
Qed.

Lemma term_le_min : forall a k j, term_le a j -> term_le a k -> term_le a (min j k).
Proof.
intros a k j aj ak; eapply unary_fuel_2; [|apply aj|apply ak]; instantiate; simpl; intros.
apply min_glb; assumption.
Qed.

Lemma term_lt_min : forall a k j, term_lt a j -> term_lt a k -> term_lt a (min j k).
Proof.
intros a k j aj ak; eapply unary_fuel_2; [|apply aj|apply ak]; instantiate; simpl; intros.
apply min_glb; assumption.
Qed.

Lemma binary_fuel_unary : forall (op : nat -> nat -> Prop) (f : nat -> Prop),
  (forall j k, op j k -> f k -> f j) ->
  forall a b, binary_fuel op a b -> unary_fuel f b -> unary_fuel f a.
Proof.
intros op f opf; induction a; intros b ab fb; destruct_binary b ab; subst; simpl in *;
repeat (match goal with
  | H : _ /\ _ |- _ => destruct H
  | |- _ /\ _ => split
  | Hop : op ?j ?k, Hf : f ?k |- f ?j => apply (opf _ _ Hop Hf)
  | IHa : forall _, _ -> _ -> _ _ ?a
    , Hop : binary_fuel op ?a ?b
    , Hf : unary_fuel f ?b
    |- unary_fuel f ?a => apply (IHa b Hop Hf)
end; auto); auto.
Qed.

Lemma le_term_le : forall a b k, le_term a b -> term_le b k -> term_le a k.
Proof.
intros a b k ab bk; eapply binary_fuel_unary; [|apply ab|apply bk].
intros; omega.
Qed.

Lemma le_term_lt : forall a b k, le_term a b -> term_lt b k -> term_lt a k.
Proof.
intros a b k ab bk; eapply binary_fuel_unary; [|apply ab|apply bk].
intros; omega.
Qed.

Lemma lt_term_le : forall a j k, term_lt a j -> j <= k -> term_lt a k.
Proof.
intros a j k aj jk; eapply unary_fuel_1; [|apply aj].
simpl; intros; omega.
Qed.

Lemma term_lt_0 : forall a, term_lt a 0 -> False.
Proof.
destruct a; simpl; intros; repeat
match goal with
  | H : _ /\ _ |- _ => destruct H
  | H : ?k < 0 |- _ => inversion H
end.
Qed.


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

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

General definitions and results about relations.
*)

Set Implicit Arguments.

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

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

Ltac class := fold impl; auto with typeclass_instances.

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

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

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

Bind Scope relation_scope with relation.

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

Open Scope relation_scope.

Notation rel := relation.
Notation same_rel := same_relation.

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

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

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

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

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

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

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Section finitely_branching.

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

  Definition sons x := proj1_sig (FB x).

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

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

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

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

End finitely_branching.

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

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

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

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

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

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

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

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

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

Instance inclusion_Refl A : Reflexive (@inclusion A).

Proof. fo. Qed.

Ltac incl_refl := apply inclusion_Refl.

Instance inclusion_Trans A : Transitive (@inclusion A).

Proof. fo. Qed.

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

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

Proof. fo. Qed.

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

Proof. auto. Qed.

Implicit Arguments inclusion_elim [A R S x y].

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

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

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

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

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

Instance EIS_same_rel A : Proper (same_rel ==> impl) (@EIS A).

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

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

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

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

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

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

Instance irreflexive_inclusion A : Proper (inclusion --> impl) (@irreflexive A).

Proof. fo. Qed.

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

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

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

Proof. unfold monotone, transp. auto. Qed.

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

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

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

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

Proof. fo. Qed.

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

Instance compose_m A :
  Proper (same_rel ==> same_rel ==> same_rel) (@compose A).

Proof. fo. Qed.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

Instance rc_trans A (R : rel A) : Transitive R -> Transitive (R%).

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

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

Proof. fo. Qed.

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

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

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

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

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

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

Proof. fo. Qed.

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

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

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

Proof.
  unfold inclusion. intros. elim H; intros.
  apply rt_step. hyp.
  apply rt_trans with y0; hyp.
Qed.

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

Proof.
  unfold inclusion. induction 1. exists y. split. hyp. apply rt_refl.
  destruct IHclos_trans1. destruct H1. exists x0. split. hyp.
  apply rt_trans with y. hyp.
  apply inclusion_elim with (R:=R!). apply tc_incl_rtc. hyp.
Qed.

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

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

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

Proof. fo. Qed.

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

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

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

Proof.
  intro. unfold inclusion. intros. do 2 destruct H0. generalize x0 y H1 H0.
  induction 1; intros. apply t_step. apply H. exists x1; split; hyp.
  apply t_trans with (y := y0); auto.
Qed.

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

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

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

Proof.
  unfold inclusion. intros. do 2 destruct H. apply t_trans with x0; hyp.
Qed.

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

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

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

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

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

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

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

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

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

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

Instance tc_proper A (E R : rel A) : Reflexive E ->
  Proper (E ==> E ==> impl) R -> Proper (E ==> E ==> impl) (R!).

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

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

Section clos_sym.

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

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

  Global Instance sc_sym : Symmetric clos_sym.

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

End clos_sym.

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

Section clos_equiv.

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

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

  Global Instance ec_equiv : Equivalence clos_equiv.

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

End clos_equiv.

Instance clos_equiv_incl A : Proper (inclusion ==> inclusion) (@clos_equiv A).

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

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

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

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

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

Proof. fo. Qed.

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

Proof.
  intro. unfold inclusion. intros. elim H0; intros.
  apply rt_step. apply H. hyp.
  apply rt_refl.
  eapply rt_trans. apply H2. hyp.
Qed.

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

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

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

Proof.
  unfold inclusion, clos_refl. intros. destruct H.
  subst y. apply rt_refl. apply rt_step. exact H.
Qed.

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

Proof.
  unfold inclusion, union. intros. elim H.
  intros. right. apply t_step. hyp.
  intro. left. refl.
  intros. destruct H1; destruct H3.
  left. trans y0; hyp.
  subst y0. right. hyp.
  subst y0. right. hyp.
  right. apply t_trans with (y := y0); hyp.
Qed.

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

Proof.
  split. apply rtc_split. rewrite union_incl. split.
  intros x y h. subst. apply rt_refl. apply tc_incl_rtc.
Qed.

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

Proof.
  unfold inclusion, union. intros. elim H; clear H x y; intros.
  right. exists y; split. exact H. apply rt_refl. auto. destruct H0.
  subst y. destruct H2. auto. destruct H0. right. exists x0. auto.
  do 2 destruct H0. right. exists x0. split. exact H0.
  apply rt_trans with (y := y); auto.
Qed.

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

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

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

Proof.
  unfold inclusion. intros. destruct H. destruct H.
  ded (rtc_split H0). destruct H1; subst.
  apply t_step;hyp.
  eapply t_trans. apply t_step.
  ehyp. hyp.
Qed.

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

Proof.
  unfold inclusion. induction 1.
  apply rt_step. hyp.
  apply rt_refl.
  eapply rt_trans. apply IHclos_refl_trans2. apply IHclos_refl_trans1.
Qed.

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

Proof.
  unfold inclusion. induction 2.
  apply H. hyp.
  constructor 2.
  constructor 3 with y; hyp.
Qed.

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

Proof.
  unfold inclusion. intros. do 2 destruct H. apply rt_trans with x0; hyp.
Qed.

Lemma trans_rtc_incl A (R : rel A) : transitive R -> reflexive R -> R# << R.

Proof.
  unfold transitive, inclusion, reflexive. intros. induction H1. hyp.
  apply H0. apply H with y; hyp.
Qed.

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

Proof.
  split. intros x y. induction 1. hyp. apply rt_refl.
  apply rt_trans with y; hyp. apply rtc_incl.
Qed.

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

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

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

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

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

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

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

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

Proof. fo. Qed.

Instance transp_same_rel A : Proper (same_rel ==> same_rel) (@transp A).

Proof. fo. Qed.

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

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

Proof. auto. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

Lemma transp_transp A (R : rel A) : transp (transp R) << R.

Proof. fo. Qed.

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

Proof. fo. Qed.

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

Proof. fo. Qed.

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

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

Proof.
  unfold inclusion. intros. do 2 destruct H. ded (rtc_split2 H0). destruct H1.
  subst x0. exists x; split. apply rt_refl. exact H.
  do 4 destruct H1. exists y; split. apply rt_trans with (y := x1).
  apply rt_step. exists x2; split. apply rt_trans with (y := x0); hyp.
  hyp. hyp. apply rt_refl.
Qed.

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

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

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

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

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

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

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

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

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

Proof.
  intro. unfold inclusion. intros. destruct H0. subst y. apply rt_refl.
  apply inclusion_elim with (R := S!). apply tc_incl_rtc. apply H. exact H0.
Qed.

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

Proof.
  intro. unfold inclusion. induction 1. apply H. exact H0.
  apply rt_trans with (y := y); hyp.
Qed.

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

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

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

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

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

Section commut.

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

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

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

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

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

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

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

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

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

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

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

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

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

End commut.

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

Section inverse_image.

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

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

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

  Lemma Rof_refl : Reflexive R -> Reflexive Rof.

  Proof. fo. Qed.

  Lemma Rof_trans : Transitive R -> Transitive Rof.

  Proof. fo. Qed.

  Lemma Rof_sym : Symmetric R -> Symmetric Rof.

  Proof. fo. Qed.

  Variable F : A -> B -> Prop.

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

End inverse_image.

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

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

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

Lemma clos_trans1_trans A (R : rel A) x y z : R!1 x y -> R!1 y z -> R!1 x z.

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

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

Proof.
  split; intro H.
  induction H.
  constructor; exact H.
  exact (t_trans A R x y z (t_step A R x y H) IHclos_trans1).
  induction H.
  constructor; exact H.
  exact (clos_trans1_trans IHclos_trans1 IHclos_trans2).
Qed.

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

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

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

Lemma clos_refl_trans1_trans A (R : rel A) x y z :
  R#1 x y -> R#1 y z -> R#1 x z.

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

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

Proof.
  split; intro H.
  induction H.
  apply rt_refl.
  exact (rt_trans A R x y z (rt_step A R x y H) IHclos_refl_trans1).
  induction H.
  exact (rt1_trans x H (rt1_refl R y)).
  apply rt1_refl.
  exact (clos_refl_trans1_trans IHclos_refl_trans1 IHclos_refl_trans2).
Qed.

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

Proof.
  intros x y xRy. induction xRy.
  apply rt1_trans with y. hyp. apply rt1_refl.
  apply rt1_trans with y; hyp.
Qed.

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

Proof.
  intros x y [z [xRz zRy]]. induction xRz.
  trivial.
  apply rt1_trans with y0. hyp.
  apply IHxRz. hyp.
Qed.

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

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

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

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

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

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

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

Proof.
  intros x y xRy. induction xRy. apply rt1_refl.
  apply clos_refl_trans1_trans with y; trivial.
  destruct H.
  apply union_rel_rt_left. apply incl_t_rt. hyp.
  apply union_rel_rt_right. apply incl_t_rt. hyp.
Qed.

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

Proof.
  intros x y xRy. induction xRy. apply rt1_refl.
  apply clos_refl_trans1_trans with y; trivial.
  destruct H.
  apply union_rel_rt_left. apply rt1_trans with y.
  apply t1_step. hyp. apply rt1_refl.
  apply union_rel_rt_right. apply rt1_trans with y.
  apply t1_step. hyp. apply rt1_refl.
Qed.

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

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

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

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

Proof. fo. Qed.

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

Proof. fo. Qed.

Instance Transitive_same_rel A : Proper (same_rel ==> impl) (@Transitive A).

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

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

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

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

Proof. fo. Qed.

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

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

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

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

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

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

Instance Proper2_proper A (E : rel A) :
  Proper (same_rel ==> impl) (Proper (E ==> E ==> impl)).

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

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

Section opt_r.

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

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

  Global Instance opt_r_Refl : Reflexive R -> Reflexive opt_r.

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

  Global Instance opt_r_Sym : Symmetric R -> Symmetric opt_r.

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

  Global Instance opt_r_Trans : Transitive R -> Transitive opt_r.

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

  Global Instance Some_Proper : Proper (R ==> opt_r) (@Some A).

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

End opt_r.

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

Section opt.

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

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

  Global Instance opt_trans : Transitive R -> Transitive opt.

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

  Global Instance opt_sym : Symmetric R -> Symmetric opt.

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

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

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

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

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

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

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

End opt.

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

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

Instance opt_proper A (E1 E2 R : rel A) :
  Proper (E1 ==> E2 ==> impl) R -> Proper (opt E1 ==> opt E2 ==> impl) (opt R).

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

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

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

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

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

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

Section restrict.

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

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

  Global Instance restrict_proper E :
    Proper (E ==> impl) P -> Proper (E ==> E ==> impl) R ->
    Proper (E ==> E ==> impl) restrict.

  Proof.
    intros PE RE x x' xx' y y' yy' [hxy xy]. split.
    rewrite <- xx'. hyp.
    (*COQ:rewrite <- xx', <- yy'.*)
    eapply RE. apply xx'. apply yy'. hyp.
  Qed.

End restrict.

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

Proof. fo. Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat fintype.
From mathcomp Require Import bigop finset binomial fingroup morphism.
From mathcomp Require Import automorphism quotient gfunctor.

(******************************************************************************)
(*   This files contains the proofs of several key properties of commutators, *)
(* including the Hall-Witt identity and the Three Subgroup Lemma.             *)
(*   The definition and notation for both pointwise and set wise commutators  *)
(* ([~x, y, ...] and [~: A, B ,...], respectively) are given in fingroup.v    *)
(* This file defines the derived group series:                                *)
(*           G^`(0) ==  G                                                     *)
(*       G^`(n.+1) == [~: G^`(n), G^`(n)]                                     *)
(* as several classical results involve the (first) derived group G^`(1),     *)
(* such as the equivalence H <| G /\ G / H abelian <-> G^`(1) \subset H.      *)
(* The connection between the derived series and solvable groups will only be *)
(* established in nilpotent.v, however.                                       *)
(******************************************************************************)

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

Import GroupScope.

Definition derived_at_rec n (gT : finGroupType) (A : {set gT}) :=
  iter n (fun B => [~: B, B]) A.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section   *)
(* "cooking" destroys it.                                                    *)
Definition derived_at := nosimpl derived_at_rec.

Arguments derived_at n%N {gT} A%g.
Notation "G ^` ( n )" := (derived_at n G) : group_scope.

Section DerivedBasics.

Variables gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types G : {group gT}.

Lemma derg0 A : A^`(0) = A. Proof. by []. Qed.
Lemma derg1 A : A^`(1) = [~: A, A]. Proof. by []. Qed.
Lemma dergSn n A : A^`(n.+1) = [~: A^`(n), A^`(n)]. Proof. by []. Qed.

Lemma der_group_set G n : group_set G^`(n).
Proof. by case: n => [|n]; apply: groupP. Qed.

Canonical derived_at_group G n := Group (der_group_set G n).

End DerivedBasics.

Notation "G ^` ( n )" := (derived_at_group G n) : Group_scope.

Section Basic_commutator_properties.

Variable gT : finGroupType.
Implicit Types x y z : gT.

Lemma conjg_mulR x y : x ^ y = x * [~ x, y].
Proof. by rewrite mulKVg. Qed.

Lemma conjg_Rmul x y : x ^ y = [~ y, x^-1] * x.
Proof. by rewrite commgEr invgK mulgKV. Qed.

Lemma commMgJ x y z : [~ x * y, z] = [~ x, z] ^ y * [~ y, z].
Proof. by rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed.

Lemma commgMJ x y z : [~ x, y * z] = [~ x, z] * [~ x, y] ^ z.
Proof. by rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed.

Lemma commMgR x y z : [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z].
Proof. by rewrite commMgJ conjg_mulR. Qed.

Lemma commgMR x y z : [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z].
Proof. by rewrite commgMJ conjg_mulR mulgA. Qed.

Lemma Hall_Witt_identity x y z :
  [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1.
Proof. (* gsimpl *)
pose a x y z : gT := x * z * y ^ x.
suffices{x y z} hw_aux x y z: [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x).
  by rewrite !hw_aux 2!mulgA !mulgK mulVg.
by rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA.
Qed.

(* the following properties are useful for studying p-groups of class 2 *)

Section LeftComm.

Variables (i : nat) (x y : gT).
Hypothesis cxz : commute x [~ x, y].

Lemma commVg : [~ x^-1, y] = [~ x, y]^-1.
Proof.
apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz.
by rewrite -conjg_mulR -conjMg mulgV conj1g.
Qed.

Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i.
Proof.
elim: i => [|i' IHi]; first exact: comm1g.
by rewrite !expgS commMgJ /conjg commuteX // mulKg IHi.
Qed.

End LeftComm.

Section RightComm.

Variables (i : nat) (x y : gT).
Hypothesis cyz : commute y [~ x, y].
Let cyz' := commuteV cyz.

Lemma commgV : [~ x, y^-1] = [~ x, y]^-1.
Proof. by rewrite -invg_comm commVg -(invg_comm x y) ?invgK. Qed.

Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i.
Proof. by rewrite -invg_comm commXg -(invg_comm x y) ?expgVn ?invgK. Qed.

End RightComm.

Section LeftRightComm.

Variables (i j : nat) (x y : gT).
Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]).

Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j).
Proof. by rewrite expgM commgX commXg //; apply: commuteX. Qed.

Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ 'C(i, 2).
Proof.
rewrite -triangular_sum; symmetry.
elim: i => [|k IHk] /=; first by rewrite big_geq ?mulg1.
rewrite big_nat_recr //= addnC expgD !expgS -{}IHk !mulgA; congr (_ * _).
by rewrite -!mulgA commuteX2 // -commgX // [mulg y]lock 3!mulgA -commgC.
Qed.

End LeftRightComm.

End Basic_commutator_properties.

(***** Set theoretic commutators *****)
Section Commutator_properties.

Variable gT : finGroupType.
Implicit Type (rT : finGroupType) (A B C : {set gT}) (D G H K : {group gT}).

Lemma commG1 A : [~: A, 1] = 1.
Proof. by apply/commG1P; rewrite centsC sub1G. Qed.

Lemma comm1G A : [~: 1, A] = 1.
Proof. by rewrite commGC commG1. Qed.

Lemma commg_sub A B : [~: A, B] \subset A <*> B.
Proof. by rewrite comm_subG // (joing_subl, joing_subr). Qed.

Lemma commg_norml G A : G \subset 'N([~: G, A]).
Proof.
apply/subsetP=> x Gx; rewrite inE -genJ gen_subG.
apply/subsetP=> _ /imsetP[_ /imset2P[y z Gy Az ->] ->].
by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV).
Qed.

Lemma commg_normr G A : G \subset 'N([~: A, G]).
Proof. by rewrite commGC commg_norml. Qed.

Lemma commg_norm G H : G <*> H \subset 'N([~: G, H]).
Proof. by rewrite join_subG ?commg_norml ?commg_normr. Qed.

Lemma commg_normal G H : [~: G, H] <| G <*> H.
Proof. by rewrite /(_ <| _) commg_sub commg_norm. Qed.

Lemma normsRl A G B : A \subset G -> A \subset 'N([~: G, B]).
Proof. by move=> sAG; apply: subset_trans (commg_norml G B). Qed.

Lemma normsRr A G B : A \subset G -> A \subset 'N([~: B, G]).
Proof. by move=> sAG; apply: subset_trans (commg_normr G B). Qed.

Lemma commg_subr G H : ([~: G, H] \subset H) = (G \subset 'N(H)).
Proof.
rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy].
  rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->].
  by rewrite conjg_Rmul groupMr // sRH // imset2_f ?groupV.
case/imset2P=> x y Gx Hy ->{xy}.
by rewrite commgEr groupMr // memJ_norm (groupV, nGH).
Qed.

Lemma commg_subl G H : ([~: G, H] \subset G) = (H \subset 'N(G)).
Proof. by rewrite commGC commg_subr. Qed.

Lemma commg_subI A B G H :
  A \subset 'N_G(H) -> B \subset 'N_H(G) -> [~: A, B] \subset G :&: H.
Proof.
rewrite !subsetI -(gen_subG _ 'N(G)) -(gen_subG _ 'N(H)).
rewrite -commg_subr -commg_subl; case/andP=> sAG sRH; case/andP=> sBH sRG.
by rewrite (subset_trans _ sRG) ?(subset_trans _ sRH) ?commgSS ?subset_gen.
Qed.

Lemma quotient_cents2 A B K :
    A \subset 'N(K) -> B \subset 'N(K) ->
  (A / K \subset 'C(B / K)) = ([~: A, B] \subset K).
Proof.
move=> nKA nKB.
by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG.
Qed.

Lemma quotient_cents2r A B K :
  [~: A, B] \subset K -> (A / K) \subset 'C(B / K).
Proof.
move=> sABK; rewrite -2![_ / _]morphimIdom -!quotientE.
by rewrite quotient_cents2 ?subsetIl ?(subset_trans _ sABK) ?commgSS ?subsetIr.
Qed.

Lemma sub_der1_norm G H : G^`(1) \subset H -> H \subset G -> G \subset 'N(H).
Proof.
by move=> sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS.
Qed.

Lemma sub_der1_normal G H : G^`(1) \subset H -> H \subset G -> H <| G.
Proof. by move=> sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed.

Lemma sub_der1_abelian G H : G^`(1) \subset H -> abelian (G / H).
Proof. by move=> sG'H; apply: quotient_cents2r. Qed.

Lemma der1_min G H : G \subset 'N(H) -> abelian (G / H) -> G^`(1) \subset H.
Proof. by move=> nHG abGH; rewrite -quotient_cents2. Qed.

Lemma der_abelian n G : abelian (G^`(n) / G^`(n.+1)).
Proof. by rewrite sub_der1_abelian // der_subS. Qed.

Lemma commg_normSl G H K : G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]).
Proof. by move=> nHG; rewrite normsRr // commg_subr. Qed.

Lemma commg_normSr G H K : G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]).
Proof. by move=> nHG; rewrite !(commGC H) commg_normSl. Qed.

Lemma commMGr G H K : [~: G, K] * [~: H, K] \subset [~: G * H , K].
Proof. by rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed.

Lemma commMG G H K :
  H \subset 'N([~: G, K]) -> [~: G * H , K] = [~: G, K] * [~: H, K].
Proof.
move=> nRH; apply/eqP; rewrite eqEsubset commMGr andbT.
have nRHK: [~: H, K] \subset 'N([~: G, K]) by rewrite comm_subG ?commg_normr.
have defM := norm_joinEr nRHK; rewrite -defM gen_subG /=.
apply/subsetP=> _ /imset2P[_ z /imset2P[x y Gx Hy ->] Kz ->].
by rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg // (subsetP nRH).
Qed.

Lemma comm3G1P A B C :
  reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1).
Proof.
have R_C := sameP trivgP commG1P.
rewrite -subG1 R_C gen_subG -{}R_C gen_subG.
apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz].
  by apply/set1P; rewrite cABC // !imset2_f.
by case/imset2P=> _ z /imset2P[x y Ax By ->] Cz ->; rewrite cABC.
Qed.

Lemma three_subgroup G H K :
  [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1.
Proof.
move/eqP/comm3G1P=> cGHK /eqP/comm3G1P cHKG.
apply/eqP/comm3G1P=> x y z Kx Gy Hz; symmetry.
rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK.
by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV.
Qed.

Lemma der1_joing_cycles (x y : gT) :
  let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in
  xy \in 'C(XY) -> XY^`(1) = <[xy]>.
Proof.
rewrite joing_idl joing_idr /= -sub_cent1 => /norms_gen nRxy.
apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //.
rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen.
rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE.
rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=.
by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1.
Qed.

Lemma commgAC G x y z : x \in G -> y \in G -> z \in G ->
  commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y].
Proof.
move=> Gx Gy Gz cyz /centsP cRxG; pose cx' u := [~ x^-1, u].
have xR3 u v: [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v).
  rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg.
  by rewrite -mulgA conjgM -conjMg -!commgEl.
suffices RxGcx' u: u \in G -> cx' u \in [~: [set x], G].
  by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'.
move=> Gu; suffices/groupMl <-: [~ x, u] ^ x^-1 \in [~: [set x], G].
  by rewrite -commMgJ mulgV comm1g group1.
by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)).
Qed.

(* Aschbacher, exercise 3.6 (used in proofs of Aschbacher 24.7 and B & G 1.10 *)
Lemma comm_norm_cent_cent H G K :
    H \subset 'N(G) -> H \subset 'C(K) -> G \subset 'N(K) ->
  [~: G, H] \subset 'C(K).
Proof.
move=> nGH /centsP cKH nKG; rewrite commGC gen_subG centsC.
apply/centsP=> x Kx _ /imset2P[y z Hy Gz ->]; red.
rewrite mulgA -[x * _]cKH ?groupV // -!mulgA; congr (_ * _).
rewrite (mulgA x) (conjgC x) (conjgCV z) 3!mulgA; congr (_ * _).
by rewrite -2!mulgA (cKH y) // -mem_conjg (normsP nKG).
Qed.

Lemma charR H K G : H \char G -> K \char G -> [~: H, K] \char G.
Proof.
case/charP=> sHG chH /charP[sKG chK]; apply/charP.
by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK].
Qed.

Lemma der_char n G : G^`(n) \char G.
Proof. by elim: n => [|n IHn]; rewrite ?char_refl // dergSn charR. Qed.

Lemma der_sub n G : G^`(n) \subset G.
Proof. by rewrite char_sub ?der_char. Qed.

Lemma der_norm n G : G \subset 'N(G^`(n)).
Proof. by rewrite char_norm ?der_char. Qed.

Lemma der_normal n G : G^`(n) <| G.
Proof. by rewrite char_normal ?der_char. Qed.

Lemma der_subS n G : G^`(n.+1) \subset G^`(n).
Proof. by rewrite comm_subG. Qed.

Lemma der_normalS n G : G^`(n.+1) <| G^`(n).
Proof. by rewrite sub_der1_normal // der_subS. Qed.

Lemma morphim_der rT D (f : {morphism D >-> rT}) n G :
   G \subset D -> f @* G^`(n) = (f @* G)^`(n).
Proof.
move=> sGD; elim: n => // n IHn.
by rewrite !dergSn -IHn morphimR ?(subset_trans (der_sub n G)).
Qed.

Lemma dergS n G H : G \subset H -> G^`(n) \subset H^`(n).
Proof. by move=> sGH; elim: n => // n IHn; apply: commgSS. Qed.

Lemma quotient_der n G H : G \subset 'N(H) -> G^`(n) / H = (G / H)^`(n).
Proof. exact: morphim_der. Qed.

Lemma derJ G n x : (G :^ x)^`(n) = G^`(n) :^ x.
Proof. by elim: n => //= n IHn; rewrite !dergSn IHn -conjsRg. Qed.

Lemma derG1P G : reflect (G^`(1) = 1) (abelian G).
Proof. exact: commG1P. Qed.

End Commutator_properties.

Arguments derG1P {gT G}.

Lemma der_cont n : GFunctor.continuous (@derived_at n).
Proof. by move=> aT rT G f; rewrite morphim_der. Qed.

Canonical der_igFun n := [igFun by der_sub^~ n & der_cont n].
Canonical der_gFun n := [gFun by der_cont n].
Canonical der_mgFun n := [mgFun by dergS^~ n].

Lemma isog_der (aT rT : finGroupType) n (G : {group aT}) (H : {group rT}) :
  G \isog H -> G^`(n) \isog H^`(n).
Proof. exact: gFisog. Qed.