(* Generalizing the definition of pairs, we can describe the type of lists of numbers like this: "A list is either the empty list or else a pair of a number and another list." *)

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

(* For example, here is a three-element list: *)

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

(* As with pairs, it is more convenient to write lists in familiar programming notation. The following declarations allow us to use :: as an infix cons operator and square brackets as an "outfix" notation for constructing lists. *)

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* all equivalent *)
Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

(* Next let's look at several functions for constructing and manipulating lists. First, the repeat function takes a number n and a count and returns a list of length count in which every element is n. *)

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

(* The length function calculates the length of a list. *)
Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

(* The app function concatenates (appends) two lists. *)
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.

(* Since app will be used extensively, it is again convenient to have an infix operator for it. *)
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

(* Here are two smaller examples of programming with lists. The hd function returns the first element (the "head") of the list, while tl returns everything but the first element (the "tail"). Since the empty list has no first element, we pass a default value to be returned in that case. *)

Definition hd (default : nat) (l : natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.


Require Export ZArith.
Require Export FunInd.
Require Export Omega.
Open Scope Z_scope.

Inductive AB : Set :=
  | Node : Z -> AB -> AB -> AB
  | Empty : AB.

(*is_ABR node lower upper
equal goes left*)
Inductive is_ABR : AB -> (option Z) -> (option Z) -> Prop :=
  | Empty_N : is_ABR Empty None None
  | Empty_L : forall (vL : Z), is_ABR Empty (Some vL) None
  | Empty_U : forall (vR : Z), is_ABR Empty None (Some vR)
  | Empty_B : forall (vL vR : Z), vL <= vR -> is_ABR Empty (Some vL) (Some vR)
  | No_Limits : forall (v : Z) (aL aR : AB), is_ABR aL None (Some v) -> is_ABR aR (Some v) None ->
    is_ABR (Node v aL aR) None None
  | Lower : forall (v vL : Z) (aL aR : AB), v > vL -> is_ABR aL (Some vL) (Some v) ->
    is_ABR aR (Some v) None -> is_ABR (Node v aL aR) (Some vL) None
  | Upper : forall (v vR : Z) (aL aR : AB), v <= vR -> is_ABR aL None (Some v) ->
    is_ABR aR (Some v) (Some vR) -> is_ABR (Node v aL aR) None (Some vR)
  | Both : forall (v vL vR : Z) (aL aR : AB), v > vL -> v <= vR -> is_ABR aL (Some vL) (Some v) ->
    is_ABR aR (Some v) (Some vR) -> is_ABR (Node v aL aR) (Some vL) (Some vR).

Definition benchmark_01 := (Node 3 (Node 1 (Node 0 Empty Empty) (Node 3 Empty Empty)) (Node 5 Empty Empty)).
Definition benchmark_02 := (Node 5 (Node 3 (Node 2 Empty Empty) (Node 4 Empty Empty)) (Node 7 (Node 7 Empty Empty) (Node 8 Empty Empty))).
Definition benchmark_03 := (Node 15 (Node 12 (Node 11 (Node 5 Empty Empty) Empty) (Node 14 (Node 13 Empty (Node 14 Empty Empty)) (Node 15 Empty Empty))) (Node 18 (Node 17 Empty Empty) (Node 19 Empty (Node 20 Empty Empty)))).

Lemma p1 : is_ABR benchmark_01 None None.
apply No_Limits.
apply Upper.
omega.
apply Upper.
omega.
apply Empty_U.
apply Empty_B.
omega.
apply Both.
omega.
omega.
apply Empty_B.
omega.
apply Empty_B.
omega.
apply Lower.
omega.
apply Empty_B.
omega.
apply Empty_L.

Ltac apply_is_ABR :=
  repeat
  apply Empty_N || apply Empty_L || apply Empty_U || apply Empty_B ||
  apply No_Limits || apply Lower || apply Upper || apply Both || auto || omega.

Lemma p2 : is_ABR benchmark_02 None None.
apply_is_ABR.
Qed.

Lemma p3 : is_ABR benchmark_03 None None.
apply_is_ABR.
Qed.

Inductive value_exists : AB -> Z -> Prop :=
  | Curr : forall (v : Z) (aL aR : AB), value_exists (Node v aL aR) v
  | Left : forall (v vL : Z) (aL aR : AB), value_exists aL vL ->
    value_exists (Node v aL aR) vL
  | Right : forall (v vR : Z) (aL aR : AB), value_exists aR vR ->
    value_exists (Node v aL aR) vR.

Lemma p5 : value_exists benchmark_01 3.
eapply Curr.
Qed.

Lemma p6 : value_exists benchmark_03 17.
eapply Right.
eapply Left.
eapply Curr.
Qed.

Fixpoint search (arbre : AB) (v : Z) : bool :=
  match arbre with
  | Empty => false
  | Node w aL aR =>
    if Z.eq_dec v w then true
    else if Z_le_dec v w then search aL v
    else search aR v
end.

Functional Scheme search_ind := Induction for search Sort Prop.

Lemma both_upper : forall (arbre : AB) (vL vR : Z), is_ABR arbre (Some vL) (Some vR) ->
    is_ABR arbre None (Some vR).
intros.
induction H; apply_is_ABR.
Qed.

Lemma both_lower : forall (arbre : AB) (vL vR : Z), is_ABR arbre (Some vL) (Some vR) ->
    is_ABR arbre (Some vL) None.
intros.
induction H; apply_is_ABR.
Qed.

Lemma both_option_reduce : forall (arbre : AB) (vL vR : option Z), is_ABR arbre vL vR ->
    is_ABR arbre None None.
intros.
induction H; apply_is_ABR.
eapply both_upper.
apply H0.
eapply both_lower.
apply H1.
eapply both_upper.
apply H1.
eapply both_lower.
apply H2.
Qed.

Theorem search_sound :
  forall (arbre : AB) (v : Z), is_ABR arbre None None -> search arbre v = true -> value_exists arbre v.

Proof.
intro.
intro.
intro.
functional induction (search arbre v) using search_ind; intros.
eapply Curr.
eapply Left.
apply IHb.
inversion H.
eapply both_option_reduce.
apply H3.
assumption.
apply Right.
apply IHb.
inversion H.
eapply both_option_reduce.
apply H5.
assumption.
contradict H0.
auto.
Qed.

Lemma limits : forall (arbre : AB) (vL vR : Z), is_ABR arbre (Some vL) (Some vR) -> vL <= vR.
intros.
inversion H.
assumption.
omega.
Qed.

Lemma combine_limits_R : forall (arbre : AB) (vL vR1 vR2 : Z), is_ABR arbre (Some vL) (Some vR1) ->
    is_ABR arbre None (Some vR2) -> vR1 <= vR2 ->  is_ABR arbre (Some vL) (Some vR2).
intros.
induction arbre.
apply_is_ABR.
inversion H.
omega.
inversion H0.
omega.
inversion H.
assumption.
inversion H0.
assumption.
apply_is_ABR.
inversion H.
omega.
Qed.

Lemma right_loosen : forall (arbre : AB) (vR1 vR2 : Z), is_ABR arbre None (Some vR1) ->
    vR1 <= vR2 -> is_ABR arbre None (Some vR2).
intros.
induction arbre.
apply_is_ABR.
inversion H.
omega.
inversion H.
assumption.
inversion H.
eapply combine_limits_R.
apply H7.
apply IHarbre2.
eapply both_upper.
apply H7.
omega.
apply_is_ABR.
Qed.

Lemma left_less : forall (aL aR : AB) (v vL : Z), is_ABR (Node v aL aR) None None ->
    value_exists aL vL -> vL <= v.
intros.
induction H0.
inversion H.
inversion H2.
omega.
apply IHvalue_exists.
inversion H.
apply_is_ABR.
inversion H3.
eapply right_loosen.
apply H11.
omega.
apply IHvalue_exists.
inversion H.
apply_is_ABR.
inversion H3.
eapply both_upper.
apply H12.
Qed.

Lemma combine_limits_L : forall (arbre : AB) (vL1 vL2 vR : Z), is_ABR arbre (Some vL1) (Some vR) ->
    is_ABR arbre (Some vL2) None -> vL2 <= vL1 ->  is_ABR arbre (Some vL2) (Some vR).
intros.
induction arbre.
apply_is_ABR.
inversion H.
omega.
inversion H.
omega.
inversion H0.
assumption.
inversion H.
assumption.
apply_is_ABR.
inversion H.
omega.
Qed.

Lemma left_loosen : forall (arbre : AB) (vL1 vL2 : Z), is_ABR arbre (Some vL1) None ->
    vL2 <= vL1 -> is_ABR arbre (Some vL2) None.
intros.
induction arbre.
apply_is_ABR.
inversion H.
omega.
inversion H.
eapply combine_limits_L.
apply H6.
apply IHarbre1.
eapply both_lower.
apply H6.
assumption.
inversion H.
assumption.
apply_is_ABR.
Qed.

Lemma right_more : forall (aL aR : AB) (v vR : Z), is_ABR (Node v aL aR) None None ->
    value_exists aR vR -> vR > v.
intros.
induction H0.
inversion H.
inversion H4.
omega.
apply IHvalue_exists.
inversion H.
apply_is_ABR.
inversion H5.
eapply both_lower.
apply H11.
apply IHvalue_exists.
inversion H.
apply_is_ABR.
inversion H5.
eapply left_loosen.
apply H12.
omega.
Qed.

Theorem search_complete : forall (arbre : AB) (v : Z), is_ABR arbre None None ->
    value_exists arbre v -> search arbre v = true.
intro.
intro.
intro.
intro.
induction H0.
simpl.
elim (Z.eq_dec v v); intro; auto.
simpl.
elim (Z.eq_dec vL v); intro; auto.
elim (Z_le_dec vL v); intro; auto.
apply IHvalue_exists.
inversion H.
eapply both_option_reduce.
apply H3.
contradict b0.
eapply left_less.
apply H.
apply H0.
simpl.
elim (Z.eq_dec vR v); intro; auto.
elim (Z_le_dec vR v); intro; auto.
destruct a.
eapply right_more.
apply H.
apply H0.
apply IHvalue_exists.
inversion H.
eapply both_option_reduce.
apply H5.
Qed.

Fixpoint insert (arbre : AB) (v : Z) : AB :=
  match arbre with
  | Empty => (Node v Empty Empty)
  | Node w aL aR =>
    if Z.eq_dec v w then arbre
    else if Z_le_dec v w then (Node w (insert aL v) aR)
    else (Node w aL (insert aR v))
end.

Functional Scheme insert_ind := Induction for insert Sort Prop.

Lemma combine : forall (vL vR : Z) (arbre : AB), is_ABR arbre None (Some vR) ->
    is_ABR arbre (Some vL) None -> vL <= vR -> is_ABR arbre (Some vL) (Some vR).
intros.
induction arbre.
apply_is_ABR.
inversion H0.
omega.
inversion H.
omega.
inversion H0.
assumption.
inversion H.
assumption.
apply_is_ABR.
Qed.

Lemma insert_right : forall (v vR : Z) (arbre : AB), is_ABR arbre None (Some vR) ->
    is_ABR (insert arbre v) None None -> v <= vR -> is_ABR (insert arbre v) None (Some vR).
intros.
functional induction (insert arbre v) using insert_ind; intros.
assumption.
apply_is_ABR.
inversion H.
omega.
inversion H0.
assumption.
inversion H.
assumption.
apply_is_ABR.
inversion H.
inversion H.
assumption.
inversion H0.
apply combine.
apply IHa.
eapply both_upper.
inversion H.
apply H13.
eapply both_option_reduce.
apply H6.
assumption.
assumption.
omega.
apply_is_ABR.
Qed.

Lemma insert_left : forall (v vL : Z) (arbre : AB), is_ABR arbre (Some vL) None ->
    is_ABR (insert arbre v) None None -> v > vL -> is_ABR (insert arbre v) (Some vL) None.
intros.
functional induction (insert arbre v) using insert_ind; intros.
assumption.
apply_is_ABR.
apply combine.
inversion H0.
assumption.
apply IHa.
inversion H.
eapply both_lower.
apply H7.
inversion H0.
eapply both_option_reduce.
apply H4.
omega.
omega.
inversion H.
assumption.
apply_is_ABR.
inversion H.
omega.
inversion H.
assumption.
inversion H0.
assumption.
apply_is_ABR.
Qed.

Lemma insert_is_ABR : forall (v : Z) (a_in : AB), is_ABR a_in None None ->
    is_ABR (insert a_in v) None None.
intro.
intro.
intro.
functional induction (insert a_in v) using insert_ind; intros.
apply_is_ABR.
inversion H.
assumption.
inversion H.
assumption.
apply_is_ABR.
inversion H.
eapply insert_right; auto.
apply IHa.
eapply both_option_reduce.
apply H2.
inversion H.
assumption.
inversion H.
apply_is_ABR.
apply insert_left; auto.
apply IHa.
eapply both_option_reduce.
apply H4.
omega.
apply_is_ABR.
Qed.

Lemma insert_new_value : forall (v : Z) (a_in : AB), is_ABR a_in None None ->
    value_exists (insert a_in v) v.
intros.
functional induction (insert a_in v) using insert_ind; intros.
apply Curr.
apply Left.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H2.
apply Right.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H4.
apply Curr.
Qed.

Lemma insert_no_loss : forall (v : Z) (a_in : AB), is_ABR a_in None None ->
    (forall (w : Z), value_exists a_in w -> value_exists (insert a_in v) w).
intros.
functional induction (insert a_in v) using insert_ind; intros.
assumption.
inversion H0.
apply Curr.
apply Left.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H8.
assumption.
apply Right.
assumption.
inversion H0.
apply Curr.
apply Left.
assumption.
apply Right.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H10.
assumption.
inversion H0.
Qed.

Theorem insert_sound : forall (v : Z) (a_in a_out : AB), is_ABR a_in None None -> a_out = (insert a_in v) ->
    is_ABR a_out None None /\ value_exists a_out v /\ (forall (w : Z), value_exists a_in w -> value_exists a_out w).
intros.
rewrite H0.
split.
apply insert_is_ABR.
assumption.
split.
apply insert_new_value.
assumption.
apply insert_no_loss.
assumption.
Qed.

Fixpoint find_max (arbre : AB) : option Z :=
  match arbre with
  | Empty => None
  | (Node x _ Empty) => (Some x)
  | (Node x _ aR) => find_max aR
end.

Fixpoint delete (arbre : AB) (v : Z) : AB :=
  match arbre with
  | Empty => Empty
  | (Node w aL aR) =>
    if Z.eq_dec w v then
    match aL, aR with
    | Empty, aR => aR
    | aL, Empty => aL
    | aL, aR => let max := find_max aL in
      match max with
      | None => aR
      | Some x => (Node x (delete aL x) aR)
    end
   end
    else if Z_lt_dec v w then (Node w (delete aL v) aR)
    else (Node w aL (delete aR v))
end.

Functional Scheme find_max_ind := Induction for find_max Sort Prop.
Functional Scheme delete_ind := Induction for delete Sort Prop.

Lemma max_geq : forall (arbre : AB) (x vR : Z) (L : option Z), is_ABR arbre L (Some vR) ->
    (find_max arbre) = (Some x) -> x <= vR.
intros.
functional induction (find_max arbre) using find_max_ind.
apply IHo.
inversion H.
eapply both_upper.
apply H8.
apply combine.
eapply both_upper.
apply H9.
eapply left_loosen.
eapply both_lower.
apply H9.
eapply limits.
apply H8.
inversion H9.
cut (vL <= x0).
omega.
eapply limits.
apply H8.
apply H0.
inversion H0.
rewrite <- H2.
inversion H; omega.
inversion H0.
Qed.

Lemma min_less : forall (arbre : AB) (x vL : Z) (R : option Z), is_ABR arbre (Some vL) R ->
    find_max arbre = (Some x) -> x > vL.
intros.
functional induction (find_max arbre) using find_max_ind.
apply IHo.
inversion H.
eapply left_loosen.
apply H8.
eapply limits.
apply H7.
apply combine.
eapply both_upper.
apply H9.
eapply left_loosen.
eapply both_lower.
apply H9.
eapply limits.
apply H8.
cut (vL <= x0).
omega.
eapply limits.
apply H8.
auto.
inversion H0.
rewrite <- H2.
inversion H; omega.
inversion H0.
Qed.

Lemma max_limit : forall (arbre : AB) (x : Z), is_ABR arbre None None ->
    (find_max arbre) = (Some x) -> is_ABR arbre None (Some x).
intros.
functional induction (find_max arbre) using find_max_ind.
apply_is_ABR.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H1.
inversion H.
inversion H13.
omega.
apply IHo.
inversion H.
eapply both_option_reduce.
apply H5.
auto.
inversion H.
auto.
inversion H.
inversion H5.
omega.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H1.
eapply limits.
apply H8.
apply IHo.
inversion H.
eapply both_option_reduce.
apply H5.
auto.
inversion H.
inversion H5.
auto.
inversion H.
inversion H5.
apply combine.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H13.
eapply both_upper.
apply H20.
apply IHo.
inversion H.
eapply both_option_reduce.
apply H5.
auto.
apply H12.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H13.
omega.
apply IHo.
inversion H.
eapply both_option_reduce.
apply H5.
auto.
inversion H.
inversion H0.
apply_is_ABR.
rewrite <- H7.
auto.
inversion H0.
Qed.

Lemma delete_right : forall (arbre : AB) (v vR : Z), is_ABR arbre None (Some vR) ->
    is_ABR (delete arbre v) None None -> is_ABR (delete arbre v) None (Some vR).
intros.
functional induction (delete arbre v) using delete_ind; apply_is_ABR.
eapply max_geq.
inversion H.
eapply right_loosen.
apply H6.
omega.
apply e3.
inversion H0.
simpl.
auto.
inversion H0.
inversion H5.
omega.
inversion H.
inversion H7.
omega.
inversion H.
inversion H7.
apply combine.
eapply both_upper.
apply H15.
eapply left_loosen.
eapply both_lower.
apply H15.
eapply max_geq.
apply H6.
auto.
inversion H0.
inversion H21.
omega.
inversion H.
inversion H7.
apply H16.
inversion H.
inversion H7.
omega.
inversion H0.
auto.
inversion H.
inversion H7.
auto.
inversion H.
inversion H6.
cut (w <= vR).
omega.
eapply limits.
apply H7.
inversion H.
inversion H6.
auto.
inversion H.
inversion H6.
apply combine.
eapply right_loosen.
eapply both_upper.
apply H14.
eapply limits.
apply H7.
eapply both_lower.
apply H14.
cut (w <= vR).
omega.
eapply limits.
apply H7.
inversion H.
eapply both_upper.
apply H7.
inversion H.
omega.
inversion H0.
apply H3.
inversion H.
auto.
inversion H.
auto.
inversion H.
auto.
inversion H0.
inversion H.
apply combine.
apply IHa.
eapply both_upper.
apply H12.
eapply both_option_reduce.
apply H5.
auto.
eapply limits.
apply H12.
Qed.

Lemma delete_left : forall (arbre : AB) (v vL : Z), is_ABR arbre (Some vL) None ->
    is_ABR (delete arbre v) None None -> is_ABR (delete arbre v) (Some vL) None.
intros.
functional induction (delete arbre v) using delete_ind; apply_is_ABR.
eapply min_less.
inversion H.
apply H6.
auto.
apply combine.
inversion H0.
simpl.
auto.
apply IHa.
inversion H.
eapply both_lower.
apply H6.
eapply both_option_reduce.
simpl.
inversion H0.
apply H3.
cut (x > vL).
omega.
eapply min_less.
inversion H.
apply H6.
auto.
cut (x <= w).
intro.
inversion H.
inversion H8.
omega.
eapply max_geq.
inversion H.
apply H6.
auto.
inversion H.
inversion H7.
apply combine.
eapply both_upper.
apply H13.
eapply left_loosen.
eapply both_lower.
apply H13.
eapply max_geq.
apply H6.
auto.
cut (x <= w).
omega.
eapply max_geq.
apply H6.
auto.
inversion H.
inversion H7.
auto.
inversion H.
inversion H7.
auto.
cut (vL <= w).
omega.
eapply limits.
apply H6.
inversion H.
inversion H7.
apply combine.
eapply both_upper.
apply H13.
eapply left_loosen.
eapply both_lower.
apply H13.
eapply limits.
apply H6.
cut (vL <= w).
omega.
eapply limits.
apply H6.
inversion H.
inversion H7.
auto.
inversion H.
inversion H6.
omega.
inversion H.
inversion H6.
auto.
inversion H.
inversion H6.
eapply both_lower.
apply H16.
inversion H.
eapply left_loosen.
apply H7.
eapply limits.
apply H6.
inversion H.
omega.
apply combine.
inversion H0.
auto.
apply IHa.
inversion H.
eapply both_lower.
apply H6.
inversion H0.
eapply both_option_reduce.
apply H3.
inversion H.
omega.
inversion H.
auto.
inversion H.
omega.
inversion H.
auto.
inversion H0.
auto.
Qed.

Lemma delete_is_ABR : forall (arbre : AB) (v : Z), is_ABR arbre None None ->
    is_ABR (delete arbre v) None None.
intros.
functional induction (delete arbre v) using delete_ind; apply_is_ABR.
eapply delete_right.
apply_is_ABR.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H0.
eapply limits.
apply H7.
eapply max_limit.
inversion H.
eapply both_option_reduce.
apply H2.
apply e3.
inversion H.
inversion H2.
apply H10.
inversion H.
inversion H2.
apply combine.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H12.
eapply both_upper.
apply H19.
eapply max_limit.
eapply both_option_reduce.
apply H2.
auto.
eapply both_lower.
apply H11.
cut (is_ABR (Node _x0 _x1 _x2) None (Some x)).
intros.
inversion H12.
omega.
eapply max_limit.
inversion H.
eapply both_option_reduce.
apply H14.
auto.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H2.
inversion H.
inversion H4.
cut (x <= w).
omega.
eapply max_geq.
apply H2.
auto.
inversion H.
inversion H4.
apply combine.
eapply both_upper.
apply H10.
eapply left_loosen.
eapply both_lower.
apply H10.
eapply max_geq.
apply H2.
auto.
cut (x <= w).
omega.
eapply max_geq.
apply H2.
auto.
inversion H.
inversion H4.
apply H11.
inversion H.
inversion H4.
eapply both_upper.
apply H10.
inversion H.
inversion H4.
apply H11.
inversion H.
inversion H2.
apply H10.
inversion H.
inversion H2.
eapply both_lower.
apply H11.
inversion H.
eapply both_option_reduce.
apply H4.
eapply delete_right.
inversion H.
apply H2.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H2.
inversion H.
auto.
inversion H.
auto.
eapply delete_left.
inversion H.
auto.
apply IHa.
inversion H.
eapply both_option_reduce.
apply H4.
Qed.

Fixpoint delete_all (arbre : AB) (v : Z) {struct arbre} : AB :=
  let del_one := (delete arbre v) in
  if (search del_one v) then
  match del_one with
  | Empty => Empty
  | (Node x aL aR) => (delete_all del_one v)
end
  else del_one.

Fixpoint leftmost_value (v : Z) (aL : AB) : Z :=
  match aL with
  | Empty => v
  | (Node vL aLL aLR) => leftmost_value vL aLL
end.

Fixpoint delete_leftmost (arbre : AB) : AB :=
  match arbre with
  | Empty => Empty
  | (Node v aL aR) =>
    match aL with
    | Empty => aR
    | (Node vL aLL aLR) => (Node v (delete_leftmost aL) aR)
  end
end.

Fixpoint
delete (arbre : AB) (v : Z) : AB :=
  match arbre with
  | Empty => Empty
  | (Node w aL aR) =>
    let del_1 := match aL with
    | Empty =>
      match aR with
      | Empty =>
        if Z.eq_dec w v then Empty
        else arbre
      | (Node vR aRL aRR) =>
        if Z.eq_dec w v then aR
        else (Node w Empty (delete aR v))
    end
    | (Node vL aLL aLR) =>
      match aR with
      | Empty =>
        if Z.eq_dec w v then aL
        else (Node w (delete aL v) Empty)
      | (Node vR aRL aRR) =>
        if Z.eq_dec w v then (Node (leftmost_value vR aRL) aL (delete_leftmost aR) )
        else if Z_le_dec w v then (Node w (delete aL v) aR)
        else (Node w aL (delete aR v))
    end
  end
    in if (search del_1 v) then (delete del_1 v) else del_1
end.
Functional Scheme lval_ind := Induction for leftmost_value Sort Prop.
Functional Scheme ldel_ind := Induction for delete_leftmost Sort Prop.
Functional Scheme delete_ind := Induction for delete Sort Prop.

Lemma limit_inherit_left : forall (v : Z) (aL aR : AB) (L R : option Z), is_ABR (Node v aL aR) L R ->
    is_ABR aL L (Some v).
intros.
inversion H; assumption.
Qed.

Lemma delete_left : forall (vR : Z) (arbre : AB) (L R : option Z), is_ABR arbre L (Some vR) ->
    is_ABR (delete_leftmost arbre) L R -> is_ABR (delete_leftmost arbre) L (Some vR).
intros.
functional induction (delete_leftmost arbre) using ldel_ind; intros; apply_is_ABR.
inversion H; apply_is_ABR.
eapply limit_inherit_left.
rewrite H5.
apply H0.
rewrite H6.
eapply limit_inherit_left.
apply H0.
inversion H.
eapply both_upper.
apply H8.
eapply combine.
eapply both_upper.
apply H9.
eapply left_loosen.
eapply both_lower.
apply H9.
omega.
omega.
Qed.

Lemma left_delete_is_ABR : forall (arbre : AB) (L R : option Z), is_ABR arbre L R ->
    is_ABR (delete_leftmost arbre) L R.
intros.
functional induction (delete_leftmost arbre) using ldel_ind; intros; apply_is_ABR.
inversion H; apply_is_ABR.
eapply delete_left.
apply H5.
rewrite H2.
apply IHa.
rewrite <- H2.
rewrite <- H4.
eapply both_option_reduce.
apply H5.
eapply delete_left.
assumption.
rewrite H4.
apply IHa.
rewrite <- H4.
rewrite <- H5.
eapply both_lower.
apply H6.
eapply delete_left.
assumption.
rewrite H4.
apply IHa.
rewrite <- H4.
rewrite <- H5.
eapply right_loosen.
apply H6.
assumption.
eapply delete_left.
assumption.
rewrite H5.
apply IHa.
rewrite <- H5.
rewrite <- H6.
apply combine.
eapply right_loosen.
eapply both_upper.
apply H7.
assumption.
eapply both_lower.
apply H7.
omega.
inversion H.
eapply both_option_reduce.
apply H6.
eapply left_loosen.
apply H7.
omega.
eapply both_upper.
apply H7.
apply combine.
eapply both_upper.
apply H8.
eapply left_loosen.
eapply both_lower.
apply H8.
omega.
omega.
Qed.

Lemma leftmost_within_left : forall (v vL: Z) (aL aR : AB) (R : option Z), is_ABR (Node v aL aR) (Some vL) R ->
    vL < leftmost_value v aL .
intros.
functional induction (leftmost_value v aL) using lval_ind; intros.
apply IHz.
inversion H.
apply_is_ABR.
inversion H6.
assumption.
inversion H6.
assumption.
eapply left_loosen.
apply H7.
inversion H6.
assumption.
apply_is_ABR.
inversion H7.
assumption.
inversion H7.
omega.
inversion H7.
assumption.
apply combine.
eapply both_upper.
apply H8.
eapply left_loosen.
eapply both_lower.
apply H8.
inversion H7.
assumption.
inversion H7.
omega.
inversion H.
inversion H6.
omega.
inversion H7.
omega.
Qed.

Lemma limits_inequality : forall (v vL vR : Z) (aL aR : AB), is_ABR (Node v aL aR) (Some vL) (Some vR) -> vR > vL.
intros.
inversion H.
inversion H7.
inversion H8.
omega.
omega.
omega.
Qed.

Lemma leftmost_within_right : forall (v vR: Z) (aL aR : AB) (L : option Z), is_ABR (Node v aL aR) L (Some vR) ->
    vR >= leftmost_value v aL .
intros.
functional induction (leftmost_value v aL) using lval_ind; intros.
apply IHz.
inversion H.
inversion H6.
apply_is_ABR.
apply combine.
eapply both_upper.
apply H7.
eapply left_loosen.
eapply both_lower.
apply H7.
omega.
omega.
inversion H7.
apply_is_ABR.
apply combine.
eapply both_upper.
apply H8.
eapply left_loosen.
eapply both_lower.
apply H8.
omega.
omega.
inversion H.
omega.
omega.
Qed.

Lemma delete_is_ABR : forall (arbre : AB) (v : Z), is_ABR arbre None None ->
    is_ABR (delete arbre v) None None.
intros.
functional induction (delete arbre v) using delete_ind; intros; apply_is_ABR.
apply Z.lt_le_incl.
eapply leftmost_within_left.
inversion H.
inversion H2.
eapply left_loosen.
apply H4.
omega.
inversion H.
inversion H2.
auto.
inversion H.
inversion H2.
apply combine.
eapply right_loosen.
eapply both_upper.
apply H11.
apply Z.lt_le_incl.
eapply leftmost_within_left.
apply H4.
eapply both_lower.
apply H11.
apply Z.lt_le_incl.
eapply leftmost_within_left.
eapply left_loosen.
apply H4.
omega.
inversion H.
eapply left_delete_is_ABR.
apply_is_ABR.

Lemma delete_left_is_ABR :

Hypotheses:
H : is_ABR (Node w (Node _x _x0 _x1) (Node vR aRL _x2)) None None
e2 : Z.eq_dec w w = left eq_refl
v : Z
aL, aR : AB
H2 : is_ABR (Node _x _x0 _x1) None (Some w)
H4 : is_ABR (Node vR aRL _x2) (Some w) None
H0 : v = w
H1 : aL = Node _x _x0 _x1
H3 : aR = Node vR aRL _x2

Goal:
is_ABR (delete_leftmost (Node vR aRL _x2)) (Some (leftmost_value vR aRL)) None

Lemma left_swap : forall (v v1 v2 : Z) (arbre : AB) (L R : option Z), is_ABR arbre L R ->
    v2 < (leftmost_value v1 arbre) -> v2 < v1 -> v < v1 -> v < (leftmost_value v2 arbre).
intros.
functional induction (leftmost_value v2 arbre) using lval_ind; intros.
apply IHz.
inversion H.
eapply both_option_reduce.
apply H8.
eapply both_lower.
apply H9.
eapply right_loosen.
apply H9.
assumption.
eapply combine.
eapply right_loosen.
eapply both_upper.
apply H10.
assumption.
eapply both_lower.
apply H10.
omega.


(** * IndPrinciples: Induction Principles *)

(** With the Curry-Howard correspondence and its realization in Coq in
    mind, we can now take a deeper look at induction principles. *)

Require Export ProofObjects.

(* ################################################################# *)
(** * Basics *)

(** Every time we declare a new [Inductive] datatype, Coq
    automatically generates an _induction principle_ for this type.
    This induction principle is a theorem like any other: If [t] is
    defined inductively, the corresponding induction principle is
    called [t_ind].  Here is the one for natural numbers: *)

Check nat_ind.
(*  ===> nat_ind :
           forall P : nat -> Prop,
              P 0  ->
              (forall n : nat, P n -> P (S n))  ->
              forall n : nat, P n  *)

(** The [induction] tactic is a straightforward wrapper that, at its
    core, simply performs [apply t_ind].  To see this more clearly,
    let's experiment with directly using [apply nat_ind], instead of
    the [induction] tactic, to carry out some proofs.  Here, for
    example, is an alternate proof of a theorem that we saw in the
    [Basics] chapter. *)

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *) simpl. intros n' IHn'. rewrite -> IHn'.
    reflexivity.  Qed.

(** This proof is basically the same as the earlier one, but a
    few minor differences are worth noting.

    First, in the induction step of the proof (the ["S"] case), we
    have to do a little bookkeeping manually (the [intros]) that
    [induction] does automatically.

    Second, we do not introduce [n] into the context before applying
    [nat_ind] -- the conclusion of [nat_ind] is a quantified formula,
    and [apply] needs this conclusion to exactly match the shape of
    the goal state, including the quantifier.  By contrast, the
    [induction] tactic works either with a variable in the context or
    a quantified variable in the goal.

    These conveniences make [induction] nicer to use in practice than
    applying induction principles like [nat_ind] directly.  But it is
    important to realize that, modulo these bits of bookkeeping,
    applying [nat_ind] is what we are really doing. *)

(** **** Exercise: 2 stars, optional (plus_one_r')  *)
(** Complete this proof without using the [induction] tactic. *)

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Coq generates induction principles for every datatype defined with
    [Inductive], including those that aren't recursive.  Although of
    course we don't need induction to prove properties of
    non-recursive datatypes, the idea of an induction principle still
    makes sense for them: it gives a way to prove that a property
    holds for all values of the type.

    These generated principles follow a similar pattern. If we define
    a type [t] with constructors [c1] ... [cn], Coq generates a
    theorem with this shape:

    t_ind : forall P : t -> Prop,
              ... case for c1 ... ->
              ... case for c2 ... -> ...
              ... case for cn ... ->
              forall n : t, P n

    The specific shape of each case depends on the arguments to the
    corresponding constructor.  Before trying to write down a general
    rule, let's look at some more examples. First, an example where
    the constructors take no arguments: *)

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.
(* ===> yesno_ind : forall P : yesno -> Prop,
                      P yes  ->
                      P no  ->
                      forall y : yesno, P y *)

(** **** Exercise: 1 star, optional (rgb)  *)
(** Write out the induction principle that Coq will generate for the
    following datatype.  Write down your answer on paper or type it
    into a comment, and then compare it with what Coq prints. *)

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Check rgb_ind.
(** [] *)

(** Here's another example, this time with one of the constructors
    taking some arguments. *)

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.
(* ===> (modulo a little variable renaming)
   natlist_ind :
      forall P : natlist -> Prop,
         P nnil  ->
         (forall (n : nat) (l : natlist),
            P l -> P (ncons n l)) ->
         forall n : natlist, P n *)

(** **** Exercise: 1 star, optional (natlist1)  *)
(** Suppose we had written the above definition a little
   differently: *)

Inductive natlist1 : Type :=
  | nnil1 : natlist1
  | nsnoc1 : natlist1 -> nat -> natlist1.

(** Now what will the induction principle look like? *)
(** [] *)

(** From these examples, we can extract this general rule:

    - The type declaration gives several constructors; each
      corresponds to one clause of the induction principle.
    - Each constructor [c] takes argument types [a1] ... [an].
    - Each [ai] can be either [t] (the datatype we are defining) or
      some other type [s].
    - The corresponding case of the induction principle says:

        - "For all values [x1]...[xn] of types [a1]...[an], if [P]
          holds for each of the inductive arguments (each [xi] of type
          [t]), then [P] holds for [c x1 ... xn]".
*)

(** **** Exercise: 1 star, optional (byntree_ind)  *)
(** Write out the induction principle that Coq will generate for the
    following datatype.  (Again, write down your answer on paper or
    type it into a comment, and then compare it with what Coq
    prints.) *)

Inductive byntree : Type :=
 | bempty : byntree
 | bleaf  : yesno -> byntree
 | nbranch : yesno -> byntree -> byntree -> byntree.
(** [] *)

(** **** Exercise: 1 star, optional (ex_set)  *)
(** Here is an induction principle for an inductively defined
    set.

      ExSet_ind :
         forall P : ExSet -> Prop,
             (forall b : bool, P (con1 b)) ->
             (forall (n : nat) (e : ExSet), P e -> P (con2 n e)) ->
             forall e : ExSet, P e

    Give an [Inductive] definition of [ExSet]: *)

Inductive ExSet : Type :=
  (* FILL IN HERE *)
.
(** [] *)

(* ################################################################# *)
(** * Polymorphism *)

(** Next, what about polymorphic datatypes?

    The inductive definition of polymorphic lists

      Inductive list (X:Type) : Type :=
        | nil : list X
        | cons : X -> list X -> list X.

    is very similar to that of [natlist].  The main difference is
    that, here, the whole definition is _parameterized_ on a set [X]:
    that is, we are defining a _family_ of inductive types [list X],
    one for each [X].  (Note that, wherever [list] appears in the body
    of the declaration, it is always applied to the parameter [X].)
    The induction principle is likewise parameterized on [X]:

      list_ind :
        forall (X : Type) (P : list X -> Prop),
           P [] ->
           (forall (x : X) (l : list X), P l -> P (x :: l)) ->
           forall l : list X, P l

    Note that the _whole_ induction principle is parameterized on
    [X].  That is, [list_ind] can be thought of as a polymorphic
    function that, when applied to a type [X], gives us back an
    induction principle specialized to the type [list X]. *)

(** **** Exercise: 1 star, optional (tree)  *)
(** Write out the induction principle that Coq will generate for
   the following datatype.  Compare your answer with what Coq
   prints. *)

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.
Check tree_ind.
(** [] *)

(** **** Exercise: 1 star, optional (mytype)  *)
(** Find an inductive definition that gives rise to the
    following induction principle:

      mytype_ind :
        forall (X : Type) (P : mytype X -> Prop),
            (forall x : X, P (constr1 X x)) ->
            (forall n : nat, P (constr2 X n)) ->
            (forall m : mytype X, P m ->
               forall n : nat, P (constr3 X m n)) ->
            forall m : mytype X, P m
*)
(** [] *)

(** **** Exercise: 1 star, optional (foo)  *)
(** Find an inductive definition that gives rise to the
    following induction principle:

      foo_ind :
        forall (X Y : Type) (P : foo X Y -> Prop),
             (forall x : X, P (bar X Y x)) ->
             (forall y : Y, P (baz X Y y)) ->
             (forall f1 : nat -> foo X Y,
               (forall n : nat, P (f1 n)) -> P (quux X Y f1)) ->
             forall f2 : foo X Y, P f2
*)
(** [] *)

(** **** Exercise: 1 star, optional (foo')  *)
(** Consider the following inductive definition: *)

Inductive foo' (X:Type) : Type :=
  | C1 : list X -> foo' X -> foo' X
  | C2 : foo' X.

(** What induction principle will Coq generate for [foo']?  Fill
   in the blanks, then check your answer with Coq.)

     foo'_ind :
        forall (X : Type) (P : foo' X -> Prop),
              (forall (l : list X) (f : foo' X),
                    _______________________ ->
                    _______________________   ) ->
             ___________________________________________ ->
             forall f : foo' X, ________________________
*)

(** [] *)

(* ################################################################# *)
(** * Induction Hypotheses *)

(** Where does the phrase "induction hypothesis" fit into this story?

    The induction principle for numbers

       forall P : nat -> Prop,
            P 0  ->
            (forall n : nat, P n -> P (S n))  ->
            forall n : nat, P n

   is a generic statement that holds for all propositions
   [P] (or rather, strictly speaking, for all families of
   propositions [P] indexed by a number [n]).  Each time we
   use this principle, we are choosing [P] to be a particular
   expression of type [nat->Prop].

   We can make proofs by induction more explicit by giving
   this expression a name.  For example, instead of stating
   the theorem [mult_0_r] as "[forall n, n * 0 = 0]," we can
   write it as "[forall n, P_m0r n]", where [P_m0r] is defined
   as... *)

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

(** ... or equivalently: *)

Definition P_m0r' : nat->Prop :=
  fun n => n * 0 = 0.

(** Now it is easier to see where [P_m0r] appears in the proof. *)

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    (* Note the proof state at this point! *)
    intros n IHn.
    unfold P_m0r in IHn. unfold P_m0r. simpl. apply IHn. Qed.

(** This extra naming step isn't something that we do in
    normal proofs, but it is useful to do it explicitly for an example
    or two, because it allows us to see exactly what the induction
    hypothesis is.  If we prove [forall n, P_m0r n] by induction on
    [n] (using either [induction] or [apply nat_ind]), we see that the
    first subgoal requires us to prove [P_m0r 0] ("[P] holds for
    zero"), while the second subgoal requires us to prove [forall n',
    P_m0r n' -> P_m0r n' (S n')] (that is "[P] holds of [S n'] if it
    holds of [n']" or, more elegantly, "[P] is preserved by [S]").
    The _induction hypothesis_ is the premise of this latter
    implication -- the assumption that [P] holds of [n'], which we are
    allowed to use in proving that [P] holds for [S n']. *)

(* ################################################################# *)
(** * More on the [induction] Tactic *)

(** The [induction] tactic actually does even more low-level
    bookkeeping for us than we discussed above.

    Recall the informal statement of the induction principle for
    natural numbers:
      - If [P n] is some proposition involving a natural number n, and
        we want to show that P holds for _all_ numbers n, we can
        reason like this:
          - show that [P O] holds
          - show that, if [P n'] holds, then so does [P (S n')]
          - conclude that [P n] holds for all n.
    So, when we begin a proof with [intros n] and then [induction n],
    we are first telling Coq to consider a _particular_ [n] (by
    introducing it into the context) and then telling it to prove
    something about _all_ numbers (by using induction).

    What Coq actually does in this situation, internally, is to
    "re-generalize" the variable we perform induction on.  For
    example, in our original proof that [plus] is associative... *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* ...we first introduce all 3 variables into the context,
     which amounts to saying "Consider an arbitrary [n], [m], and
     [p]..." *)
  intros n m p.
  (* ...We now use the [induction] tactic to prove [P n] (that
     is, [n + (m + p) = (n + m) + p]) for _all_ [n],
     and hence also for the particular [n] that is in the context
     at the moment. *)
  induction n as [| n'].
  - (* n = O *) reflexivity.
  - (* n = S n' *)
    (* In the second subgoal generated by [induction] -- the
       "inductive step" -- we must prove that [P n'] implies
       [P (S n')] for all [n'].  The [induction] tactic
       automatically introduces [n'] and [P n'] into the context
       for us, leaving just [P (S n')] as the goal. *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** It also works to apply [induction] to a variable that is
    quantified in the goal. *)

Theorem plus_comm' : forall n m : nat,
  n + m = m + n.
Proof.
  induction n as [| n'].
  - (* n = O *) intros m. rewrite <- plus_n_O. reflexivity.
  - (* n = S n' *) intros m. simpl. rewrite -> IHn'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

(** Note that [induction n] leaves [m] still bound in the goal --
    i.e., what we are proving inductively is a statement beginning
    with [forall m].

    If we do [induction] on a variable that is quantified in the goal
    _after_ some other quantifiers, the [induction] tactic will
    automatically introduce the variables bound by these quantifiers
    into the context. *)

Theorem plus_comm'' : forall n m : nat,
  n + m = m + n.
Proof.
  (* Let's do induction on [m] this time, instead of [n]... *)
  induction m as [| m'].
  - (* m = O *) simpl. rewrite <- plus_n_O. reflexivity.
  - (* m = S m' *) simpl. rewrite <- IHm'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

(** **** Exercise: 1 star, optional (plus_explicit_prop)  *)
(** Rewrite both [plus_assoc'] and [plus_comm'] and their proofs in
    the same style as [mult_0_r''] above -- that is, for each theorem,
    give an explicit [Definition] of the proposition being proved by
    induction, and state the theorem and proof in terms of this
    defined proposition.  *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################# *)
(** * Induction Principles in [Prop] *)

(** Earlier, we looked in detail at the induction principles that Coq
    generates for inductively defined _sets_.  The induction
    principles for inductively defined _propositions_ like [ev] are a
    tiny bit more complicated.  As with all induction principles, we
    want to use the induction principle on [ev] to prove things by
    inductively considering the possible shapes that something in [ev]
    can have.  Intuitively speaking, however, what we want to prove
    are not statements about _evidence_ but statements about
    _numbers_: accordingly, we want an induction principle that lets
    us prove properties of numbers by induction on evidence.

    For example, from what we've said so far, you might expect the
    inductive definition of [ev]...

      Inductive ev : nat -> Prop :=
      | ev_0 : ev 0
      | ev_SS : forall n : nat, ev n -> ev (S (S n)).

    ...to give rise to an induction principle that looks like this...

    ev_ind_max : forall P : (forall n : nat, ev n -> Prop),
         P O ev_0 ->
         (forall (m : nat) (E : ev m),
            P m E ->
            P (S (S m)) (ev_SS m E)) ->
         forall (n : nat) (E : ev n),
         P n E

     ... because:

     - Since [ev] is indexed by a number [n] (every [ev] object [E] is
       a piece of evidence that some particular number [n] is even),
       the proposition [P] is parameterized by both [n] and [E] --
       that is, the induction principle can be used to prove
       assertions involving both an even number and the evidence that
       it is even.

     - Since there are two ways of giving evidence of evenness ([ev]
       has two constructors), applying the induction principle
       generates two subgoals:

         - We must prove that [P] holds for [O] and [ev_0].

         - We must prove that, whenever [n] is an even number and [E]
           is an evidence of its evenness, if [P] holds of [n] and
           [E], then it also holds of [S (S n)] and [ev_SS n E].

     - If these subgoals can be proved, then the induction principle
       tells us that [P] is true for _all_ even numbers [n] and
       evidence [E] of their evenness.

    This is more flexibility than we normally need or want: it is
    giving us a way to prove logical assertions where the assertion
    involves properties of some piece of _evidence_ of evenness, while
    all we really care about is proving properties of _numbers_ that
    are even -- we are interested in assertions about numbers, not
    about evidence.  It would therefore be more convenient to have an
    induction principle for proving propositions [P] that are
    parameterized just by [n] and whose conclusion establishes [P] for
    all even numbers [n]:

       forall P : nat -> Prop,
       ... ->
       forall n : nat,
       even n -> P n

    For this reason, Coq actually generates the following simplified
    induction principle for [ev]: *)

Check ev_ind.
(* ===> ev_ind
        : forall P : nat -> Prop,
          P 0 ->
          (forall n : nat, ev n -> P n -> P (S (S n))) ->
          forall n : nat,
          ev n -> P n *)

(** In particular, Coq has dropped the evidence term [E] as a
    parameter of the the proposition [P]. *)

(** In English, [ev_ind] says:

    - Suppose, [P] is a property of natural numbers (that is, [P n] is
      a [Prop] for every [n]).  To show that [P n] holds whenever [n]
      is even, it suffices to show:

      - [P] holds for [0],

      - for any [n], if [n] is even and [P] holds for [n], then [P]
        holds for [S (S n)]. *)

(** As expected, we can apply [ev_ind] directly instead of using
    [induction]. *)

Theorem ev_ev' : forall n, ev n -> ev' n.
Proof.
  apply ev_ind.
  - (* ev_0 *)
    apply ev'_0.
  - (* ev_SS *)
    intros m Hm IH.
    apply (ev'_sum 2 m).
    + apply ev'_2.
    + apply IH.
Qed.

(** The precise form of an [Inductive] definition can affect the
    induction principle Coq generates.

    For example, in chapter [IndProp], we defined [<=] as: *)

(* Inductive le : nat -> nat -> Prop :=
     | le_n : forall n, le n n
     | le_S : forall n m, (le n m) -> (le n (S m)). *)

(** This definition can be streamlined a little by observing that the
    left-hand argument [n] is the same everywhere in the definition,
    so we can actually make it a "general parameter" to the whole
    definition, rather than an argument to each constructor. *)

Inductive le (n:nat) : nat -> Prop :=
  | le_n : le n n
  | le_S : forall m, (le n m) -> (le n (S m)).

Notation "m <= n" := (le m n).

(** The second one is better, even though it looks less symmetric.
    Why?  Because it gives us a simpler induction principle. *)

Check le_ind.
(* ===>  forall (n : nat) (P : nat -> Prop),
           P n ->
           (forall m : nat, n <= m -> P m -> P (S m)) ->
           forall n0 : nat, n <= n0 -> P n0 *)

(* ################################################################# *)
(** * Formal vs. Informal Proofs by Induction *)

(** Question: What is the relation between a formal proof of a
    proposition [P] and an informal proof of the same proposition [P]?

    Answer: The latter should _teach_ the reader how to produce the
    former.

    Question: How much detail is needed??

    Unfortunately, there is no single right answer; rather, there is a
    range of choices.

    At one end of the spectrum, we can essentially give the reader the
    whole formal proof (i.e., the "informal" proof will amount to just
    transcribing the formal one into words).  This may give the reader
    the ability to reproduce the formal one for themselves, but it
    probably doesn't _teach_ them anything much.

   At the other end of the spectrum, we can say "The theorem is true
   and you can figure out why for yourself if you think about it hard
   enough."  This is also not a good teaching strategy, because often
   writing the proof requires one or more significant insights into
   the thing we're proving, and most readers will give up before they
   rediscover all the same insights as we did.

   In the middle is the golden mean -- a proof that includes all of
   the essential insights (saving the reader the hard work that we
   went through to find the proof in the first place) plus high-level
   suggestions for the more routine parts to save the reader from
   spending too much time reconstructing these (e.g., what the IH says
   and what must be shown in each case of an inductive proof), but not
   so much detail that the main ideas are obscured.

   Since we've spent much of this chapter looking "under the hood" at
   formal proofs by induction, now is a good moment to talk a little
   about _informal_ proofs by induction.

   In the real world of mathematical communication, written proofs
   range from extremely longwinded and pedantic to extremely brief and
   telegraphic.  Although the ideal is somewhere in between, while one
   is getting used to the style it is better to start out at the
   pedantic end.  Also, during the learning phase, it is probably
   helpful to have a clear standard to compare against.  With this in
   mind, we offer two templates -- one for proofs by induction over
   _data_ (i.e., where the thing we're doing induction on lives in
   [Type]) and one for proofs by induction over _evidence_ (i.e.,
   where the inductively defined thing lives in [Prop]). *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Set *)

(** _Template_:

       - _Theorem_: <Universally quantified proposition of the form
         "For all [n:S], [P(n)]," where [S] is some inductively defined
         set.>

         _Proof_: By induction on [n].

           <one case for each constructor [c] of [S]...>

           - Suppose [n = c a1 ... ak], where <...and here we state
             the IH for each of the [a]'s that has type [S], if any>.
             We must show <...and here we restate [P(c a1 ... ak)]>.

             <go on and prove [P(n)] to finish the case...>

           - <other cases similarly...>                        []

    _Example_:

      - _Theorem_: For all sets [X], lists [l : list X], and numbers
        [n], if [length l = n] then [index (S n) l = None].

        _Proof_: By induction on [l].

        - Suppose [l = []].  We must show, for all numbers [n],
          that, if [length [] = n], then [index (S n) [] =
          None].

          This follows immediately from the definition of [index].

        - Suppose [l = x :: l'] for some [x] and [l'], where
          [length l' = n'] implies [index (S n') l' = None], for
          any number [n'].  We must show, for all [n], that, if
          [length (x::l') = n] then [index (S n) (x::l') =
          None].

          Let [n] be a number with [length l = n].  Since

            length l = length (x::l') = S (length l'),

          it suffices to show that

            index (S (length l')) l' = None.

          But this follows directly from the induction hypothesis,
          picking [n'] to be [length l'].  [] *)

(* ================================================================= *)
(** ** Induction Over an Inductively Defined Proposition *)

(** Since inductively defined proof objects are often called
    "derivation trees," this form of proof is also known as _induction
    on derivations_.

    _Template_:

       - _Theorem_: <Proposition of the form "[Q -> P]," where [Q] is
         some inductively defined proposition (more generally,
         "For all [x] [y] [z], [Q x y z -> P x y z]")>

         _Proof_: By induction on a derivation of [Q].  <Or, more
         generally, "Suppose we are given [x], [y], and [z].  We
         show that [Q x y z] implies [P x y z], by induction on a
         derivation of [Q x y z]"...>

           <one case for each constructor [c] of [Q]...>

           - Suppose the final rule used to show [Q] is [c].  Then
             <...and here we state the types of all of the [a]'s
             together with any equalities that follow from the
             definition of the constructor and the IH for each of
             the [a]'s that has type [Q], if there are any>.  We must
             show <...and here we restate [P]>.

             <go on and prove [P] to finish the case...>

           - <other cases similarly...>                        []

    _Example_

       - _Theorem_: The [<=] relation is transitive -- i.e., for all
         numbers [n], [m], and [o], if [n <= m] and [m <= o], then
         [n <= o].

         _Proof_: By induction on a derivation of [m <= o].

           - Suppose the final rule used to show [m <= o] is
             [le_n]. Then [m = o] and we must show that [n <= m],
             which is immediate by hypothesis.

           - Suppose the final rule used to show [m <= o] is
             [le_S].  Then [o = S o'] for some [o'] with [m <= o'].
             We must show that [n <= S o'].
             By induction hypothesis, [n <= o'].

             But then, by [le_S], [n <= S o'].  [] *)

(** $Date: 2016-07-14 17:02:35 -0400 (Thu, 14 Jul 2016) $ *)


Require Import Coq.Arith.PeanoNat.
Require Import Lia.

Fixpoint x(n:nat) : nat :=
 match n with
 |0 => 0
 |S k => match k with
         |0 => 1 (*n = 1*)
         |1 => 1 (*n = 2*)
         |S j => (x k) + 2 * (x j)
         end
 end.

Lemma ch3div3_caseSS : forall j:nat, x (S (S (S j))) = (x (S (S j))) + (x (S j)) + (x (S j)).
intros.
unfold x.
progress fold x.
unfold "*".
remember (match j with
| 0 => 1
| S _ =>
    match j with
    | S (S _ as j0) => x j + (x j0 + (x j0 + 0))
    | _ => 1
    end + (x j + (x j + 0))
end ) as a.
remember (match j with
 | S (S _ as j0) => x j + (x j0 + (x j0 + 0))
 | _ => 1
 end) as b.
rewrite Nat.add_0_r.
rewrite Nat.add_assoc.
easy.
Defined.

Lemma ch3div3_lemma : forall n:nat, {a : nat & 3 * a = (x (3 * n))}.
intros.
destruct n.
exists 0; easy.
destruct n.
exists 1; easy.
induction n.
exists 7; easy.
destruct IHn as [a e].
simpl in *.
Search Nat.add.
repeat (try rewrite Nat.add_0_r in *;
        try rewrite plus_Sn_m in *;
        try rewrite <- plus_n_Sm in *).
repeat rewrite Nat.add_assoc in *.
remember (S (n + n + n)) as j.
progress repeat rewrite (ch3div3_caseSS) in *.
remember (x (S j)) as C.
remember (x (S (S j))) as D.
exists (10 * C + 11 * D + 2 * a).
simpl.
repeat rewrite Nat.add_assoc in *.
repeat (try rewrite Nat.add_0_r).
repeat rewrite (Nat.add_comm _ a).
progress repeat rewrite (Nat.add_assoc).
progress rewrite e.
progress repeat rewrite <- (Nat.add_assoc).
progress repeat apply Nat.add_cancel_l.
progress repeat rewrite (Nat.add_assoc).
progress rewrite e.
progress repeat rewrite <- (Nat.add_assoc).
progress repeat apply Nat.add_cancel_l.
progress repeat rewrite (Nat.add_assoc).
progress repeat apply Nat.add_cancel_r.
progress repeat rewrite <- (Nat.add_assoc).
progress repeat rewrite (Nat.add_comm C).
progress repeat rewrite <- (Nat.add_assoc).
progress repeat apply Nat.add_cancel_l.
trivial.
Defined.

Theorem ch3div3_1 : forall n:nat, {a : nat & 3 * a = n} -> {a : nat & 3 * a = (x n)}.
intros.
destruct H as [a ?e].
rewrite <- e.
destruct (ch3div3_lemma a) as [b ?e].
exists b.
apply e0.
Defined.

Theorem ch3div3_2 : forall n:nat, {a : nat & 3 * a = (x n)} -> {a : nat & 3 * a = n}.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type :=   Zero : natural | Succ : natural -> natural .

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut y a).
lfind.  reflexivity.
Admitted.

Theorem mult_eq_qmult : forall (x : natural) (y : natural), eq (mult x y) (qmult x y Zero).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. rewrite plus_qmult. reflexivity.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := mult (Succ y) (Succ x).


Set Printing Universes.
Set Universe Polymorphism.

(*The inductive type of formulae. Note that if All or Ex quantifies over a type in a universe, then the resulting form is in a strictly higher universe. Note also that the definition is universe-polymorphic, thus the All and Ex constructors of a form at a higher level can quantify over a form at a lower level*)
Inductive form :=
| Tr : form (*true/⊤*)
| Fa : form (*absurd*)
| And : form -> form -> form (*conjunction*)
| Or : form -> form -> form (*disjunction*)
| Impl : form -> form -> form (*implication*)
| All : forall {A : Type}, (A -> form) -> form (*Universal quantifier*)
| Ex : forall {A : Type}, (A -> form) -> form (*Existential quantifier*)
| Atom : Prop -> form. (*Atomic propositions*)

Notation "f ⇒ g" := (Impl f g)
                     (at level 99, right associativity).

(*---------------------------------*)
(*Contexts --- are represented by terms L:form → Prop*)

(*Empty context*)
Definition Ø (f:form) := False.

(*Context extension*)
Definition L_ext : (form -> Prop) -> form -> form -> Prop :=
  fun L f g => (L g) \/ (g = f).
Notation "L ⋯ f" := (L_ext L f) (at level 99).

(*One might be tempted instead to make the following definition of "removing a hypothesis from a context". However, since contexts are not interpreted as lists but as (sub)sets/classes of formulae specified/separated by a predicate, and not as lists or multisets, the only sense to removing a formulae from a context is that of discarding *all* occurrences of the formula from the context. This is unwise --- for instance, it seems to me as though defining inference rules so that weakening is admissible becomes tricky, especially in the case of the introduction of the implication.

Definition L_rm : (form -> Prop) -> form -> form -> Prop :=
  fun L A B => (L B) /\ (~ B = A).*)

(*--------------------------------*)
(*Derivations/Judgements*)

(*Question 1.1.1*)
(*The inductive family of derivations, indexed over contexts and formulae, and valued in Prop. We choose to place ourselves in Natural Deduction.*)
Inductive deriv : (form -> Prop) -> form -> Prop :=
| ax     : forall (L:_ -> Prop) f,
             L f -> deriv L f
| Tr_i   : forall L, deriv L Tr
| Fa_e   : forall L f, deriv L Fa -> deriv L f
| imp_i  : forall L f g,
             deriv (L⋯f) g -> deriv L (Impl f g)
| imp_e  : forall L f g,
             deriv L (Impl f g) -> deriv L f -> deriv L g
| and_i  : forall L f g,
             deriv L f -> deriv L g -> deriv L (And f g)
| and_e1 : forall L f g,
             deriv L (And f g) -> deriv L f
| and_e2 : forall L f g,
             deriv L (And f g) -> deriv L g
| or_i1  : forall L f g,
             deriv L f -> deriv L (Or f g)
| or_i2  : forall L f g,
             deriv L g -> deriv L (Or f g)
| or_e   : forall L f g h,
             deriv L (Or f g) -> deriv (L⋯f) h -> deriv (L⋯g) h -> deriv L h
| ex_i   : forall L {A:Type} (P:A -> form) t,
             deriv L (P t) -> deriv L (Ex P)
| ex_e   : forall L {A:Type} (P:A -> form) f,
             (forall t, deriv (L⋯P t) f) -> (deriv L (Ex P)) -> deriv L f
(*Note the side condition that the standard formulaion of the rule above requires, namely that neither L nor f contain t as a free variable. This is guaranteed by explicitly binding L and f — the forall in the Coq lambda-term/the meta-term — above the binder for t, thus t is neither free in nor can be captured by any substitution for L or f. Note also that this meta-binding inside the scope of L and f is *precisely* what we mean when we say that the term-variable in the auxiliary premiss of the ∃-elim rule is free neither in the rest of the context nor in the conclusion.*)

| all_i  : forall L {A:Type} (P:A -> form),
             (forall t, deriv L (P t)) -> deriv L (All P)
(*same remark for the side condition in the rule above*)

| all_e  : forall L {A:Type} (P:A -> form),
             deriv L (All P) -> forall t, deriv L (P t).
Notation "L ⊢ f" := (deriv L f) (at level 99).

(* ---------------------------------------------  *)
(*The admissible inference rules*)

(*Weakening*)
Lemma deriv_weakening_strong (L : form -> Prop) f {H:L ⊢ f} :
  forall L':_-> Prop,
    (forall f, L f -> L' f) ->
    L' ⊢ f.
Proof.
  induction H; intros.
  - apply ax, H0, H.
  - apply Tr_i.
  - apply Fa_e, IHderiv, H0.
  - apply imp_i, IHderiv. intros.
    case H1.
    + intro; left; apply H0. assumption.
    + intro; right; assumption.
  - apply (imp_e _ f g). apply IHderiv1, H1.
    apply IHderiv2, H1.
  - apply and_i.
    + apply IHderiv1, H1.
    + apply IHderiv2, H1.
  - apply (and_e1 _ _ g), IHderiv, H0.
  - apply (and_e2 _ f _), IHderiv, H0.
  - apply or_i1, IHderiv, H0.
  - apply or_i2, IHderiv, H0.
  - apply (or_e _ f g).
    + apply IHderiv1, H2.
    + apply IHderiv2. intros. case H3.
      * intro; left; apply H2; assumption.
      * intro; right; assumption.
    + apply IHderiv3; intros; case H3.
      * intro; left; apply H2; assumption.
      * intro; right; assumption.
  - apply (ex_i _ _ t), IHderiv, H0.
  - apply (ex_e _ P f). intro t1. apply (H0 t1).
    intros. case H3.
    + intro; left; apply H2; assumption.
    + intro; right; assumption.
    + apply IHderiv. assumption.
  - apply all_i. intro; apply H0, H1.
  - apply all_e, IHderiv, H0.
Defined.

(*Question 1.2.1*)
(*A logically equivalent statement, but where the induction tactic does not
produce strong enough hypotheses for the proof to go through*)
Lemma deriv_weakening (L L' : form -> Prop) f :
  L ⊢ f ->
  (forall f, L f -> L' f) ->
  L' ⊢ f.
Proof.
  intros; apply (deriv_weakening_strong L); assumption.
Defined.

(*The usual form of the weakening rule*)
Lemma wkn (L : form -> Prop) g f :
  L ⊢ f -> (L⋯g) ⊢ f.
Proof.
  intro; apply (deriv_weakening L (L⋯_)).
  - assumption.
  - intros; left; assumption.
Defined.

(*Substitution/Cut/Context morphisms*)

(*A statement phrased in a way to let Coq's induction tactic go through*)
Lemma deriv_substitution_strong (L : form -> Prop) f :
  deriv L f ->
  forall L', (forall f, L f -> deriv L' f) ->
        deriv L' f.
Proof.
  intros H; induction H; intros.
  - apply H0, H.
  - apply Tr_i.
  - apply Fa_e, IHderiv, H0.
  - apply imp_i, IHderiv.
    intros. case H1.
    + intro; apply wkn.
      apply H0, H2.
    + intro; apply ax; right; assumption.
  - apply (imp_e _ f g). apply IHderiv1, H1.
    apply IHderiv2, H1.
  - apply and_i.
    + apply IHderiv1, H1.
    + apply IHderiv2, H1.
  - apply (and_e1 _ _ g), IHderiv, H0.
  - apply (and_e2 _ f _), IHderiv, H0.
  - apply or_i1, IHderiv, H0.
  - apply or_i2, IHderiv, H0.
  - apply (or_e _ f g).
    + apply IHderiv1, H2.
    + apply IHderiv2; intros; case H3.
      * intro; apply wkn, H2, H4.
      * intro; apply ax; right; assumption.
    + apply IHderiv3. intros; case H3.
      * intro; apply wkn, H2, H4.
      * intro; apply ax; right; assumption.
  - apply (ex_i _ _ t), IHderiv, H0.
  - apply (ex_e _ P f). intro t1; apply (H0 t1).
    intros; case H3.
    + intro; apply wkn, H2; assumption.
    + intro. apply ax; right; assumption.
    + apply IHderiv. assumption.
  - apply all_i. intro; apply H0, H1.
  - apply all_e, IHderiv, H0.
Defined.

(*Question 1.2.2*)
(*A statement equivalent to the one above*)
Lemma deriv_substitution (L L' : form -> Prop) f :
  deriv L f ->
  (forall f, L f -> deriv L' f) ->
  deriv L' f.
Proof.
  intros.
  apply (deriv_substitution_strong L); assumption.
Defined.

(*Fin*)


Require Import Arith.
Section strong_induction.

Theorem induction1:
 forall P : nat -> Prop,
 (forall n : nat,
    (forall k : nat, (k < n -> P k)) -> (forall k : nat, (k <= n -> P k)))
 -> (forall n : nat, (forall k : nat, (k <= n -> P k))).

Proof.

induction n.
intro.
apply H.
intro.
intro.

unfold lt in H0.
inversion H0.

apply H.
intro.
intro.
apply IHn.

unfold lt in H0.
apply le_S_n in H0.
assumption.

Qed.

Theorem strong_induction:
 forall P : nat -> Prop,
 (forall n : nat,
   (forall k : nat, (k < n -> P k)) -> P n)
 -> (forall n : nat, P n).

Proof.

intro.
intro.

assert ( forall n:nat, (forall k:nat, k < n -> P k) ->
                       (forall k:nat, k <= n -> P k) ).
intro.
intro.
intro.
intro.

inversion H1.
apply H.
assumption.

apply H0.
rewrite <- H3.
unfold lt.
apply le_n_S.
assumption.

assert( forall n : nat, (forall k : nat, (k <= n -> P k)) ).

apply induction1.
assumption.

intro.

assert (forall k:nat, k <= n -> P k).
apply H1.

apply H2.

constructor.

Qed.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

Set Implicit Arguments.

Require Import Setoid.
Require Import Relations.
Require Import List.
Require Import Wellfounded.
Require Export TransClosure.

Lemma acc_trans :
 forall A (R : relation A) a, Acc R a -> Acc (trans_clos R) a.
Proof.
intros A R a Acc_R_a.
induction Acc_R_a as [a Acc_R_a IH].
apply Acc_intro.
intros b b_Rp_a; induction b_Rp_a.
apply IH; trivial.
apply Acc_inv with y.
apply IHb_Rp_a; trivial.
apply t_step; trivial.
Defined.

Lemma wf_trans :
  forall A (R : relation A) , well_founded R -> well_founded (trans_clos R).
Proof.
unfold well_founded; intros A R WR.
intro; apply acc_trans; apply WR; trivial.
Defined.

Lemma trans_incl :
  forall A (R1 R2 : relation A), inclusion _ R1 R2 -> inclusion _ (trans_clos R1) (trans_clos R2).
Proof.
intros A R1 R2 R1_in_R2 a b H; induction H as [a' b' H | a' b' c' H1 H2].
apply t_step; apply R1_in_R2; trivial.
apply t_trans with b'; trivial.
apply R1_in_R2; trivial.
Qed.

Lemma refl_trans_incl :
  forall A (R1 R2 : relation A), inclusion _ R1 R2 -> inclusion _ (refl_trans_clos R1) (refl_trans_clos R2).
Proof.
intros A R1 R2 R1_in_R2 a b [a' | a' b' H].
left.
apply t_clos; apply trans_incl with R1; assumption.
Qed.

Lemma trans_incl2 :
  forall A B (f : A -> B) (R1 : relation A) (R2 : relation B),
  (forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2)) ->
	forall a1 a2, trans_clos R1 a1 a2 ->  trans_clos R2 (f a1) (f a2).
Proof.
intros A B f R1 R2 R1_in_R2 a b H; induction H as [a' b' H | a' b' c' H1 H2].
apply t_step; apply R1_in_R2; trivial.
apply t_trans with (f b'); trivial.
apply R1_in_R2; trivial.
Qed.

Lemma trans_with_eq :
  forall A (R : relation A) a1 a2,
  trans_clos (union A (@eq _) R) a1 a2 <-> refl_trans_clos R a1 a2.
Proof.
intros A R a1 a2; split.
intro H; induction H as [b1 b2 H | b1 b2 b3 H1 H2].
destruct H as [H | H].
subst b2; apply r_step; assumption.
apply t_clos; apply t_step; assumption.
destruct H1 as [H1 | H1].
subst b2; assumption.
destruct IHH2 as [b2 H3 | b2 b3 H3].
apply t_clos; apply t_step; assumption.
apply t_clos; apply t_trans with b2; assumption.

intro H; destruct H as [a1 H | a1 a2 H].
apply t_step; left; apply refl_equal.
apply (@trans_incl _ R); trivial.
right; assumption.
Qed.

Lemma acc_star :
   forall A (R : relation A) a, Acc R a -> forall b,  refl_trans_clos  R b a -> Acc R b.
Proof.
intros A R a Acc_a b H; destruct H as [a1 H | a1 a2 H].
assumption.
apply Acc_incl with (trans_clos R).
intros b1 b2 H'; apply t_step; assumption.
apply Acc_inv with a2; trivial.
apply acc_trans; trivial.
Qed.

Inductive compose_rel A (R1 R2 : relation A) : relation A :=
  Comp : forall a1 a2 a3, R1 a1 a2 -> R2 a2 a3 -> compose_rel R1 R2 a1 a3.

Section Compose.
Variable A : Type.
Variable R1 : relation A.
Variable R2 : relation A.

Lemma trans_union :
  forall a b,
  trans_clos (union _ R1 R2) a b <->
  union _ (trans_clos R1)
            (compose_rel (refl_trans_clos R1) (trans_clos (compose_rel R2 (refl_trans_clos R1)))) a b.
Proof.
intros a b; split.
(* 1/2 -> *)
intro H; induction H as [x y H1 | x y z H1 Hn].
destruct H1 as [H1 | H1].
left; apply t_step; assumption.
right; apply Comp with x.
apply r_step.
apply t_step.
apply Comp with y; trivial.
apply r_step.
destruct H1 as [H1 | H2]; destruct IHHn as [IHHn | IHHn].
left; apply t_trans with y; trivial.
right; inversion IHHn as [x' y' z' K1 K2]; subst x' z'; clear IHHn.
apply Comp with y'.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_clos; apply t_step; trivial.
subst y1 y2; apply t_clos; apply t_trans with y; trivial.
trivial.
right.
apply Comp with x.
apply r_step.
apply t_step; apply Comp with y; trivial.
apply t_clos; trivial.
right; inversion IHHn as [x' y' z' K1 K2]; subst x' z'; clear IHHn.
apply Comp with x.
apply r_step.
apply t_trans with y'; trivial.
apply Comp with y; trivial.
(* 1/1 <- *)
intros [H | H].
apply trans_incl with R1; trivial.
intros; left; trivial.
inversion H as [x' y' z' K1 K2]; clear H; subst x' z'.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel R2 (refl_trans_clos R1)); trivial.
clear a b K2; intros a b K2.
inversion K2 as [x' y' z' K1 K2']; clear K2; subst x' z'.
inversion K2' as [y1 | y1 y2 K2'']; clear K2'.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply t_trans with y'.
right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel R2 (refl_trans_clos R1)); trivial.
clear a b y' K1' K2; intros a b K2.
inversion K2 as [x' y' z' K1 K2']; clear K2; subst x' z'.
inversion K2' as [y1 | y1 y2 K2'']; clear K2'.
subst y' y1.
left; right; trivial.
subst y1 y2.
right with y'.
right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
Qed.

Lemma trans_union_alt :
  forall a b,
  trans_clos (union _ R1 R2) a b <->
  union _ (trans_clos R1)
             (compose_rel (trans_clos (compose_rel (refl_trans_clos R1) R2))
                                  (refl_trans_clos R1)) a b.
Proof.
intros a b; split.
(* 1/2 -> *)
rewrite trans_clos_trans_clos_alt in *; intro H; induction H as [x y H1 | x y z H1 IHH1 Hn].
(* 1/3 one step *)
destruct H1 as [H1 | H1].
left; left; assumption.
right; apply Comp with y.
left; apply Comp with x; trivial.
left.
left.
(* 1/2 several steps *)
destruct IHH1 as [IHH1 | IHH1]; destruct Hn as [Hn | Hn].
(* 1/5 *)
left; rewrite trans_clos_trans_clos_alt in *; right with y; trivial.
(* 1/4 *)
right; apply Comp with z.
left; apply Comp with y; trivial.
right; trivial.
left.
(* 1/3 *)
inversion IHH1 as [x' y' z' K1 K2]; subst x' z'; clear IHH1.
right; apply Comp with y'; trivial.
inversion K2 as [y'' | a a' K2' K2''].
subst y' y''.
right; left; trivial.
subst a a'; right; apply trans_clos_is_trans with y; trivial.
left; trivial.
(* 1/2 *)
inversion IHH1 as [x' y' z' K1 K2]; subst x' z'; clear IHH1.
right.
apply Comp with z.
apply trans_clos_is_trans with y'; trivial.
left; apply Comp with y; trivial.
left.
(* 1/1 <- *)
intros [H | H].
apply trans_incl with R1; trivial.
intros; left; trivial.
inversion H as [x' y' z' K1 K2]; clear H; subst x' z'.
inversion K2 as [y1 | y1 y2 K2']; clear K2.
subst y1 y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel (refl_trans_clos R1) R2); trivial.
clear a b K1; intros a b H.
inversion H as [x' y' z' K1 K2]; subst x' z'; clear H.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
left; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_clos_is_clos.
apply trans_incl with (compose_rel (refl_trans_clos R1) R2); trivial.
clear a b y' K1 K2'; intros a b H.
inversion H as [x' y' z' K1 K2]; subst x' z'; clear H.
inversion K1 as [y1 | y1 y2 K1']; clear K1.
subst y1 y'; apply t_step; right; trivial.
subst y1 y2.
apply trans_clos_is_trans with y'.
apply trans_incl with R1; trivial.
intros; left; trivial.
left; right; trivial.
apply trans_incl with R1; trivial.
intros; left; trivial.
Qed.

Lemma acc_union :
  well_founded R1 ->
  forall a, Acc (compose_rel R2 (refl_trans_clos R1)) a <-> Acc (union _ R1 R2) a.
Proof.
intros W1'.
assert (W1 := wf_trans W1'); clear W1'.
intros a; split.
intro Acc_a; induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
revert IH2 Acc_a.
pattern a; apply (well_founded_ind W1); clear a.
intros a IH1 IH2 Acc_a.
apply Acc_intro.
intros b [H1 | H2].
apply IH1.
apply t_step; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Acc_intro; intros c H2.
apply Acc_inv with a; trivial.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply IH2.
apply Comp with a; trivial.
apply r_step.

intro Acc_a; apply Acc_incl with (trans_clos (union _ R1 R2)).
intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H2 as [b | a2 a3 K2]; clear H2; subst.
left; right; assumption.
apply t_trans with b2.
right; assumption.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
apply acc_trans; assumption.
Qed.

Lemma acc_union_weak :
  forall a, Acc (compose_rel R2 (refl_trans_clos R1)) a ->
              (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
              Acc (union _ R1 R2) a.
Proof.
intros a Acc_a H;
induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
assert (Acc1_a : Acc R1 a).
apply H; left.
revert IH2 H Acc_a.
induction Acc1_a as [a Acc1_a IH1].
intros IH2 H Acc_a.
apply Acc_intro.
intros b [H1 | H2].
apply IH1; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' h H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
intros c K; inversion K; clear K; subst.
apply Acc1_a; assumption.
apply H.
rewrite trans_clos_trans_clos_alt in H0.
inversion H0; clear H0; subst.
right; left.
inversion H2; clear H2; subst.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.
inversion H3; clear H3; subst.
apply refl_trans_clos_is_trans with y; trivial.
right; rewrite trans_clos_trans_clos_alt; assumption.
right; left.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.
apply Acc_intro; intros c K.
apply Acc_inv with a; trivial.
inversion K; clear K; subst.
apply Comp with a2; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; exact H1.

apply IH2.
apply Comp with a; [assumption | left].
intros c K; apply H.
apply refl_trans_clos_is_trans with b; trivial.
right; left; apply Comp with a; [assumption | left].
Qed.

Lemma acc_union_alt :
  well_founded R1 ->
  forall a, (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) <-> Acc (union _ R1 R2) a.
Proof.
intros W1'; split.
intro Ha; apply acc_union_weak; trivial.
apply Acc_intro; intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
assert (Acc_b2 := Ha b2 H21).
revert a Ha b4 H' H21; induction Acc_b2 as [b2 Acc_b2 IH].
intros a Ha b4 H' H21.
apply Acc_intro.
intros b6 H.
inversion H as [a6 b5 a4 H65 H54]; clear H; subst.
apply IH with b5 b4; trivial.
apply Comp with b4; trivial.
intros b7 H7.
apply Acc_b2.
apply Comp with b4; trivial.

intros Acc_a b H; apply Acc_incl with (trans_clos (union _ R1 R2)).
clear b H; intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H1 as [b | a2 a3 K1]; clear H1; subst.
left; right; assumption.
apply trans_clos_is_trans with b2.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
left; right; assumption.
inversion H as [a' | b' a' K]; clear H.
apply acc_trans; assumption.
subst; apply Acc_inv with a.
apply acc_trans; assumption.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
Qed.

Lemma acc_union_alt_weak :
  forall a, (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
               (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) ->
              Acc (union _ R1 R2) a.
Proof.
intros a H1a H2a.
apply acc_union_weak; trivial.
clear H1a.
apply Acc_intro; intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
assert (Acc_b2 := H2a b2 H21).
revert a H2a b4 H' H21; induction Acc_b2 as [b2 Acc_b2 IH].
intros a Ha b4 H' H21.
apply Acc_intro.
intros b6 H.
inversion H as [a6 b5 a4 H65 H54]; clear H; subst.
apply IH with b5 b4; trivial.
apply Comp with b4; trivial.
intros b7 H7.
apply Acc_b2.
apply Comp with b4; trivial.
Qed.

Lemma wf_union_alt :
  well_founded R1 ->
  (well_founded (compose_rel (refl_trans_clos R1) R2) <-> well_founded (union _ R1 R2)).
Proof.
intros W1'; split.
intro W; intro a; rewrite <- acc_union; trivial.
assert (W1 := wf_trans W1'); clear W1'.
apply Acc_intro.
intros b4 H.
inversion H as [a4 b2 a1 H' H21]; clear H; subst.
clear a H21.
revert b4 H'.
pattern b2; apply (well_founded_ind (wf_trans W)); clear b2.
intros a IH b H.
apply Acc_intro; intros c K.
inversion K as [d' c' b' H1 H2];clear K; subst.
apply IH with c'; trivial.
left; apply Comp with b; trivial.

intros W a; apply Acc_incl with (trans_clos (union _ R1 R2)).
intros a1 a3 H; inversion H as [b1 b2 b3 H1 H2]; clear H; subst a1 a3.
inversion H1 as [b | a2 a3 K1]; clear H1; subst.
left; right; assumption.
apply trans_clos_is_trans with b2.
apply trans_incl with R1; trivial.
intros x y H; left; assumption.
left; right; assumption.
apply acc_trans; apply W.
Qed.

Lemma acc_comp_incl :
  forall R, (forall a, Acc R a -> Acc (union _ R1 R2) a) ->
  forall a, Acc R a -> Acc (compose_rel (refl_trans_clos R1) R2) a.
Proof.
intros R H a Acc_a.
apply Acc_incl with (trans_clos (union _ R1 R2)).
clear; intros a b H.
inversion H as [c1 c2 c3 K1 K2]; clear H; subst.
inversion K1 as [c | b1 b2 K3 K4]; clear K1; subst.
left; right; assumption.
apply trans_clos_is_trans with c2.
apply trans_incl with R1; trivial.
clear; intros a b H; left; assumption.
left; right; assumption.
apply acc_trans.
apply H; assumption.
Qed.

End Compose.

Definition rest A P R := fun (a b : A) => R a b /\ P a /\ P b.

Lemma rest_union : forall A P (R1 R2 : relation A) a b, rest P (union _ R1 R2) a b <-> union _ (rest P R1) (rest P R2) a b.
intros A P R1 R2 a b; split.
intros [[H1 | H2] [Pa Pb]]; [left | right]; repeat split; assumption.
intros [[H1 [Pa Pb]] | [H2 [Pa Pb]]]; repeat split; trivial.
left; assumption.
right; assumption.
Qed.

Lemma rest_trans :
   forall A (P : A -> Prop) (R : relation A), (forall a b, P a -> R b a -> P b) ->
	forall a, P a -> forall b, trans_clos (rest P R) b a <-> trans_clos R b a.
Proof.
intros A P R Inv a Pa b; split.
apply trans_incl; intros x y [H _]; assumption.
intro H; rewrite trans_clos_trans_clos_alt in H; rewrite trans_clos_trans_clos_alt.
induction H as [x y K | x y z K1 K2].
left; repeat split; trivial.
apply Inv with y; assumption.
assert (Py := Inv _ _ Pa H).
right with y.
exact (K2 Py).
repeat split; assumption.
Qed.

Lemma acc_rest :
  forall A (R : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R b a -> P b) ->
  (forall a, (P a -> Acc R a) <-> Acc (rest P R) a).
Proof.
intros A R P Inv a; split.
intro K; apply Acc_intro; intros b [H [Wb Wa]].
apply Acc_inv with a; trivial.
apply Acc_incl with R.
clear; intros a b [H _]; assumption.
apply K; assumption.
repeat split; assumption.
intro Acc_a; induction Acc_a as [a Acc_a IH].
intro Pa; apply Acc_intro; intros b H.
apply IH.
repeat split; trivial.
apply Inv with a; assumption.
apply Inv with a; assumption.
Qed.

Lemma wf_rest :
  forall A (R : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R b a -> P b) ->
  ((forall a, P a -> Acc R a) <->  well_founded (rest P R)).
Proof.
intros A R P Inv; split.
intros W a; rewrite <- acc_rest; trivial.
apply W.
intros W a; rewrite acc_rest; trivial.
Qed.

Lemma acc_union_rest :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  (forall a, P a -> Acc R1 a) ->
  forall a, P a -> Acc (compose_rel R2 (refl_trans_clos R1)) a -> Acc (union _ R1 R2) a.
Proof.
intros A R1 R2 P Inv1 Inv2 W1' a Wa Acc_a.
rewrite wf_rest in W1'.
set (R1' := fun a b => R1 a b /\ P a /\ P b) in *.
assert (W1 := wf_trans W1'); clear W1'.
revert Wa; induction Acc_a as [a Acc_a' IH2].
assert (Acc_a : Acc (compose_rel R2 (refl_trans_clos R1)) a).
apply Acc_intro; trivial.
clear Acc_a'.
revert IH2 Acc_a.
pattern a; apply (well_founded_ind W1); clear a.
intros a IH1 IH2 Acc_a Wa.
apply Acc_intro.
intros b [H1 | H2].
apply IH1.
apply t_step; repeat split; trivial.
apply Inv1 with a; trivial.
intros c H2; apply IH2.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Acc_intro; intros c H2.
apply Acc_inv with a; trivial.
inversion H2 as [c' d' b' H H']; subst.
apply Comp with d'; trivial.
apply refl_trans_clos_is_trans with b; trivial.
right; left; trivial.
apply Inv1 with a; trivial.
apply IH2.
apply Comp with a; trivial.
apply r_step.
apply Inv2 with a; trivial.
trivial.
Qed.

Lemma acc_union_rest_alt :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  (forall a, P a -> Acc R1 a) ->
  (forall a, (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) -> P a -> Acc (union _ R1 R2) a).
Proof.
intros A R1 R2 P Inv1 Inv2 W1' a W Pa.
assert (H : Acc (union _ (rest P R1) (rest P R2)) a).
rewrite <- acc_union_alt.
intros b H; apply Acc_incl with (compose_rel (refl_trans_clos R1) R2).
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 [H2 _]]; subst.
apply Comp with a; [idtac | assumption].
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
apply W.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
rewrite wf_rest in W1'; assumption.
clear W; revert Pa; induction H as [a Acc_a IH].
intro Pa; apply Acc_intro; intros a1 [H1 | H2]; apply IH.
left; repeat split; trivial.
apply Inv1 with a; assumption.
apply Inv1 with a; assumption.
right; repeat split; trivial.
apply Inv2 with a; assumption.
apply Inv2 with a; assumption.
Qed.

Lemma acc_union_rest_alt_weak :
  forall A (R1 R2 : relation A) (P : A -> Prop),
  (forall (a b : A), P a -> R1 b a -> P b) ->
  (forall (a b : A), P a -> R2 b a -> P b) ->
  forall a, (forall b, refl_trans_clos (compose_rel R2 (refl_trans_clos R1)) b a -> Acc R1 b) ->
               (forall b, refl_trans_clos R1 b a -> Acc (compose_rel (refl_trans_clos R1) R2) b) ->
               P a -> Acc (union _ R1 R2) a.
Proof.
intros A R1 R2 P Inv1 Inv2 a H1a H2a Pa.
assert (H : Acc (union _ (rest P R1) (rest P R2)) a).
apply acc_union_alt_weak.
intros b H; apply Acc_incl with R1.
clear; intros a1 a2 [H _]; assumption.
apply H1a.
apply refl_trans_incl with (compose_rel (rest P R2) (refl_trans_clos (rest P R1))); trivial.
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 H2]; subst.
apply Comp with a.
inversion H1; trivial.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.

intros b H; apply Acc_incl with (compose_rel (refl_trans_clos R1) R2).
clear; intros a1 a2 H; inversion H as [c1 a c2 H1 [H2 _]]; subst.
apply Comp with a; [idtac | assumption].
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
apply H2a.
apply refl_trans_incl with (rest P R1); [idtac | assumption].
clear; intros a1 a2 [H _]; assumption.
clear H1a H2a; revert Pa; induction H as [a Acc_a IH].
intro Pa; apply Acc_intro; intros a1 [H1 | H2]; apply IH.
left; repeat split; trivial.
apply Inv1 with a; assumption.
apply Inv1 with a; assumption.
right; repeat split; trivial.
apply Inv2 with a; assumption.
apply Inv2 with a; assumption.
Qed.

Lemma accR2 : forall A (R : relation A) a, Acc R a <-> Acc (compose_rel R R) a.
Proof.
intros A R a; split.
intro Acc_a; apply Acc_incl with (trans_clos R).
intros x z H; inversion H as [x' y z' H1 H2]; clear H; subst; apply t_trans with y; trivial.
apply t_step; trivial.
apply acc_trans; trivial.
intros Acc_a; induction Acc_a as [a Acc_a IH].
apply Acc_intro; intros b H; apply Acc_intro; intros c H'.
apply IH; apply Comp with b; trivial.
Qed.

Lemma acc_inv_im :
	forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
	(forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2)) ->
	forall a, Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f H a.
set (b := f a) in *.
assert (b_eq_fa := refl_equal b).
unfold b at 2 in b_eq_fa; clearbody b.
intro Acc_b; revert a b_eq_fa; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa; apply Acc_intro; intros a' H'.
apply IH with (f a'); trivial.
subst b; apply H; trivial.
Qed.

Lemma acc_inv_im2 :
   forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
  forall a, (forall a1 a2 a3, R1 a3 a2 -> R1 a2 a1 -> refl_trans_clos R1 a1 a -> R2 (f a2) (f a1)) ->
  Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f a Hinv Acc_b.
set (b := f a) in *.
assert (b_eq_fa := refl_equal b).
unfold b at 2 in b_eq_fa; clearbody b.
revert a b_eq_fa Hinv; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa Hinv.
apply Acc_intro; intros a2 H2.
apply Acc_intro; intros a3 H3.
apply Acc_inv with a2; trivial.
apply IH with (f a2); trivial.
subst b; apply Hinv with a3; trivial.
left.
revert Hinv H2; clear; intros Hinv H2.
intros b1 b2 b3 K3 K2 K1.
apply Hinv with b3; trivial.
inversion K1 as [b | b' a' K1'].
right; left; assumption.
right; apply trans_clos_is_trans with a2; trivial.
left; assumption.
Qed.

Lemma acc_inv_im3 :
   forall A B (R1 : relation A) (R2 : relation B) (f : A -> B),
  forall a, (forall a1 a2, R1 a2 a1 -> refl_trans_clos R1 a1 a -> R2 (f a2) (f a1)) ->
  Acc R2 (f a) -> Acc R1 a.
Proof.
intros A B R1 R2 f a Hinv Acc_b.
set (b := f a) in *.
assert (b_eq_fa := refl_equal b).
unfold b at 2 in b_eq_fa; clearbody b.
revert a b_eq_fa Hinv; induction Acc_b as [b Acc_b IH].
intros a b_eq_fa Hinv.
apply Acc_intro; intros a2 H2.
apply IH with (f a2); trivial.
subst b; apply Hinv; trivial.
left.
revert Hinv H2; clear; intros Hinv H2.
intros b1 b2 K2 K1.
apply Hinv; trivial.
inversion K1 as [b | b' a' K1'].
right; left; assumption.
right; apply trans_clos_is_trans with a2; trivial.
left; assumption.
Qed.

Lemma union_equiv :
forall A R1 R2 R3 R4 (R1_equiv_R3: forall x y, R1 x y <-> R3 x y)
(R2_equiv_R4: forall x y, R2 x y <-> R4 x y) x y,
(union A R1 R2 x y <-> union _ R3 R4 x y).
Proof.
  intros A R1 R2 R3 R4 R1_equiv_R3 R2_equiv_R4 x y.
  split;intro H;case H.
  rewrite R1_equiv_R3;intro H';left;exact H'.
  rewrite R2_equiv_R4;intro H';right;exact H'.
  rewrite <- R1_equiv_R3;intro H';left;exact H'.
  rewrite <- R2_equiv_R4;intro H';right;exact H'.
Qed.

Lemma union_sym : forall A R1 R2 x y, union A R1 R2 x y <-> union A R2 R1 x y.
Proof.
  intros A R1 R2 x y.
  split;  (inversion_clear 1;[right|left];assumption).
Qed.

Lemma union_assoc :
  forall A R1 R2 R3 x y, union A (union A R1 R2) R3 x y <-> union A R1 (union A R2 R3) x y.
Proof.
  intros A R1 R2 R3 x y.
  split.
  intro H.
  case H;clear H;intro H.
  case H;clear H;intro H.
  left;assumption.
  right;left;assumption.
  right;right;assumption.
  intro H.
  case H;clear H;intro H.
  left;left;assumption.
  case H;clear H;intro H.
  left;right;assumption.
  right;assumption.
Qed.

Lemma union_idem : forall A R x y, union A R R x y <-> R x y.
Proof.
  intros A R x y.
  split.
  inversion_clear 1;assumption.
  intro H;left;assumption.
Qed.

Lemma union_idem_strong : forall A (R R': A -> A -> Prop) (H:forall x y, R x y -> R' x y) x y, (union A R R' x y <-> R' x y).
Proof.
  intros A R R' H x y.
  split.
  inversion_clear 1. apply H;assumption.
  assumption.
  intro H';right;assumption.
Qed.

Section star.
Unset Implicit Arguments.
Variable A:Type.
Variable R : A -> A -> Prop.
Inductive star (x:A) : A -> Prop :=
| star_refl : star x x
| star_step : forall y, star x y -> forall z, R y z -> star x z
.

Lemma star_trans: forall x y z, star x y -> star y z -> star x z.
Proof.
intros x y z H H1;revert x H;
induction H1.

tauto.
intros.
econstructor 2 with y0;auto.
Qed.

Lemma star_R : forall x y, R x y -> star x y.
Proof.
intros x y H;constructor 2 with x;[constructor|assumption].
Qed.

Lemma star_ind2 : forall  x (P:A -> Prop),
  (P x) ->
  (forall y, P y -> forall z, R y z -> P z) ->
  forall a, star x a -> P a.
Proof.
  intros x P H H0 a H1.
  induction H1.
  exact H.
  apply H0 with (y:=y);assumption.
Qed.

End star.

Lemma star_equiv :  forall A (R1 R2: A -> A -> Prop), (forall l r, R1 r l <-> R2 r l) ->
  forall l r, star _ R1 r l <-> star _ R2 r l.
Proof.
  intros A R1 R2 H l r.
  split;induction 1;try constructor.
  constructor 2 with y;auto.
  rewrite H in H1;assumption.
  constructor 2 with y;auto.
  rewrite H;assumption.
Qed.
Set Implicit Arguments.
Inductive product_o A B (R1 : relation A) (R2 : relation B) : relation (A*B)%type :=
	| CaseA : forall a a' b, R1 a a' -> product_o R1 R2 (a,b) (a',b)
	| CaseB : forall a b b', R2 b b' -> product_o R1 R2 (a,b) (a,b').

Lemma acc_and :
   forall A B (R1 : relation A) (R2 : relation B),
   forall a b, Acc R1 a -> Acc R2 b -> Acc (product_o R1 R2) (a,b).
Proof.
intros A B R1 R2 a b Acc_a; generalize b; clear b;
induction Acc_a as [a Acc_a IHa].
intros b Acc_b; generalize a Acc_a IHa; clear a Acc_a IHa;
induction Acc_b as [b Acc_b IHb]; intros a Acc_a IHa;
apply Acc_intro; intros [a' b'] H; inversion H; clear H; subst.
apply IHa; trivial.
apply Acc_intro; trivial.
apply IHb; trivial.
Defined.

Definition nf A (R : relation A) t := forall s, R s t -> False.

Lemma acc_nf : forall A (R : relation A) FB, (forall t s, In s (FB t) <-> R s t) ->
                          forall t, Acc R t -> { s : A | nf R s /\ (s = t \/ trans_clos R s t)}.
Proof.
intros A R FB red_dec t Acc_t; induction Acc_t as [t Acc_t IH].
case_eq (FB t).
intro H; exists t; split.
intros s H'; rewrite <- red_dec in H';  rewrite H in H'; trivial.
left; trivial.
intros a l H; destruct (IH a) as [a' [nf_a'  H']].
rewrite <- red_dec; rewrite H; left; trivial.
exists a'; split; trivial.
destruct H' as [a'_eq_a | H'].
subst; right; apply t_step; rewrite <- red_dec; rewrite H; left; trivial.
right; apply trans_clos_is_trans with a; trivial.
apply t_step; rewrite <- red_dec; rewrite H; left; trivial.
Defined.

Lemma dec_nf : forall A (R : relation A) FB, (forall t s, In s (FB t) <-> R s t) ->
                          forall t, {nf R t}+{~nf R t}.
Proof.
intros A R FB red_dec t.
case_eq (FB t).
intro H; left; unfold nf; intros s H'; rewrite <- red_dec in H'; rewrite H in H'; contradiction.
intros a l H.
right; intro H'; apply H' with a.
rewrite <- red_dec; rewrite H; left; trivial.
Defined.

Lemma cycle_not_acc : forall A (R : relation A) (a : A), R a a -> ~Acc R a.
Proof.
intros A R a H Acc_a; generalize H; clear H;
induction Acc_a as [a Acc_a IH].
intro H; apply (IH a); trivial.
Qed.