(* Authors: Christian Doczkal and Jan-Oliver Kaiser *)
(* Distributed under the terms of CeCILL-B. *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import setoid_leq misc languages dfa nfa.

Set Default Proof Using "Type".

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

(** * Regular Expressions

This file contains the definition of regular expressions and the proof
that regular expressions have the same expressive power as finite
automata. *)

Section RegExp.
Variable char : eqType.

Inductive regexp :=
 | Void
 | Eps
 | Atom of char
 | Star of regexp
 | Plus of regexp & regexp
 | Conc of regexp & regexp.

Lemma eq_regexp_dec (e1 e2 : regexp) : {e1 = e2} + {e1 <> e2}.
Proof. decide equality; apply: eq_comparable. Qed.

Definition regexp_eqMixin := EqMixin (compareP eq_regexp_dec).
Canonical Structure form_eqType := EqType _ regexp_eqMixin.
End RegExp.

Arguments void : clear implicits.
Arguments eps : clear implicits.
Prenex Implicits Plus.
Arguments plusP {char r s w}.

Notation "'Void'" := (@Void _).
Notation "'Eps'" := (@Eps _).

(** We assign a decidable language to every regular expression *)

Fixpoint re_lang (char: eqType) (e : regexp char) : dlang char :=
  match e with
  | Void => void char
  | Eps => eps char
  | Atom x => atom x
  | Star e1 => star (re_lang e1)
  | Plus e1 e2 => plus (re_lang e1) (re_lang e2)
  | Conc e1 e2 => conc (re_lang e1) (re_lang e2)
  end.

Canonical Structure regexp_predType (char: eqType) := PredType (@re_lang char).

(** We instantiate Ssreflects Canonical Big Operators *)
Notation "\sigma_( i <- r )  F" := (\big[Plus/Void]_(i <- r) F) (at level 50).
Notation "\sigma_( i | P )  F" := (\big[Plus/Void]_(i | P) F) (at level 50).

Lemma big_plus_seqP (T char : eqType) (r : seq T) w (F : T -> regexp char) :
  reflect (exists2 x, x \in r & w \in F x) (w \in \sigma_(i <- r) F i).
Proof.
  elim: r w => [|r rs IHrs] w. rewrite big_nil; by constructor => [[x]].
  rewrite big_cons; apply: (iffP plusP) => [[H|H]|[x]].
  - exists r => //; by rewrite mem_head.
  - case/IHrs : H => x Hx ?. exists x => //. by rewrite in_cons Hx orbT.
  - rewrite in_cons; case/orP => [/eqP -> |]; auto => ? ?.
    right. apply/IHrs. by exists x.
Qed.

Lemma big_plusP (T char: finType) (P:pred T) w (F : T -> regexp char) :
  reflect (exists2 i, P i  & w \in F i) (w \in \sigma_(i | P i) F i).
Proof.
  rewrite -big_filter. apply: (iffP (big_plus_seqP _ _ _)) => [[x]|[x] H1 H2].
  - rewrite mem_filter => /andP [? ?]; by exists x.
  - by exists x; rewrite // mem_filter H1 mem_index_enum.
Qed.

Fixpoint re_size (char: eqType) (e : regexp char) :=
  match e with
  | Star s => (re_size s).+1
  | Plus s t => ((re_size s)+(re_size t)).+1
  | Conc s t => ((re_size s)+(re_size t)).+1
  | _ => 1
  end.

Lemma big_plus_size (T char : eqType) (r : seq T) (F : T -> regexp char) m :
  (forall i, i \in r -> re_size (F i) <= m) -> re_size (\sigma_(i <- r) F i) <= (size r * m.+1).+1.
Proof.
  elim: r => [|e r IH /forall_cons [A B]]; first by rewrite big_nil.
  rewrite big_cons /= ltnS mulSn addSn -addnS leq_add //. exact: IH.
Qed.

(** ** Regular Expressions to Finite Automata *)
Section DFAofRE.
Variable (char : finType).

Fixpoint re_to_nfa (r : regexp char): nfa char :=
  match r with
  | Void => dfa_to_nfa (dfa_void _)
  | Eps => nfa_eps _
  | Atom a => nfa_char a
  | Star s => nfa_star (re_to_nfa s)
  | Plus s t => nfa_plus (re_to_nfa s) (re_to_nfa t)
  | Conc s t => nfa_conc (re_to_nfa s) (re_to_nfa t)
  end.

Lemma re_to_nfa_correct (r : regexp char) : nfa_lang (re_to_nfa r) =i r.
Proof.
  elim: r => [||a|s IHs |s IHs t IHt |s IHs t IHt] w //=.
  - by rewrite -dfa_to_nfa_correct inE /dfa_accept inE.
  - exact: nfa_eps_correct.
  - exact: nfa_char_correct.
  - rewrite nfa_star_correct. exact: star_eq.
  - by rewrite nfa_plus_correct /plus inE IHs IHt.
  - rewrite nfa_conc_correct. exact: conc_eq.
Qed.

Lemma re_to_nfa_size e : #|re_to_nfa e| <= 2 * re_size e.
Proof.
  elim: e; rewrite /= ?card_unit ?card_bool => //.
  - move => e IH. by rewrite card_option (leqRW IH) mulnS add2n.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
Qed.

Definition re_to_dfa := @nfa_to_dfa _ \o re_to_nfa.

Lemma re_to_dfa_correct (r : regexp char) : dfa_lang (re_to_dfa r) =i r.
Proof. move => w. by rewrite -nfa_to_dfa_correct re_to_nfa_correct. Qed.

Lemma re_to_dfa_size e : #|re_to_dfa e| <= 2^(2 * re_size e).
Proof. by rewrite card_set leq_pexp2l // re_to_nfa_size. Qed.

(** Decidability of regular expression equivalence *)

Definition re_equiv r s := dfa_equiv (re_to_dfa r) (re_to_dfa s).

Lemma re_equiv_correct r s : reflect (r =i s) (re_equiv r s).
Proof.
  apply: (iffP (dfa_equiv_correct _ _)) => H w;
    move/(_ w) : H; by rewrite !re_to_dfa_correct.
Qed.

End DFAofRE.

(** ** Finite Automata to Regular Expressions (Kleene Construction) *)

Section KleeneAlgorithm.
  Variable char : finType.
  Variable A : dfa char.

  (** We first define the transition languages between states. The
  trasition languages are defined such that [w \in L^X q p] iff for
  all nonempty strict prefixes [v] of [w], [delta q v \in X]. *)

  Definition L (X : {set A}) (p q : A) x :=
    (delta p x == q) && [forall (i : 'I_(size x) | 0 < i), delta p (take i x) \in X].
  Notation "'L^' X" := (L X) (at level 8,format "'L^' X").

  Lemma dfa_L x y w : w \in L^setT x y = (delta x w == y).
  Proof.
    rewrite unfold_in. case: (_ == _) => //=.
    apply/forall_inP => ? ?. by rewrite inE.
  Qed.

  Lemma LP {X : {set A}} {p q : A} {x} :
    reflect (delta p x = q /\ forall i, (0 < i) -> (i < size x) -> delta p (take i x) \in X)
            (x \in L^X p q).
  Proof.
    apply: (iffP andP); case => /eqP ? H; split => //.
    - move => i I1 I2. exact: (forall_inP H (Ordinal I2)).
    - apply/forall_inP => [[i I1 /= I2]]; auto.
  Qed.

  Lemma L_monotone (X : {set A}) (x y z : A): {subset L^X x y <= L^(z |: X) x y}.
  Proof.
    move => w. rewrite !unfold_in. case: (_ == _) => //. apply: sub_forall => i /=.
    case: (_ < _) => //= H. by rewrite inE H orbT.
  Qed.

  Lemma L_nil X x y : reflect (x = y) ([::] \in L^X x y).
  Proof. apply: (iffP LP) => //=. by case. Qed.

  Lemma L_set0 p q w :
    L^set0 q p w -> p = q /\ w = [::] \/ exists2 a, w = [::a] & p = dfa_trans q a.
  Proof.
    case/LP => <-. case: w => [|a [|b w]] H ; [by left|by right;exists a|].
    move: (H 1). do 2 case/(_ _)/Wrap => //. by rewrite inE.
  Qed.

  Lemma L_split X p q z w : w \in L (z |: X) p q ->
    w \in L^X p q \/
    exists w1 w2, [/\ w = w1 ++ w2, size w2 < size w, w1 \in L^X p z & w2 \in L^(z |: X) z q].
  Proof.
    case/LP => H1 H2.
    case: (find_minn_bound (fun i => (0 < i) && (delta p (take i w) == z)) (size w)).
    - case => i [lt_w /andP [i_gt0 /eqP delta_z] min_i]; right.
      exists (take i w); exists (drop i w).
      have ? : 0 < size w by exact: ltn_trans lt_w.
      rewrite cat_take_drop size_drop -{2}[size w]subn0 ltn_sub2l //; split => //.
      + apply/LP. split => // j J1 J2.
        have lt_i_j : j < i. apply: leq_trans J2 _. by rewrite size_take lt_w.
        have/(H2 _ J1) : j < size w. exact: ltn_trans lt_w.
        case/setU1P => [H|]; last by rewrite take_take 1?ltnW.
        move: (min_i _ lt_i_j). by rewrite negb_and J1 H eqxx.
      + apply/LP. rewrite -H1 -{2}[w](cat_take_drop i) delta_cat delta_z.
        split => // j J1 J2. rewrite -{1}delta_z -delta_cat -takeD.
        apply: H2; first by rewrite addn_gt0 J1 orbT.
        by rewrite -[w](cat_take_drop i) size_cat size_take lt_w ltn_add2l.
    - move => H; left. apply/LP. split => // i I1 I2. apply: contraTT (H2 _ I1 I2) => C.
      rewrite inE negb_or C inE andbT. apply: contraNN (H _ I2) => ->. by rewrite I1.
  Qed.

  Lemma L_cat (X : {set A}) x y z w1 w2 :
    z \in X -> w1 \in L^X x z -> w2 \in L^X z y -> w1++w2 \in L^X x y.
  Proof.
    move => Hz /LP [H11 H12] /LP [H21 H22]. apply/LP.
    split; first by rewrite delta_cat H11 H21.
    move => i i_gt0 H. rewrite take_cat. case: (boolP (i < _)); first exact: H12.
    rewrite delta_cat H11 -leqNgt => le_w1.
    case: (posnP (i - size w1)) => [->|Hi]; first by rewrite take0.
    apply: H22 => //. by rewrite -(ltn_add2l (size w1)) subnKC // -size_cat.
  Qed.

  Lemma L_catL X x y z w1 w2 :
    w1 \in L^X x z -> w2 \in L^(z |: X) z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move/(L_monotone z). apply: L_cat. exact: setU11. Qed.

  Lemma L_catR X x y z w1 w2 :
    w1 \in L^(z |: X) x z -> w2 \in L^X z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move => H /(L_monotone z). apply: L_cat H. exact: setU11. Qed.

  Lemma L_star (X : {set A}) z w : w \in star (L^X z z) -> w \in L^(z |: X) z z.
  Proof.
    move/starP => [vv Hvv ->]. elim: vv Hvv => [_|r vv IHvv]; first exact/L_nil.
    move => /= /andP [/andP [_ H1] H2]. exact: L_catL H1 (IHvv H2).
  Qed.

  (** Main Lemma - L satisfies a recursive equation that can be used
  to construct a regular expression *)

  Lemma L_rec (X : {set A}) x y z :
    L^(z |: X) x y =i plus (conc (L^X x z) (conc (star (L^X z z)) (L^X z y))) (L^X x y).
  Proof.
    move => w. apply/idP/idP.
    - move: w x y. apply: (size_induction (measure := size)) => w IHw x y.
      move/L_split => [|[w1 [w2 [Hw' H1 Hw1 Hw2]]]].
      + rewrite inE => ->. by rewrite orbT.
      + move: (IHw w2 H1 z y Hw2) Hw' => H4 -> {IHw H1}.
        rewrite inE (conc_cat Hw1 _) //.
        case/plusP : H4 => H; last by rewrite -[w2]cat0s conc_cat //.
        move/concP : H => [w21] [w22] [W1 [W2]] /concP [w221] [w222] [W3 [W4 W5]]; subst.
        by rewrite catA conc_cat // star_cat.
    - case/plusP ; last exact: L_monotone.
      move/concP => [w1] [w2] [-> [Hw1]] /concP [w3] [w4] [-> [Hw3 Hw4]].
      by rewrite (L_catL Hw1) // (L_catR _ Hw4) // L_star.
  Qed.

  (** Construction of the regular expression *)

  Definition edges (x y : A) := \big[Plus/Void]_(a | dfa_trans x a == y) Atom a.

  Definition edgesP x y w :
    reflect (exists2 a, w = [::a] & dfa_trans x a = y) (w \in edges x y).
  Proof. apply: (iffP (big_plusP _ _ _)) => [|] [a] /eqP ? /eqP ?; by exists a. Qed.

  Definition R0 x y := Plus (if x == y then Eps else Void) (edges x y).

  Lemma mem_R0 w x y :
    reflect (w = [::] /\ x=y \/ exists2 a, w = [::a] & dfa_trans x a = y)
            (w \in R0 x y).
  Proof.
    apply: (iffP plusP).
    - case => [| /edgesP]; auto. case e : (x == y) => // /eqP.
      by rewrite (eqP e); auto.
    - case => [[-> ->]|/edgesP];auto. by rewrite eqxx; auto.
  Qed.

  Fixpoint R (X : seq A) (x y : A) :=
    if X isn't z :: X' then R0 x y else
      Plus (Conc (R X' x z) (Conc (Star (R X' z z)) (R X' z y))) (R X' x y).

  Notation "'R^' X" := (R X) (at level 8, format "'R^' X").

  Lemma L_R (X : seq A) x y : L^[set z in X] x y =i R^X x y.
  Proof.
    elim: X x y => [|z X' IH] x y w.
    - rewrite (_ : [set z in [::]] = set0) //=.
      apply/idP/mem_R0.
      + move/L_set0 => [[-> ->]|[a -> ->]]; by eauto.
      + move => [[-> ->]|[a -> <-]]; apply/LP => /=; split => // [[|i]] //.
    - rewrite set_cons /= (L_rec _ _) -2!topredE /= /plus /= IH.
      f_equal.
      apply: conc_eq; first exact: IH.
      apply: conc_eq; last exact: IH.
      apply: star_eq. exact: IH.
  Qed.

  Definition dfa_to_re : regexp char := \sigma_(x | x \in dfa_fin A) R^(enum A) (dfa_s A) x.

  Lemma dfa_to_re_correct : dfa_lang A =i dfa_to_re.
  Proof.
    move => w. apply/idP/big_plusP => [H|[x Hx]].
    - exists (delta_s A w) => //. by rewrite -L_R set_enum dfa_L.
    - by rewrite -L_R set_enum dfa_L inE /dfa_accept => /eqP ->.
  Qed.

  (** ** Size Bound for Kleene Theorem *)

  Let c := (2 * #|char|).+3.

  Lemma R0_size x y : re_size (R0 x y) <= c.
  Proof.
    rewrite /= [X in X + _](_ : _ = 1); last by case (_ == _).
    rewrite add1n !ltnS. rewrite /edges -big_filter.
    apply: leq_trans (big_plus_size (m := 1) _) _ => [//|].
    rewrite size_filter ltnS mulnC leq_mul2l /=.
    apply: leq_trans (count_size _ _) _. by rewrite /index_enum -enumT cardE.
  Qed.

  Fixpoint R_size_rec (n : nat) := if n is n'.+1 then 4 * R_size_rec n' + 4 else c.

  Lemma R_size x : re_size (R^(enum A) (dfa_s A) x) <= R_size_rec #|A| .
  Proof.
    rewrite cardE. elim: (enum A) (dfa_s A) x => [|r s IH] p q.
    - exact: R0_size.
    - rewrite /= 6!(addSn,addnS) addn4 !ltnS !(leqRW (IH _ _)).
      by rewrite !mulSn mul0n addn0 !addnA.
  Qed.

  Lemma R_size_low (n : nat) : 3 <= R_size_rec n.
  Proof. elim: n => // n IH. by rewrite (leqRW IH) /= -(leqRW (leq_addr _ _)) leq_pmull. Qed.

  Lemma R_size_high n : R_size_rec n <= c * 4^(2 * n).
  Proof.
    elim: n => //= [|n IH].
    - by rewrite mulnS muln0 addn0.
    - rewrite [in X in _^X]mulnS expnD mulnA [c * _]mulnC -mulnA.
      rewrite -(leqRW IH) -[4^2]/((1+3) * 4) -mulnA mulnDl mul1n leq_add //.
      by rewrite -(leqRW (R_size_low _)).
  Qed.

  Lemma dfa_to_re_size : re_size dfa_to_re <= (#|A| * (c * 4 ^ (2 * #|A|)).+1).+1.
  Proof.
    rewrite /dfa_to_re -big_filter (leqRW (big_plus_size (m := R_size_rec #|A|)_)).
    - rewrite -(leqRW (R_size_high _)) size_filter (leqRW (count_size _ _)).
      by rewrite ltnS /index_enum -enumT cardE.
    - move => q _. exact: R_size.
  Qed.

End KleeneAlgorithm.

Lemma regularP (char : finType) (L : lang char) :
  regular L <-T->  { e : regexp char | forall x, L x <-> x \in e}.
Proof.
  split => [[A HA]|[e He]].
  - exists (dfa_to_re A) => x. by rewrite -dfa_to_re_correct.
  - exists (re_to_dfa e) => x. by rewrite re_to_dfa_correct.
Qed.

(** Closure of Regular Expressions under intersection and complement *)

Definition Inter (char : finType) (r s : regexp char) :=
  dfa_to_re (dfa_op andb (re_to_dfa r) (re_to_dfa s)).

Lemma Inter_correct (char : finType) (r s : regexp char) w :
  w \in Inter r s = (w \in r) && (w \in s).
Proof. by rewrite /Inter -dfa_to_re_correct dfa_op_correct !re_to_dfa_correct. Qed.

Definition Neg (char : finType) (r : regexp char) :=
  dfa_to_re (dfa_compl (re_to_dfa r)).

Lemma Neg_correct (char : finType) (r : regexp char) w :
  w \in Neg r = (w \notin r).
Proof. by rewrite /Neg -dfa_to_re_correct dfa_compl_correct !re_to_dfa_correct. Qed.

(** ** Regular expression for images of homomorphimsms *)

Prenex Implicits Conc.
Definition String (char : finType) (w : word char) :=
  foldr Conc Eps [seq Atom a | a <- w].

Lemma StringE (char : finType) (w : word char) : String w =i pred1 w.
Proof.
  elim: w => [|a v IHv] w //=. rewrite inE /String /=. apply/concP/eqP.
  - move => [w1] [w2] [e []]. set r := foldr _ _ _.
    rewrite -/(re_lang r) inE e => /eqP -> H /=.
    rewrite IHv inE in H. by rewrite (eqP H).
  - move => e. exists [:: a]; exists v; split => //; split.
    by rewrite inE. by rewrite IHv inE eqxx.
Qed.

Section Image.
  Variables (char char' : finType) (h : seq char -> seq char').
  Hypothesis h_hom : homomorphism h.

  Fixpoint re_image (e : regexp char) : regexp char' :=
    match e with
    | Void => Void
    | Eps => Eps
    | Atom a => String (h [:: a])
    | Star e => Star (re_image e)
    | Plus e1 e2 => Plus (re_image e1) (re_image e2)
    | Conc e1 e2 => Conc (re_image e1) (re_image e2)
    end.

  Lemma re_imageP e v : reflect (image h (re_lang e) v) (v \in re_image e).
  Proof using h_hom.
    elim: e v => [||a|e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2] v /=.
    - rewrite inE; constructor. move => [u]. by case.
    - rewrite inE; apply: (iffP eqP) => [-> |[w] [] /eqP -> <-]; last exact: h0.
      exists [::]; by rewrite ?h0.
    - rewrite StringE. apply: (iffP eqP) => [->|[w /=]].
      + exists [::a] => //. by rewrite /atom inE.
      + by rewrite /atom inE => [[]] /eqP -> <-.
    - apply: (iffP idP) => [/starP [vv] /allP Hvv dev_v|].
        have {Hvv IHe} Hvv v' : v' \in vv -> image h (re_lang e) v'.
          by move => /Hvv /= /andP [_ /IHe].
        subst v. elim: vv Hvv => [|v vv IHvv] Hvv /=; first by exists [::]; rewrite ?h0.
        case: (Hvv v (mem_head _ _)) => w [Hw1 Hw2].
        case/forall_cons: Hvv => Hv /IHvv [ww [Hww1 Hww2]].
        exists (w++ww); split; by [exact: star_cat | rewrite h_hom Hw2 Hww2].
      + case => w [] /starP [ww] /allP Hww1 -> <-. rewrite h_flatten //.
        apply: starI => v' /mapP [w' /Hww1 /= /andP [_ Hw' ->]].
        apply/IHe. by exists w'.
    - apply: (iffP orP).
       + case => [/IHe1 | /IHe2] [w] [] H <-.
           exists w => //. by rewrite /plus inE (_ : w \in re_lang e1).
         exists w => //. by rewrite /plus inE (_ : w \in re_lang e2) ?orbT.
       + case => w []. case/orP => H <-; [left; apply/IHe1 |right; apply/IHe2]; by exists w.
    - apply: (iffP idP).
      + case/concP => v1 [v2] [e] [/IHe1 [w [Hw1 Hw2]] /IHe2 [w' [Hw1' Hw2']]].
        exists (w++w'); split; first exact: conc_cat.
        by rewrite h_hom e Hw2 Hw2'.
      + case => w [] /concP [w1] [w2] [-> [H1 H2 <-]]. rewrite h_hom.
        apply: conc_cat; [apply/IHe1|apply/IHe2]. by exists w1. by exists w2.
  Qed.

End Image.

Lemma im_regular (char char' : finType) (h : word char -> word char') L :
  homomorphism h -> regular L -> regular (image h L).
Proof.
  move => hom_h /regularP [e He]. apply/regularP. exists (@re_image _ _ h e) => w.
  transitivity (image h (re_lang e) w); first exact: image_ext.
  exact: rwP (re_imageP _ _ _).
Qed.

(** ** Regular Expression for word reversal *)

Fixpoint Rev (char : finType) (e : regexp char) :=
  match e with
  | Star e => Star (Rev e)
  | Plus e1 e2 => Plus (Rev e1) (Rev e2)
  | Conc e1 e2 => Conc (Rev e2) (Rev e1)
  | _ => e
  end.

Lemma Rev_correct (char : finType) (e : regexp char) w :
  w \in Rev e = (rev w \in e).
Proof.
  elim: e w => [||a|e IH|e1 IH1 e2 IH2|e1 IH1 e2 IH2] w //.
  - rewrite !inE. apply/eqP/idP; first by move->.
    elim/last_ind: w => //= s a _. by rewrite rev_rcons.
  - rewrite !inE. apply/eqP/eqP; first by move->.
    do 2 elim/last_ind: w => //= w ? _. by rewrite !rev_rcons.
  - rewrite /=; apply/idP/idP; case/starP => vv /allP /= H.
    + move->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite -IH. by case/andP: (H _ V1).
    + rewrite -{2}[w]revK => ->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite IH revK. by case/andP: (H _ V1).
  - by rewrite /= !inE -!/(re_lang _) IH1 IH2.
  - rewrite /=. apply/concP/concP => [] [w1] [w2]; rewrite -!/(re_lang _).
    + move => [-> [A B]]. exists (rev w2), (rev w1). by rewrite rev_cat -IH1 -IH2.
    + rewrite -{2}[w]revK. move => [-> [A B]]. exists (rev w2), (rev w1).
      by rewrite rev_cat IH1 IH2 !revK.
Qed.

Lemma regular_rev (char : finType) (L : lang char) :
  regular L -> regular (fun x => L (rev x)).
Proof. case/regularP => e H. apply/regularP. exists (Rev e) => x. by rewrite Rev_correct. Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import Basic_Cons.Terminal.

(** In category of types, generalized products are simply dependent prdoducts. *)
Section Type_Cat_GenProd.
  Context (A : Type) (map : A → Type_Cat).

  Local Notation Fm := (Discr_Func Type_Cat map) (only parsing).

  Program Definition Type_Cat_GenProd_Cone : Cone Fm :=
    {|
      cone_apex := {|FO := fun _ => ∀ x : A, (Fm _o x)%object; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x y => y x |}
    |}.

  Program Definition Type_Cat_GenProd : (Π map)%object :=
    {|
      LRKE := Type_Cat_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c X x  =>
                    match c as u return ((Cn _o)%object u → map x) with
                    | tt => fun X : (Cn _o)%object tt => Trans Cn x X
                    end X
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    destruct c; destruct c'; destruct h.
    extensionality x; extensionality y.
    apply (equal_f ((@Trans_com _ _ _ _ Cn) y y eq_refl) x).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenProd_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y; extensionality z.
    destruct x.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (f_equal (fun w :
                  ((Cn ∘ (Functor_To_1_Cat (Discr_Cat A))) –≻ Fm)%nattrans =>
           Trans w z y) hc)); clearbody hc'; clear hc.
    trivial.
  Qed.

End Type_Cat_GenProd.


(* Axiom PropExt : forall (A B : Prop), A <-> B -> A = B. *)
Axiom PI : forall (A : Prop) (x y : A), x = y.
Axiom funext : forall A (B : A -> Type) (f g : forall x, B x), (forall x, f x = g x) -> f = g.

Set Primitive Projections.

Axiom ℙ : Type.
Axiom le₀ : ℙ -> ℙ -> Type.

Definition le p q := forall r, le₀ q r -> le₀ p r.

Definition le_id {p} : le p p := fun r k => k.
Definition le_cmp {p q r} (α : le p q) (β : le q r) : le p r := fun r k => α r (β r k).

Notation "p ≤ q" := (le p q) (at level 70, no associativity).
Notation "'!'" := (@le_id _).
Notation "α ∘ β" := (@le_cmp _ _ _ β α) (at level 35).

Record Psh := mkPsh {
  set : ℙ -> Type;
  mon : forall {p q} (α : q ≤ p), set p -> set q;
  mon_id : forall p (x : set p), mon ! x = x;
  mon_cmp : forall p q (α : le q p) r (β : r ≤ q) (x : set p), mon (α ∘ β) x = mon β (mon α x);
}.

Record Nat (A B : Psh) := mkNat {
  hom : forall p, A.(set) p -> B.(set) p;
  nat : forall p q (α : q ≤ p) x,
    hom q (A.(mon) α x) = B.(mon) α (hom p x);
}.

Arguments hom {_ _}.
Arguments nat {_ _}.

Lemma Nat_eq : forall A B (f g : Nat A B),
  (forall p (x : A.(set) p), f.(hom) p x = g.(hom) p x) -> f = g.
Proof.
intros A B [f fn] [g gn] e.
cbn in *.
assert (e' : f = g).
{ apply funext; intros p; apply funext; intros x; apply e. }
destruct e'.
replace fn with gn by apply PI.
reflexivity.
Qed.

Definition Nid {A} : Nat A A.
Proof.
unshelve refine (mkNat _ _ (fun _ x => x) _).
reflexivity.
Defined.

Definition Ncmp {A B C} (f : Nat A B) (g : Nat B C) : Nat A C.
Proof.
unshelve refine (mkNat _ _ (fun p x => g.(hom) p (f.(hom) p x)) _).
intros; rewrite f.(nat), g.(nat); reflexivity.
Defined.

Record Pfc := mkPfc {
  elt : forall p q (α : q ≤ p), Type;
  rel : forall p, (forall q α, elt p q α) -> Prop;
  prm : forall p q (α : q ≤ p), elt p q α = elt q q !;
}.

Definition cast (A : Pfc) {p q} (α : q ≤ p) : A.(elt) q q ! -> A.(elt) p q α :=
  match A.(prm) p q α with eq_refl => fun x => x end.

Record El p (A : Pfc) := mkEl {
  el₀ : forall q (α : q ≤ p), A.(elt) q q !;
  elε : forall q (α : q ≤ p), A.(rel) q (fun r β => cast A β (el₀ r (α ∘ β)));
}.

Arguments el₀ {_ _}.
Arguments elε {_ _}.

Lemma El_eq : forall p A (x y : El p A),
  x.(el₀) = y.(el₀) -> x = y.
Proof.
intros p A [x₀ xε] [y₀ yε] e; cbn in *.
destruct e.
replace yε with xε by apply PI.
reflexivity.
Qed.

Definition lift (A : Pfc) {p q} (α : q ≤ p) (x : El p A) : El q A.
Proof.
unshelve refine (mkEl _ _ (fun r β => x.(el₀) r (α ∘ β)) _).
refine (fun r β => x.(elε) r (α ∘ β)).
Defined.

Record Fnc (A B : Pfc) := mkFnc {
  fnc : forall p (x : El p A), B.(elt) p p !;
  rlz : forall p (x : El p A), B.(rel) p (fun q (α : q ≤ p) => cast B α (fnc q (lift A α x)));
}.

Arguments fnc {_ _}.
Arguments rlz {_ _}.

Lemma Fnc_eq : forall A B (f g : Fnc A B),
  (forall p (x : El p A), f.(fnc) p x = g.(fnc) p x) -> f = g.
Proof.
intros A B [f fn] [g gn] e.
cbn in *.
assert (e' : f = g).
{ apply funext; intros p; apply funext; intros x; apply e. }
destruct e'.
replace fn with gn by apply PI.
reflexivity.
Qed.

Definition App {A B p} (f : Fnc A B) (x : El p A) : El p B.
Proof.
unshelve refine (mkEl _ _ (fun q α => f.(fnc) q (lift A α x)) _).
intros q α.
apply (f.(rlz) q (lift A α x)).
Defined.

Definition Fid {A} : Fnc A A.
Proof.
unshelve refine (mkFnc _ _ (fun p x => x.(el₀) p !) _).
intros p x.
refine (x.(elε) p !).
Defined.

Definition Fcmp {A B C} (f : Fnc A B) (g : Fnc B C) : Fnc A C.
Proof.
unshelve refine (mkFnc _ _ (fun p x => g.(fnc) p (App f x)) _).
intros p x.
refine (g.(rlz) _ (App f x)).
Defined.

Definition F (A : Psh) : Pfc.
Proof.
unshelve refine (
  mkPfc
    (fun p q α => A.(set) q)
    (fun p x => forall q (α : q ≤ p), x q α = A.(mon) α (x p !))
    (fun p q α => eq_refl)).
Defined.

Definition G (A : Pfc) : Psh.
Proof.
unshelve refine (
  mkPsh
    (fun p => El p A)
    (fun p q α x => lift A α x)
    (fun p x => eq_refl)
    (fun p q α r β x => eq_refl)
).
Defined.

Definition Fφ {A B} (f : Nat A B) : Fnc (F A) (F B).
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => f.(hom) p (x.(el₀) p !)).
+ cbn; intros p x q α.
  rewrite <- f.(nat).
  assert (xε := x.(elε) p ! q α).
  cbn in *.
  rewrite <- xε.
  reflexivity.
Defined.

Lemma Fφ_id : forall A, Fφ (@Nid A) = Fid.
Proof.
intros A.
apply Fnc_eq; intros p α; reflexivity.
Qed.

Lemma Fφ_cmp : forall A B C (f : Nat A B) (g : Nat B C), Fφ (Ncmp f g) = Fcmp (Fφ f) (Fφ g).
Proof.
intros A B C f g.
apply Fnc_eq; intros p α; reflexivity.
Qed.

Definition Gφ {A B} (f : Fnc A B) : Nat (G A) (G B).
Proof.
unshelve refine (mkNat _ _ _ _).
+ refine (fun p x => App f x).
+ cbn; intros p q α x.
  reflexivity.
Defined.

Lemma Gφ_id : forall A, Gφ (@Fid A) = Nid.
Proof.
intros A.
apply Nat_eq; intros p α; reflexivity.
Qed.

Lemma Gφ_cmp : forall A B C (f : Fnc A B) (g : Fnc B C), Gφ (Fcmp f g) = Ncmp (Gφ f) (Gφ g).
Proof.
intros A B C f g.
apply Nat_eq; intros p α; reflexivity.
Qed.

Definition of_GF {A} : Nat (G (F A)) A.
Proof.
unshelve refine (mkNat _ _ _ _).
+ refine (fun p x => x.(el₀) p !).
+ intros p q α [x₀ xε]; cbn in *.
  specialize (xε p ! q α).
  etransitivity; [|apply xε].
  reflexivity.
Defined.

Lemma of_GF_nat : forall A B (f : Nat A B),
  Ncmp of_GF f = Ncmp (Gφ (Fφ f)) of_GF.
Proof.
intros A B f.
apply Nat_eq; intros p x.
reflexivity.
Qed.

Definition to_GF {A} : Nat A (G (F A)).
Proof.
unshelve refine (mkNat _ _ _ _).
+ unshelve refine (fun p x => mkEl _ _ (fun q α => _) _).
  - refine (A.(mon) α x).
  - refine (fun q α r β => A.(mon_cmp) _ _ _ _ _ _).
+ cbn; intros p q α x.
  apply El_eq; cbn.
  apply funext; intros r; apply funext; intros β.
  symmetry; apply A.(mon_cmp).
Defined.

Lemma to_GF_nat : forall A B (f : Nat A B),
  Ncmp f to_GF = Ncmp to_GF (Gφ (Fφ f)).
Proof.
intros A B f.
apply Nat_eq; intros p x; apply El_eq.
apply funext; intros q; apply funext; intros α.
cbn.
rewrite f.(nat); reflexivity.
Qed.

Lemma of_to_GF_id : forall A, Ncmp of_GF to_GF = @Nid (G (F A)).
Proof.
intros A.
apply Nat_eq; intros p x; cbn in *.
apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
symmetry.
apply x.(elε).
Qed.

Lemma to_of_GF_id : forall A, Ncmp to_GF of_GF = @Nid A.
Proof.
intros A.
apply Nat_eq; intros p x; cbn in *.
apply A.(mon_id).
Qed.

Definition of_FG {A} : Fnc (F (G A)) A.
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => (x.(el₀) p !).(el₀) p !).
+ intros p [x₀ xε]; cbn in *.
  assert (e : x₀ = (fun q (α : q ≤ p) => lift A α (x₀ p !))).
  { apply funext; intros q; apply funext; intros α.
    apply (xε p ! q α). }
  rewrite e; cbn; clear e.
  apply (x₀ p !).(elε).
Defined.

Lemma of_FG_nat : forall A B (f : Fnc A B),
  Fcmp of_FG f = Fcmp (Fφ (Gφ f)) of_FG.
Proof.
intros A B f.
apply Fnc_eq; intros p [x₀ xε]; cbn in *.
f_equal; apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
specialize (xε p ! q α).
change (α ∘ !) with (! ∘ α).
rewrite xε.
reflexivity.
Qed.

Definition to_FG {A} : Fnc A (F (G A)).
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => x).
+ intros p x; cbn; reflexivity.
Defined.

Lemma to_FG_nat : forall A B (f : Fnc A B),
  Fcmp f to_FG = Fcmp to_FG (Fφ (Gφ f)).
Proof.
intros A B f.
apply Fnc_eq; intros p x.
reflexivity.
Qed.

Lemma of_to_FG_id : forall A, Fcmp of_FG to_FG = @Fid (F (G A)).
Proof.
intros A.
apply Fnc_eq; intros p [x₀ xε]; cbn in *.
apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
change (el₀ (x₀ q (! ∘ α)) q ! = el₀ (x₀ p !) q α).
rewrite (xε p ! q α).
reflexivity.
Qed.

Lemma to_of_FG_id : forall A, Fcmp to_FG of_FG = @Fid A.
Proof.
intros A.
apply Fnc_eq; intros p x; cbn in *.
reflexivity.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Rbase.
Require Export QArith_base.

(** Injection of rational numbers into real numbers. *)

Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R.

Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R.
Proof.
intros.
now apply not_O_IZR.
Qed.

Hint Resolve IZR_nz Rmult_integral_contrapositive.

Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y.
Proof.
unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply eq_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R).
rewrite <- H; field; auto.
rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto.
Qed.

Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y.
Proof.
unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert ((X1 * Y2)%R = (Y1 * X2)%R).
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_eq; auto.
clear H.
field_simplify_eq; auto.
rewrite H0; ring.
Qed.

Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y.
Proof.
unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply le_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
apply Rmult_le_compat_r; auto.
apply Rmult_le_pos.
now apply IZR_le.
now apply IZR_le.
Qed.

Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R.
Proof.
unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert (X1 * Y2 <= Y1 * X2)%R.
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_le; auto.
clear H.
replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
apply Rmult_le_compat_r; auto.
apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x<y.
Proof.
unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply lt_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
apply Rmult_lt_compat_r; auto.
apply Rmult_lt_0_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Qlt_Rlt : forall x y : Q, x<y -> (Q2R x < Q2R y)%R.
Proof.
unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert (X1 * Y2 < Y1 * X2)%R.
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_lt; auto.
clear H.
replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
apply Rmult_lt_compat_r; auto.
apply Rmult_lt_0_compat; apply Rinv_0_lt_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R.
Proof.
unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2);
 unfold Qden, Qnum.
simpl_mult.
rewrite plus_IZR.
do 3 rewrite mult_IZR.
field; auto.
Qed.

Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R.
Proof.
unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2);
 unfold Qden, Qnum.
simpl_mult.
do 2 rewrite mult_IZR.
field; auto.
Qed.

Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R.
Proof.
unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum.
rewrite Ropp_Ropp_IZR.
field; auto.
Qed.

Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
Proof.
unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
Qed.

Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R.
Proof.
unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden.
simpl; intros; elim H; trivial.
intros; field; auto.
intros;
  change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R;
  change (IZR (Zneg p)) with (- IZR (Zpos p))%R;
  simpl; field; (*auto 8 with real.*)
  repeat split; auto; auto with real.
Qed.

Lemma Q2R_div :
 forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R.
Proof.
unfold Qdiv, Rdiv.
intros; rewrite Q2R_mult.
rewrite Q2R_inv; auto.
Qed.

Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.


Require Import Arith NPeano List Bool Psatz.
Require Import Cecoa.Lib Cecoa.Syntax Cecoa.CBV_cache.
Require Import Omega.

Import List.ListNotations.
Infix "∈" := In (at level 70).

Section Ordering.

Set Implicit Arguments.

Variables variable function constructor : Type.

Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Notation cbv := (CBV_cache.cbv variable function constructor).
Notation cache := (CBV_cache.cache variable function constructor).

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.

Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.

Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Variable rule_default : rule.

Variable prog : list rule.

Variable max_arity : nat.

Notation wf :=
  (CBV_cache.wf variable_eq_dec function_eq_dec constructor_eq_dec rule_default prog max_arity).

(* Function ranks and compatibility *)

Variable rank: function -> nat.

(* PPO *)

Inductive product {A: Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| product_conseq : forall x y xs ys, x = y -> product R xs ys   -> product R (x::xs) (y::ys)
| product_consst : forall x y xs ys, R x y -> Forall2 (clos_refl R) xs ys -> product R (x::xs) (y::ys).

Inductive PPO: term -> term -> Prop :=
| ppo_constr_in    : forall s c lt,    In s lt            -> PPO s (capply c lt)
| ppo_fun_in       : forall s f lt,    In s lt            -> PPO s (fapply f lt)
| ppo_constr_sub   : forall s t c lt,  In t lt -> PPO s t -> PPO s (capply c lt)
| ppo_fun_sub      : forall s t f lt,  In t lt -> PPO s t -> PPO s (fapply f lt)
| ppo_constr_split : forall c ls f lt, (forall s, In s ls -> PPO s (fapply f lt))
                                       -> PPO (capply c ls) (fapply f lt)
| ppo_funlt_split  : forall g ls f lt, rank g < rank f
                                       -> (forall s, In s ls -> PPO s (fapply f lt))
                                       -> PPO (fapply g ls) (fapply f lt)
| ppo_funeqv_split : forall g ls f lt, rank g = rank f
                                       -> product PPO ls lt
                                       -> PPO (fapply g ls) (fapply f lt).

Infix "≺ppo" := PPO (at level 80).
Infix "≼ppo" := (clos_refl PPO) (at level 80).

Hint Constructors product PPO.

Definition lt_wf_rect (n : nat) (P : nat -> Type)
  (F : forall n, (forall m, m < n -> P m) -> P n) : P n :=
  well_founded_induction_type (well_founded_ltof nat (fun m => m)) P F n.

Definition term_dec (t1 t2 : term) : {t1=t2}+{t1<>t2}.
Proof.
case_eq (term_beq variable_eq_dec function_eq_dec constructor_eq_dec t1 t2); intro H; [ left | right];
rewrite <- (term_beq_eq variable_eq_dec function_eq_dec constructor_eq_dec); [exact H | congruence ].
Defined.

Lemma Exists_dec_gen :
  forall {A : Type} (P : A -> Prop) (l : list A),
  (forall x : A, In x l -> {P x} + {~ P x}) -> {Exists P l} + {~ Exists P l}.
Proof.
intros A P l P_dec.
induction l as [ | x l IH ].

- right.
  intro Hex.
  inversion Hex.

- elim (P_dec x); [ | | simpl; tauto ].

  + intro HP.
    left.
    apply Exists_cons_hd; assumption.

  + intro HnotP.
    elim IH.

    * intro Hex.
      left.
      apply Exists_cons_tl; assumption.

    * intro Hnotex.
      right.
      intro Hex.
      inversion Hex; tauto.

    * intros x' Hx'.
      apply P_dec.
      simpl; tauto.
Defined.

Lemma Forall_dec_gen :
  forall {A : Type} (P : A -> Prop) (l : list A),
  (forall x : A, In x l -> {P x} + {~ P x}) -> {Forall P l} + {~ Forall P l}.
Proof.
  intros A P l.
  induction l as [ | x' l' IH ];
    [ intros; left; constructor | ].
  intros Hx'l'.
  assert (Hx' : {P x'} + {~ P x'}) by now apply Hx'l'; left.
  assert (Hl' : forall x : A, In x l' -> {P x} + {~ P x}) by now intros; apply Hx'l'; right.
  clear Hx'l'.
  apply IH in Hl'.
  elim Hx'; elim Hl'; intros H'x' H'l';
  [ now left; constructor | | | ];
  now right; intros Hfor; inversion Hfor.
Defined.

Lemma Forall2_dec_gen :
  forall {A B : Type} (R : A -> B -> Prop) (xs : list A) (ys : list B),
  (forall x y, In x xs -> In y ys -> {R x y}+{~R x y}) ->
  {Forall2 R xs ys}+{~Forall2 R xs ys}.
Proof.
  intros A B R xs.
  induction xs as [ | x xs IH ].

  - intros ys.
    case ys; intros;
      [ left; constructor
      | right; intros Hfor; inversion Hfor ].

  - intros ys; case ys; clear ys;
    [ now intros; right; intros Hfor; inversion Hfor | ].
    intros y ys Hxxsyys.

    assert (Hxy : {R x y} + {~ R x y}) by now apply Hxxsyys; left.
    assert (Hxsys : {Forall2 R xs ys} + {~ Forall2 R xs ys})
      by now apply IH; intros; apply Hxxsyys; right.
    clear Hxxsyys.
    elim Hxy; elim Hxsys; intros H'xsys H'xy;
    [ now left; constructor | | | ] ;
    now right; intros Hfor; inversion Hfor.
Defined.

Lemma clos_refl_dec {A : Type} (A_dec : forall x y:A, {x=y}+{x<>y})
  (R : A -> A -> Prop) (x y : A) (R_dec : {R x y}+{~R x y}) :
  {clos_refl R x y}+{~(clos_refl R) x y}.
Proof.
unfold clos_refl.
destruct (A_dec x y) as [ Heq | Hneq ].

- left.
  tauto.

- destruct R_dec as [ Hr | Hnotr ].

  + left.
    tauto.

  + right.
    tauto.
Defined.

Lemma product_dec (A : Type) (A_dec : forall x y:A, {x=y}+{x<>y})
  (R : A -> A -> Prop) (xs ys : list A)
  (R_dec : forall x y, In x xs -> In y ys -> {R x y}+{~R x y}) :
  {product R xs ys}+{~product R xs ys}.
Proof.
revert ys R_dec.
induction xs as [ | x xs IH ]; intros ys R_dec.

- right.
  intro Hproduct.
  inversion Hproduct.

- destruct ys as [ | y ys ].

  + right.
    intro Hproduct.
    inversion Hproduct.

  + destruct (A_dec x y) as [ Heq | Hneq ].

    * {elim (IH ys).

      - intro Hprod.
        left.
        apply product_conseq; assumption.

      - intro Hnotprod.
        elim (R_dec x y).

        + intro Hr.
          eelim (Forall2_dec_gen (clos_refl R) xs ys _).

Unshelve.

          * intro Hall.
            left.
            apply product_consst; trivial.

          * intro Hnotall.
            right.
            intro Hprod.
            inversion Hprod; tauto.

          * intros x' y' Hx' Hy'.
            apply clos_refl_dec; [ exact A_dec | ].
            apply R_dec; simpl; tauto.

        + intro HnotR.
          right.
          intro Hprod.
          inversion Hprod; tauto.

        + simpl; tauto.

        + simpl; tauto.

      - intros; apply R_dec; simpl; tauto.
      }

      * {elim (R_dec x y).

        - intro Hr.
          eelim (Forall2_dec_gen (clos_refl R) xs ys _).

Unshelve.

          + intro Hall.
            left.
            apply product_consst; trivial.

          + intro Hnotall.
            right.
            intro Hprod.
            inversion Hprod; tauto.

          + intros x' y' Hx' Hy'.
            apply clos_refl_dec; [ exact A_dec | ].
            apply R_dec; simpl; tauto.

        - intro HnotR.
          right.
          intro Hprod.
          inversion Hprod; tauto.

        - simpl; tauto.

        - simpl; tauto.
        }
Defined.

Lemma PPO_dec t1 t2: {PPO t1 t2}+{~PPO t1 t2}.
Proof.
clear rule_default.
remember (term_size t1 + term_size t2) as whole_size eqn: H_size.
revert t1 t2 H_size.
induction whole_size as [ whole_size IH ] using lt_wf_rect.
intros [ x | c lt | f lt ] [ x' | c' lt' | f' lt' ] H_size;
 try (right; intro Hppo; inversion Hppo; fail).

- destruct (@in_dec term term_dec (var x) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_constr_in; exact Hin.

  + eelim (Exists_dec_gen (fun t => PPO (var x) t) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_constr_sub with t'; trivial.

    * intro Hnotex.
      right.
      rewrite Exists_exists in Hnotex.
      intro Hppo.
      inversion Hppo; [ tauto | ].
      apply Hnotex.
      eexists.
      split; eassumption.

    * simpl.
      intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.

- destruct (@in_dec term term_dec (var x) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_fun_in; exact Hin.

  + eelim (Exists_dec_gen (PPO (var x)) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_fun_sub with t'; trivial.

    * intro Hnotex.
      right.
      rewrite Exists_exists in Hnotex.
      intro Hppo.
      inversion Hppo; [ tauto | ].
      apply Hnotex.
      eexists.
      split; eassumption.

    * intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.

- destruct (@in_dec term term_dec (capply c lt) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_constr_in; exact Hin.

  + eelim (Exists_dec_gen (PPO (capply c lt)) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_constr_sub with t'; trivial.

    * intro Hnotex.
      right.
      rewrite Exists_exists in Hnotex.
      intro Hppo.
      inversion Hppo; [ tauto | ].
      apply Hnotex.
      eexists.
      split; eassumption.

    * intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.

- destruct (@in_dec term term_dec (capply c lt) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_fun_in; exact Hin.

  + eelim (Exists_dec_gen (PPO (capply c lt)) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_fun_sub with t'; trivial.

    * intro Hnotex.
      {eelim (Forall_dec_gen (fun t => PPO t (fapply f' lt')) lt _).

Unshelve.

      - intro Hall.
        left.
        rewrite Forall_forall in Hall.
        apply ppo_constr_split; assumption.

      - intro Hnotall.
        right.
        rewrite Exists_exists in Hnotex.
        rewrite Forall_forall in Hnotall.
        intros Hppo.
        inversion Hppo; [ tauto | firstorder | tauto ].

      - intros t Hin.
        eapply IH; [ | reflexivity ].
        subst whole_size.
        apply plus_lt_compat_r.
        simpl.
        apply le_lt_n_Sm, in_le_suml.
        rewrite in_map_iff.
        exists t.
        tauto.
      }

    * intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.

- destruct (@in_dec term term_dec (fapply f lt) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_constr_in; exact Hin.

  + eelim (Exists_dec_gen (PPO (fapply f lt)) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_constr_sub with t'; trivial.

    * intro Hnotex.
      right.
      rewrite Exists_exists in Hnotex.
      intro Hppo.
      inversion Hppo; [ tauto | ].
      apply Hnotex.
      eexists.
      split; eassumption.

    * intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.

- destruct (@in_dec term term_dec (fapply f lt) lt') as [ Hin | Hnotin ].

  + left.
    apply ppo_fun_in; exact Hin.

  + eelim (Exists_dec_gen (PPO (fapply f lt)) lt' _).

Unshelve.

    * intro Hex.
      left.
      rewrite Exists_exists in Hex.
      destruct Hex as (t' & Hin & Hppo).
      apply ppo_fun_sub with t'; trivial.

    * intro Hnotex.
      rewrite Exists_exists in Hnotex.
      {destruct (lt_eq_lt_dec (rank f) (rank f')) as [ [ Hlt | Heq ] | Hgt ].

      - eelim (Forall_dec_gen (fun t => PPO t (fapply f' lt')) lt _).

Unshelve.

        * intro Hall.
          left.
          rewrite Forall_forall in Hall.
          apply ppo_funlt_split; assumption.

        * intro Hnotall.
          right.
          rewrite Forall_forall in Hnotall.
          intros Hppo.
          inversion Hppo; [ tauto | firstorder | tauto | omega ].

        * intros t Hin.
          eapply IH; [ | reflexivity ].
          subst whole_size.
          apply plus_lt_compat_r.
          simpl.
          apply le_lt_n_Sm, in_le_suml.
          rewrite in_map_iff.
          exists t.
          tauto.

      - destruct (product_dec term_dec PPO lt lt').

        + intros t t' Ht Ht'.
          eapply IH; [ | reflexivity ].
          subst whole_size.
          apply plus_lt_compat; simpl; apply le_lt_n_Sm, in_le_suml;
           rewrite in_map_iff; eexists; tauto.

        + left.
          apply ppo_funeqv_split; trivial.

        + right.
          intro Hppo.
          inversion Hppo; [ tauto | firstorder | omega | tauto ].

      - right.
        intro Hppo.
        inversion Hppo; [ tauto | firstorder | omega | omega ].
      }

    * intros t' Hin.
      eapply IH; [ | reflexivity ].
      subst whole_size.
      apply plus_lt_compat_l.
      simpl.
      apply le_lt_n_Sm, in_le_suml.
      rewrite in_map_iff.
      exists t'.
      tauto.
Defined.

Lemma product_length A (R: A -> A -> Prop) xs ys :
  product R xs ys -> length xs = length ys.
Proof.
intro H.
induction H as [ x y xs ys H1 H2 IH | x y xs ys H1 H2 ].

- simpl; congruence.

- apply Forall2_length in H2.
  simpl; congruence.
Qed.

Lemma product_Forall2 A (R: A -> A -> Prop) ls lt : product R ls lt -> Forall2 (clos_refl R) ls lt.
Proof.
intro H_product.
unfold clos_refl.
induction H_product; auto.
Qed.

Lemma product_Exists2 A (R: A -> A -> Prop) ls lt : product R ls lt -> Exists2 R ls lt.
Proof.
intro H_product.
induction H_product; auto.
Qed.

Definition PPO_rule (r: rule) : Prop :=
  match r with
    | rule_intro f lp t => PPO t (fapply f (map (@term_from_pattern _ _ _) lp))
  end.

Definition PPO_prog : Prop :=
  forall r, In r prog -> PPO_rule r.

Lemma value_PPO_function (v: value) (f: function) (lt: list term) :
  PPO (@term_from_value _ _ _ v) (fapply f lt).
Proof.
  (* c’est juste un paquet de ppo_constr_split pour déconstruire la valeur *)
  induction v using value_ind2.
  simpl.

  apply ppo_constr_split.
  intros s H_s_in_map.
  rewrite in_map_iff in H_s_in_map.
  destruct H_s_in_map as (v & H1 & H2).
  subst s.
  apply H.
  exact H2.
Qed.

Lemma product_trans (A: Type) (R : A -> A -> Prop) lt1 lt2 lt3 :
    (forall t1 t2 t3, In t1 lt1 -> In t2 lt2 -> In t3 lt3 -> R t1 t2 -> R t2 t3 -> R t1 t3) ->
    product R lt1 lt2 -> product R lt2 lt3 -> product R lt1 lt3.
Proof.
intros H_R H12 H23.
assert (length lt1 = length lt2) as Hlen12. { apply product_length in H12; trivial. }
assert (length lt2 = length lt3) as Hlen23. { apply product_length in H23; trivial. }
revert lt1 H_R Hlen12 H12.
induction H23 as [ Ba t23 lt2 lt3 Be H_prod23 IH | t2 t3 lt2 lt3 HR23 HForall23 ];
intros lt1 H_R Hlen12 H12.

- subst.
  inversion H12 as [ Ba Bb lt1' Bd Be H_prod12 Bg Bh | t1 Bb lt1' Bd HR12 HForall12 Bg Bh ];
  subst; rename lt1' into lt1.

  + apply product_conseq; trivial.
    simpl in *.
    apply IH; try congruence.
    intros t1 t2 t3 H_In1 H_In2 H_In3.
    apply H_R; tauto.

  + apply product_consst; trivial.
    apply Forall2_trans with (ys := lt2); trivial.

    * intros t1' t2; intros; apply clos_refl_trans with (t2:=t2); trivial.
      apply H_R; simpl; tauto.

    * apply product_Forall2.
      exact H_prod23.

- inversion H12 as [ Ba Bb lt1' Bd Be Hprod12 Bg Bh | t1 Bb lt1' Bd HR12 HForall12 Bg Bh ];
  subst; rename lt1' into lt1.

  + apply product_consst; trivial.
    apply Forall2_trans with (ys := lt2); trivial.

    * intros t1' t2' t3' Hin1' Hin2' Hin3' [ HR12' | Heq12'] [ HR23' | Heq23' ];
      subst;
      unfold clos_refl;
      try tauto.

      left.
      apply (H_R t1' t2' t3'); trivial; simpl; tauto.

    * apply product_Forall2; trivial.

  + apply product_consst.

    * apply (H_R t1 t2 t3); simpl; tauto.

    * apply Forall2_trans with (ys := lt2); trivial.
      intros t1' t2' t3' Hin1' Hin2' Hin3' [ HR12' | Heq12'] [ HR23' | Heq23' ];
      subst;
      unfold clos_refl;
      try tauto.

      left.
      apply (H_R t1' t2' t3'); trivial; simpl; tauto.
Qed.

Lemma PPO_trans t1 t2 t3 : PPO t1 t2 -> PPO t2 t3 -> PPO t1 t3.
Proof.
remember (term_size t1 + term_size t2 + term_size t3) as whole_size eqn: H_size.
revert t1 t2 t3 H_size.
induction whole_size as [ whole_size IH ] using lt_wf_ind.
intros t1 t2 t3 H_size H12 H23.

inversion H23 as [ Ba c3 lt3 Hin3 Be Bf | Ba f3 lt3 Hin3 Be Bf | Ba t3' c3 lt3 Hin3 Hppo23 Bg Bh | Ba t3' f3 lt3 Hin3 Hppo23 Bg Bh | c2 lt2 f3 lt3 Hppo23 Bf Bg | f2 lt2 f3 lt3 Hrk23 Hppo23 Bg Bh | f2 lt2 f3 lt3 Hrk23 Hprodppo23 Bg Bh ];
subst.

- (* ppo_constr_in *)
  apply ppo_constr_sub with (t:=t2); trivial.

- (* ppo_fun_in *)
  apply ppo_fun_sub with (t:=t2); trivial.

- (* ppo_constr_sub *)
  apply ppo_constr_sub with (t:=t3'); trivial.
  apply IH with (m:= term_size t1 + term_size t2 + term_size t3') (t2 := t2); auto.
  apply plus_lt_compat_l.
  apply (in_map (@term_size _ _ _)), in_le_suml in Hin3.
  apply le_lt_n_Sm; trivial.

- (* ppo_fun_sub *)
  apply ppo_fun_sub with (t:=t3'); trivial.
  apply IH with (m:= term_size t1 + term_size t2 + term_size t3') (t2 := t2); auto.
  apply plus_lt_compat_l.
  apply (in_map (@term_size _ _ _)), in_le_suml in Hin3.
  apply le_lt_n_Sm; trivial.

- (* ppo_constr_split *)
  inversion H12 as [ | | Ba t2 Bc Bd Hin2 Hppo12 Bg Bh | | | | ]; subst; auto.
  apply IH with (m:= term_size t1 + term_size t2 + term_size (fapply f3 lt3)) (t2 := t2); auto.
  apply plus_lt_compat_r; apply plus_lt_compat_l.
  apply (in_map (@term_size _ _ _)), in_le_suml in Hin2.
  apply le_lt_n_Sm; trivial.

- (* ppo_funlt_split *)
  inversion H12 as [ | Ba Bb Bc Hin1 Be Bf | | Ba t2 Bc Bd Hin2 Hppo12 Bg Bh | c1 lt1 Bc Bd Hppolt1f2 Bf Bg | f1 lt1 Bc Bd Hrk12 Hppolt1f2 Bg Bh | f1 lt1 Bc Bd Hrk12 Hprodppo12 Bg Bh ]; subst.

  + (* ppo_fun_in *)
    apply Hppo23; trivial.

  + (* ppo_fun_sub *)
    apply IH with (m:= term_size t1 + term_size t2 + term_size (fapply f3 lt3)) (t2 := t2); auto.
    apply plus_lt_compat_r; apply plus_lt_compat_l.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin2.
    apply le_lt_n_Sm; trivial.

  + (* ppo_constr_split *)
    apply ppo_constr_split.
    intros t1 Hin1.
    apply IH with (m:= term_size t1 + term_size (fapply f2 lt2) + term_size (fapply f3 lt3)) (t2 := fapply f2 lt2);
    auto.
    do 2 apply plus_lt_compat_r.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
    simpl; apply le_lt_n_Sm; trivial.

  + (* ppo_funlt_split *)
    apply ppo_funlt_split; try omega.
    intros t1 Hin1.
    apply IH with (m:= term_size t1 + term_size (fapply f2 lt2) + term_size (fapply f3 lt3)) (t2:=fapply f2 lt2);
    auto.
    do 2 apply plus_lt_compat_r.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
    simpl.
    apply le_lt_n_Sm.
    trivial.

  + (* ppo_funeqv_split *)
    apply ppo_funlt_split; try omega.
    intros t1 Hin1.
    apply product_Forall2 in Hprodppo12.
    apply Forall2_In_l with (x := t1) in Hprodppo12; trivial.
    destruct Hprodppo12 as ( t2 & Hin2 & [ Hppo12 | Heq12 ] ).

    * apply IH with (m:= term_size t1 + term_size t2 + term_size (fapply f3 lt3)) (t2 := t2); eauto.
      apply plus_lt_compat_r.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin2.
      simpl.
      auto with *.

    * subst.
      apply Hppo23.
      trivial.

- (* ppo_funeqv_split *)
  inversion H12 as [ | Ba Bb Bc Hin1 Be Bf | | Ba t2 Bc Bd Hin2 Hppo12 Bg Bh | c1 lt1 Bc Bd Hppolt1f2 Bf Bg | f1 lt1 Bc Bd Hrk12 Hppolt1f2 Bg Bh | f1 lt1 Bc Bd Hrk12 Hprodppo12 Bg Bh ];
  subst.

  + (* ppo_fun_in *)
    apply product_Forall2 in Hprodppo23.
    apply Forall2_In_l with (x := t1) in Hprodppo23; trivial.
    destruct Hprodppo23 as (t3 & Hin3 & [ Hppo13 | Heq13 ] ).

    * apply ppo_fun_sub with (t := t3); trivial.
    * apply ppo_fun_in; subst; trivial.

  + (* ppo_fun_sub *)
    apply product_Forall2 in Hprodppo23.
    apply Forall2_In_l with (x := t2) in Hprodppo23; trivial.
    destruct Hprodppo23 as (t3 & Hin3 & [ Hppo23 | Heq23 ] ).

    * apply ppo_fun_sub with (t := t3); trivial.
      apply IH with (m := term_size t1 + term_size t2 + term_size t3) (t2 := t2); trivial.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin2.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin3.
      simpl.
      auto with *.

    * subst.
      apply ppo_fun_sub with (t := t3); trivial.

  + (* ppo_constr_split *)
    apply ppo_constr_split.
    intros t1 Hin1.
    apply IH with (m := term_size t1 + term_size (fapply f2 lt2) + term_size (fapply f3 lt3)) (t2 := fapply f2 lt2);
    trivial.

    * do 2 apply plus_lt_compat_r.
      simpl.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
      apply le_lt_n_Sm.
      trivial.

    * apply Hppolt1f2.
      trivial.

  + (* ppo_funlt_split *)
    apply ppo_funlt_split; try omega.
    intros t1 Hin1.
    apply IH with (m := term_size t1 + term_size (fapply f2 lt2) + term_size (fapply f3 lt3)) (t2 := fapply f2 lt2);
    trivial.

    * do 2 apply plus_lt_compat_r.
      simpl.
      apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
      apply le_lt_n_Sm.
      trivial.

    * apply Hppolt1f2.
      trivial.

  + (* ppo_funeqv_split *)
    (* Il s’agit de prouver ici que product PPO est transitif. *)
    apply ppo_funeqv_split; try congruence.
    apply product_trans with (lt2 := lt2); trivial.
    intros t1 t2 t3 Hin1 Hin2 Hin3 Hppo12 Hppo23.
    apply IH with (t2 := t2) (m := term_size t1 + term_size t2 + term_size t3); trivial.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin1.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin2.
    apply (in_map (@term_size _ _ _)), in_le_suml in Hin3.
    simpl.
    auto with *.
Qed.

Lemma PPO_trans_eq t1 t2 t3 : clos_refl PPO t1 t2 -> PPO t2 t3 -> PPO t1 t3.
Proof.
intros [H12 | H12] H23.

- apply PPO_trans with t2; trivial.

- congruence.
Qed.

Lemma PPO_trans_eq_r t1 t2 t3 : PPO t1 t2 -> clos_refl PPO t2 t3 -> PPO t1 t3.
Proof.
  intros H12 [H23 | H23].

  - apply PPO_trans with t2; trivial.
  - congruence.
Qed.

Lemma PPO_asym t1 t2 : PPO t1 t2 -> ~ PPO t2 t1.
Proof.
remember (term_size t1 + term_size t2) as whole_size eqn: H_size.
revert t1 t2 H_size.
induction whole_size as [ whole_size IH ] using lt_wf_ind.
intros t1 t2 H_size Hppo12 Hppo21.
destruct t1 as [ x | c lt | f lt ].

- inversion Hppo21.

- inversion Hppo21 as [ Ba Bb Bc Hin Be Bf | | aa t ac ad Hin Hppo ag ah | | | | ]; subst.

  + inversion Hppo12 as [ aa c2 lt2 Hin2 ae af | aa f2 lt2 Hin2 ae af | aa t3 c3 lt3 Hin3 Hppo3 ag ah | aa t3 f3 lt3 Hin3 Hppo3 ag ah | aa ab f3 lt3 Hall af ag | | ]
    ; subst.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (capply c lt) + term_size (capply c lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (capply c lt) + term_size (capply c lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * assert (PPO t3 (capply c lt)) as Hppo. {
        apply PPO_trans with (t2 := capply c3 lt3); trivial.
        eapply ppo_constr_in.
        exact Hin3.
      }
      eapply IH with (m := term_size (capply c lt) + term_size t3) in Hppo; try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

    * assert (PPO t3 (capply c lt)) as Hppo. {
        apply PPO_trans with (t2 := fapply f3 lt3); trivial.
        eapply ppo_fun_in.
        exact Hin3.
      }
      eapply IH with (m := term_size (capply c lt) + term_size t3) in Hppo; try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * generalize Hin.
      intro Hin'.
      apply Hall in Hin.
      {apply IH with (m := term_size (fapply f3 lt3) + term_size (fapply f3 lt3)) in Hin; trivial.

      - assert (PPO (fapply f3 lt3) (fapply f3 lt3)) as H. {
        apply PPO_trans with (capply c lt); trivial.
        }
        tauto.

      - apply plus_lt_compat_r.
        apply in_capply_term_size_lt; trivial.
      }

  + inversion Hppo12 as [ aa c2 lt2 Hin2 ae af | aa f2 lt2 Hin2 ae af | aa t3 c3 lt3 Hin3 Hppo3 ag ah | aa t3 f3 lt3 Hin3 Hppo3 ag ah | aa ab f3 lt3 Hall af ag | | ]; subst.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (capply c lt) + term_size (capply c lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (capply c lt) + term_size (capply c lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * assert (PPO t3 (capply c lt)) as Hppo'. {
        apply PPO_trans with (t2 := capply c3 lt3); trivial.
        eapply ppo_constr_in.
        exact Hin3.
      }
      apply IH with (m := term_size (capply c lt) + term_size t3) in Hppo'; try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

    * assert (PPO t3 (capply c lt)) as Hppo'. {
        apply PPO_trans with (t2 := fapply f3 lt3); trivial.
        eapply ppo_fun_in.
        exact Hin3.
      }
      apply IH with (m := term_size (capply c lt) + term_size t3) in Hppo'; try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * generalize Hin.
      intro Hin'.
      apply Hall in Hin.
      apply IH with (m := term_size t + term_size (fapply f3 lt3)) in Hin; trivial; try tauto.
      apply plus_lt_compat_r.
      apply in_capply_term_size_lt; trivial.

- inversion Hppo21 as [ | aa ab ac Hin ae af | | aa t3 ac ad Hin Hppo ag ah | c3 lt3 ac ad Hall af ag | f3 lt3 ac ad Hrank Hall ag ah | f3 lt3 ac ad Hrank Hprod ag ah ];
  subst.

  + generalize (PPO_trans Hppo21 Hppo12).
    intro Hppo11.
    generalize Hppo11.
    intro Hppo11'.
    apply IH with (m := term_size t2 + term_size t2) in Hppo11; try tauto.
    apply plus_lt_compat_r.
    apply in_fapply_term_size_lt; trivial.

  + generalize Hin.
    intro Hin'.
    apply ppo_fun_in with (f := f) in Hin.
    generalize (PPO_trans Hin Hppo12).
    intro Hppo32.
    eapply IH in Hppo32; try tauto; try reflexivity.
    apply plus_lt_compat_r.
    apply in_fapply_term_size_lt; trivial.

  + inversion Hppo12 as [ aa ab ac Hin ae af | | aa t3 ac ad Hin Hppo ag ah | | | | ]; subst; try omega.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (fapply f lt) + term_size (fapply f lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

    * generalize Hin.
      intro Hin'.
      apply ppo_constr_in with (c := c3) in Hin.
      generalize (PPO_trans Hin Hppo21).
      intro Hppo31.
      apply IH with (m := term_size (fapply f lt) + term_size t3)in Hppo31;
       try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_capply_term_size_lt; trivial.

  + inversion Hppo12 as [ | aa ab ac Hin ae af | | aa t3 ac ad Hin Hppo ag ah | | | ]; subst; try omega.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (fapply f lt) + term_size (fapply f lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * generalize Hin.
      intro Hin'.
      apply ppo_fun_in with (f := f3) in Hin.
      generalize (PPO_trans Hin Hppo21).
      intro Hppo31.
      apply IH with (m := term_size (fapply f lt) + term_size t3)in Hppo31;
       try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

  + inversion Hppo12 as [ | aa ab ac Hin ae af | | aa t3 ac ad Hin Hppo ag ah | | | aa ab ac ad Hrank' Hprodrev ag ah ];
    subst; try omega.

    * generalize (PPO_trans Hppo12 Hppo21).
      intro Hppo11.
      generalize Hppo11.
      intro Hppo11'.
      apply IH with (m := term_size (fapply f lt) + term_size (fapply f lt)) in Hppo11; try tauto.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * generalize Hin.
      intro Hin'.
      apply ppo_fun_in with (f := f3) in Hin.
      generalize (PPO_trans Hin Hppo21).
      intro Hppo31.
      apply IH with (m := term_size (fapply f lt) + term_size t3)in Hppo31;
       try tauto; try ring.
      apply plus_lt_compat_l.
      apply in_fapply_term_size_lt; trivial.

    * set (term_default := fapply f [] : term).
    apply product_Exists2, (Exists2_exists term_default) in Hprod.
      destruct Hprod as ( i & Hlen & Hppoi ).
      assert (Hlen' : i < length lt).
      { apply product_length in Hprodrev.
        congruence.
      }
      apply product_Forall2 in Hprodrev.
      apply (Forall2_forall term_default) with (i := i) in Hprodrev; trivial.
      rename Hprodrev into Hppoeqi.

      { destruct Hppoeqi as [ Hpporevi | Hppoeqi ].

        - apply IH with (m := term_size (nth i lt3 term_default) + term_size (nth i lt term_default)) in Hppoi; trivial; try tauto.
          rewrite plus_comm.
          apply plus_lt_compat.

          + apply in_fapply_term_size_lt; trivial.
            apply nth_In; trivial.

          + apply in_fapply_term_size_lt; trivial.
            apply nth_In; trivial.

        - generalize Hppoi; intros Hppoibis.
          apply IH with (m := term_size (nth i lt3 term_default) + term_size (nth i lt term_default)) in Hppoi; trivial.

          + rewrite Hppoeqi in Hppoi, Hppoibis.
            tauto.

          + rewrite plus_comm.
            apply plus_lt_compat.

            * apply in_fapply_term_size_lt; trivial.
              apply nth_In; trivial.

            * apply in_fapply_term_size_lt; trivial.
              apply nth_In; trivial.
      }
Qed.

Lemma PPO_irrefl t : ~PPO t t.
Proof.
intro Hppo.
generalize Hppo.
intro Hppo'.
apply PPO_asym in Hppo.
tauto.
Qed.

Lemma PPO_term_pattern_subst p t s :
  PPO t (@term_from_pattern _ _ _ p) ->
  PPO (subst s t) (@term_from_value _ _ _ (psubst s p)).
Proof.
  revert t s.
  induction p as [ v | c lp IH ] using pattern_ind2;
    intros t s Hppo;
    [ solve [inversion Hppo] | idtac ].
  inversion Hppo as [ aa ab ac Hin ae af | | aa t' ac ad Hin Hppo' ag ah | | | | ]; subst.

  - (* ppo_constr_in *)
    rewrite in_map_iff in Hin.
    destruct Hin as (p & Heq & Hin).
    subst t.
    apply ppo_constr_in.
    rewrite in_map_iff.
    exists (psubst s p).
    split.

    + symmetry.
      apply subst_psubst.

    + apply in_map.
      assumption.

  - (* ppo_constr_sub *)
    rewrite in_map_iff in Hin.
    destruct Hin as (p & Heq & Hin).
    subst t'.
    apply ppo_constr_sub with (t := @term_from_value _ _ _ (psubst s p)).

    + do 2 apply in_map; assumption.

    + apply IH; assumption.
Qed.

Lemma fapply_not_PPO_value f lt v :
  term_value v -> ~ PPO (fapply f lt) v.
Proof.
  revert f lt.
  induction v as [ | c lv IH | f' lt' ] using term_ind2; intros f lt Hval Hppo; simpl in Hval; try tauto.
  rewrite <- forall_andl in Hval; rewrite Forall_forall in Hval.
  inversion Hppo as [ Ba Bb Bc Hin Be Bf | | Ba v Bc Bd Hin Hpposub Bg Bh | | | | ]; subst.
  - apply Hval in Hin.
    simpl in Hin.
    assumption.
  - apply IH in Hpposub; trivial.
    apply Hval.
    trivial.
Qed.

Lemma fapply_not_PPO_pattern f lt p :
  ~ PPO (fapply f lt) (@term_from_pattern _ _ _ p).
Proof.
  revert f lt.
  induction p as [ v | c lp IH ] using pattern_ind2;
    intros f lt Hppo;
    [ solve [ inversion Hppo ] | idtac ].
  inversion Hppo as [ aa ab ac Hin ae af | | aa t ac ad Hin Hppo' ag ah | | | | ]; subst.

  - rewrite in_map_iff in Hin.
    destruct Hin as ( p & Heq & _ ).
    destruct p; discriminate Heq.

  - rewrite in_map_iff in Hin.
    destruct Hin as ( p & Heq & Hin ).
    subst t.
    revert Hppo'.
    apply IH.
    assumption.
Qed.

Lemma PPO_rule_PPO_instance s f lp t :
  PPO_rule (rule_intro f lp t) ->
  PPO (subst s t) (fapply f (map (@term_from_value _ _ _) (map (psubst s) lp))).
Proof.
induction t as [ x | c lt IH | g lt IH ] using term_ind2; intro Hppo.

- apply value_PPO_function.

- apply ppo_constr_split.
  intros t Hin.
  rewrite in_map_iff in Hin.
  destruct Hin as (t' & Hsubst & Hin).
  fold (subst s t') in Hsubst.
  subst t.
  apply IH; trivial.
  simpl in *.
  apply PPO_trans with (capply c lt); trivial.
  apply ppo_constr_in; trivial.

- inversion Hppo as [ | aa ab ac Hin ae af | | aa t ac ad Hin Hppo' ag ah | | aa ab ac ad Hrank Hppo' ag ah | aa ab ac ad Hrank Hproduct ag ah];
   clear Hppo; subst.

  + rewrite in_map_iff in Hin.
    destruct Hin as (p & Heq & Hin).
    destruct p; simpl in Heq; congruence.

  + rewrite in_map_iff in Hin.
    destruct Hin as (p & Heq & Hin).
    subst t.
    exfalso; revert Hppo'.
    apply fapply_not_PPO_pattern.

  + apply ppo_funlt_split; trivial.
    intros t Hin.
    rewrite in_map_iff in Hin.
    destruct Hin as (t' & Heq & Hin).
    fold (subst s t') in Heq.
    subst t.
    apply IH; trivial.
    apply Hppo'; trivial.

  + apply ppo_funeqv_split; trivial.
    clear Hrank IH.
    revert lp Hproduct.
    induction lt as [ | t lt IH ]; intros lp Hproduct; try solve[inversion Hproduct].
    destruct lp as [ | p lp ]; try solve[inversion Hproduct].
    inversion Hproduct as [ aa ab ac ad ae Hproduct' ag ah | aa ab ac ad Hppo Hforall ag ah ];
     clear Hproduct; subst.

    * apply IH in Hproduct'.
      clear IH.
      apply product_conseq; trivial.
      apply subst_psubst.

    * clear IH.
      { apply product_consst.

      - apply PPO_term_pattern_subst; trivial.

      - change (
          Forall2 (clos_refl PPO) (map (subst s) lt)
            (map (@term_from_value _ _ _) (map (psubst s) lp))
        ).
        revert lp Hforall.
        induction lt as [ | t' lt IH ]; intros lp Hforall;
         destruct lp as [ | p' lp ]; trivial; try solve[inversion Hforall].
        apply Forall2_cons.

        + inversion Hforall as [ | aa ab ac ad Hclos Hforall' ag ah ]; subst.
          destruct Hclos as [ Hppo' | Heq' ].

          * left.
            apply PPO_term_pattern_subst.
            assumption.

          * right.
            subst t'.
            apply subst_psubst.

        + apply IH.
          inversion Hforall; trivial.
      }
Qed.

Lemma PPO_rule_instance i s p c1 t c2 v :
  PPO_prog ->
  wf (cbv_update i s p c1 t c2 v) ->
  PPO (proj_left p) t.
Proof.
  simpl; intros Hppoprog Hwf.
  destruct t; try tauto.
  destruct Hwf as (_ & lp & t & Hi & Hrule & Heqlt & Heqp_l & _).
  rewrite Heqp_l; rewrite Heqlt.
  apply PPO_rule_PPO_instance.
  apply Hppoprog.
  rewrite <- Hrule.
  apply nth_In.
  assumption.
Qed.

Definition activation_rank (p : cbv) : nat :=
  match p with
  | cbv_update _ _ _ _ (fapply f _) _ _ => rank f
  | _                                   => 0
  end.

Lemma fapplies_rec_PPO t t': In t (fapplies_in_term t') -> clos_refl PPO t t'.
Proof.
  revert t.
  induction t' as [ | c lt' IH | f lt' IH ] using term_ind2; intros t Hin.
  - simpl in *.
    exfalso; assumption.
  - left.
    simpl in *.
    apply in_flat_map in Hin.
    destruct Hin as ( t' & Hint' & Hint ).
    destruct (IH t' Hint' t Hint) as [ Hppo | Heq ].
    + apply PPO_trans with (t2 := t'); trivial.
      constructor.
      trivial.
    + subst; constructor; trivial.
  - simpl in Hin.
    destruct Hin as [ Heq | Hin ].
    + right; symmetry; trivial.
    + left.
      apply in_flat_map in Hin.

      destruct Hin as ( t' & Hint' & Hint ).
      destruct (IH t' Hint' t Hint) as [ Hppo | Heq ].
      * apply PPO_trans with (t2 := t'); trivial.
        constructor.
        trivial.
      * subst; constructor; trivial.
Qed.

Lemma PPO_value_is_value t v : PPO t v -> term_value v -> term_value t.
Proof.
  revert t.
  induction v as [ | c lv IH | ] using term_ind2; intros t Hppo Hvalv;
  [ inversion Hppo | idtac | inversion Hvalv ].
  inversion Hppo as [ Ba Bb Bc Hin Be Bf | | Ba s Bc Bd Hin Hppos Bg Bh | | | | ]; subst.

  - simpl in Hvalv.
    apply andl_in with (l := map (@term_value _ _ _) lv); trivial.
    apply in_map; assumption.

  - apply IH with (t := s); trivial.
    simpl in Hvalv.
    apply andl_in with (l := map (@term_value _ _ _) lv); trivial.
    apply in_map; assumption.
Qed.

Lemma PPO_activation_le_rank f1 lt1 f2 lv2 :
  PPO (fapply f1 lt1) (fapply f2 (map (@term_from_value _ _ _) lv2)) -> rank f1 <= rank f2.
Proof.
  remember (term_size (fapply f1 lt1) + term_size (fapply f2 (map (@term_from_value variable function constructor) lv2))) as whole_size eqn: Hsize.
  revert f1 lt1 f2 lv2 Hsize.
  induction whole_size as [ whole_size IH ] using lt_wf_ind.
  intros f1 lt1 f2 lv2 Hsize Hppo.
  inversion Hppo as [ | Ba Bb Bc Hin Be Bf | | Ba v Bc Bd Hin Hpposub Bh Bi | | | ]; subst.
  - (* Impossible car les lt2 sont des valeurs *)
    apply in_map_iff in Hin; destruct Hin as (v & Heqv & Hv).
    contradict Heqv; apply term_from_value_not_fapply.

  - apply in_map_iff in Hin; destruct Hin as (v' & Heqv' & Hv').
    subst v.
    contradict Hpposub; apply fapply_not_PPO_value.
    apply term_value_eqv; eauto.

  - apply lt_le_weak; assumption.

  - apply le_lt_or_eq_iff; right; assumption.
Qed.

Lemma PPO_pattern_le_rank f1 lt1 f2 lp2 :
  PPO (fapply f1 lt1) (fapply f2 (map (@term_from_pattern _ _ _) lp2)) -> rank f1 <= rank f2.
Proof.
  remember (term_size (fapply f1 lt1) + term_size (fapply f2 (map (@term_from_pattern variable function constructor) lp2))) as whole_size eqn: Hsize.
  revert f1 lt1 f2 lp2 Hsize.
  induction whole_size as [ whole_size IH ] using lt_wf_ind.
  intros f1 lt1 f2 lv2 Hsize Hppo.
  inversion Hppo as [ | Ba Bb Bc Hin Be Bf | | Ba v Bc Bd Hin Hpposub Bh Bi | | | ]; subst.
  - (* Impossible car les lt2 sont des valeurs *)
    apply in_map_iff in Hin; destruct Hin as (v & Heqv & Hv).
    contradict Heqv. apply term_from_pattern_not_fapply.

  - apply in_map_iff in Hin; destruct Hin as (v' & Heqv' & Hv').
    subst v.
    contradict Hpposub; apply fapply_not_PPO_pattern.

  - apply lt_le_weak; assumption.

  - apply le_lt_or_eq_iff; right; assumption.
Qed.

Lemma subfapplies_activation_le_rank i s p c1 f lt c2 v f' lt' :
  let proof_tree := cbv_update i s p c1 (fapply f lt) c2 v in
  PPO_prog -> wf proof_tree ->
  In (fapply f' lt') (fapplies_in_term (proj_left p)) ->
  rank f' <= rank f.
Proof.
  intros proof_tree Hppoprog Hwf Hin.
  assert (PPO (fapply f' lt') (fapply f lt)) as Hppo.
  - apply PPO_trans_eq with (t2 := proj_left p).
    + apply fapplies_rec_PPO.
      trivial.
    + apply (PPO_rule_instance i s p c1 (fapply f lt) c2 v); assumption.

  - assert (Hltval : Forall (@term_value _ _ _) lt).
    {
      destruct Hwf as (_ & lp & _ & _ & _ & Heqlt & _ & _ & _ & _ & _ & _ & _).
      clear i p c1 f c2 v f' lt' proof_tree Hppoprog Hin Hppo.
      revert lp Heqlt;
        induction lt as [ | t lt IH ]; intros lp Heqlt;
        constructor;
        rewrite map_map in Heqlt;
        destruct lp as [ | p lp ]; [ discriminate | idtac | discriminate | idtac ].

      - rewrite term_value_eqv.
        exists (psubst s p).
        injection Heqlt.
        intros; assumption.

      - apply IH with (lp := lp).
        rewrite map_map.
        injection Heqlt; intros; assumption.
    }

    clear i s p c1 c2 v proof_tree Hppoprog Hwf Hin.
    inversion Hppo as [ | | | Ba t Bc Bd Hin Hppot Bg Bh | | | ]; subst.

    + (* ppo_fun_in : absurde *)
      assert (Himp : term_value (fapply f' lt')).
      { apply Forall_In_l with (xs := lt); assumption. }
      inversion Himp.

    + (* ppo_fun_sub : absurde *)
      exfalso.
      generalize Hppot.
      apply fapply_not_PPO_value.
      apply Forall_In_l with (xs := lt); assumption.

    + (* ppo_funlt_split *)
      apply lt_le_weak; assumption.

    + (* ppo_funeqv_split *)
      apply Nat.eq_le_incl; assumption.
Qed.

Lemma le_rank_first_activation i s p c1 t c2 v p' :
  let proof_tree := cbv_update i s p c1 t c2 v in
  PPO_prog -> wf proof_tree ->
  In p' (first_activations proof_tree) ->
  activation_rank p' <= activation_rank proof_tree.
Proof.
  intros proof_tree Hppoprog Hwf Hinfst.
  apply incl_first_activations_semi in Hinfst.
  generalize Hwf; intros Hfor2.
  apply first_activations_residues_activation in Hfor2; trivial.
  apply Forall2_In_l with (x:= p') in Hfor2 as (t' & Hinfapp & Hfor2); trivial.
  assert (exists f' lt', t' = fapply f' lt') as (f' & lt' & Heqt'). {
    apply fapplies_in_term_are_fapplies with (t2 := proj_left p);
    tauto.
  }
  transitivity (rank f').
  - subst.
    assert (wf p') as Hwfp'. {
      apply wf_InCBV_wf with (proof_tree := proof_tree); try assumption.
        apply InCBV_In_sub_trees, first_activations_and_semi_incl_sub_trees; assumption.
    }
    destruct p' as [ | | i' s' p'' c1' t'' c2' v'' | ] ; simpl; try apply le_0_n.
    simpl in *.
    destruct t''; try tauto.
    destruct Hfor2 as [ Heqf _ ].
    subst; auto.
  - subst t'.
    simpl.
    generalize Hwf; intros Hwf'; simpl in Hwf'.
    destruct t as [ | | f lt ]; try tauto.
    apply (@subfapplies_activation_le_rank i s p c1 f lt c2 v f' lt'); tauto.
Qed.

Lemma PPO_first_activations i s p c1 t c2 v p' :
  let proof_tree := cbv_update i s p c1 t c2 v in
  PPO_prog -> wf proof_tree ->
  In p' (first_activations proof_tree) ->
  PPO (proj_left p') (proj_left proof_tree).
Proof.
  intros proof_tree.
  unfold proof_tree.
  intros H_ppo H_wf H_p'.
  destruct t as [ | | f lv ]; try (simpl in H_wf; tauto).
  simpl.
  generalize H_p'.
  intros H_rank; apply le_rank_first_activation in H_rank; trivial.
  apply le_lt_or_eq in H_rank.
  assert ( exists f' lv', proj_left p' = fapply f' lv' ) as H_p'_fapply.
  { apply first_activations_incl_activations in H_p'.
    generalize H_p'; intros Hwfp'.
    apply (activations_wf H_wf) in Hwfp'.
    apply activation_is_function in H_p'.
    destruct H_p' as (i' & s' & p'' & c1' & t' & c2' & v' & Heqp').
    subst p'; simpl.
    simpl in Hwfp'.
    destruct t' as [ | | f'' lt'' ] ; try tauto.
    exists f''; exists lt''; trivial.
  }

  destruct H_p'_fapply as (f' & lv' & H_p'_fapply).
  rewrite H_p'_fapply.

  destruct H_rank as [ H_rank | H_rank ].

  - apply first_activations_incl_activations in H_p'.
    destruct p' as [ | | i' s' p'' c1' t' c2' v'| ];
      try (apply activation_is_function in H_p';
           repeat match goal with
                    | H : exists _, _ |- _ => destruct H
                  end;
           discriminate).
    simpl in H_p'_fapply.
    subst t'.
    apply ppo_funlt_split; trivial.
    intros v'' Hin.
    generalize H_p'; intros Hwfp'.
    apply (activations_wf H_wf) in Hwfp'.
    destruct Hwfp' as (_ & lp & _ & _ & _ & Heqlv' & _).
    subst lv'.
    apply in_map_iff in Hin; destruct Hin as (v''' & Heqv'' & Hin).
    rewrite <- Heqv''.
    apply value_PPO_function.

  - generalize H_wf; intros Hresidues;
    apply first_activations_residues_activation in Hresidues; try assumption.
    generalize H_p'; intros Hin;
    apply incl_first_activations_semi in Hin.
    apply Forall2_In_l with (x := p') in Hresidues; [ clear Hin | assumption ].
    destruct Hresidues as (t & Hin & Hresidues).
    rewrite H_p'_fapply in Hresidues.
    destruct t as [ | | f'' lt ]; try tauto.
    destruct Hresidues as [ Heqf Hlooklt ]; subst f''.
    generalize H_p'; intros Hactp';
    apply first_activations_incl_activations in Hactp'.
    generalize Hactp'; intros Hwfp';
    apply (@activations_wf _ _ _ _ _ _ _ _ _ _ _ H_wf) in Hwfp'.
    apply activation_is_function in Hactp'.
    destruct Hactp' as ( i' & s' & p'' & c1' & t' & c2' & v' & Heqp' ).
    subst p'.
    simpl in H_p'_fapply; subst t'.
    simpl in H_rank; simpl in Hlooklt.

    assert (Hppofapp: PPO (fapply f' lt) (fapply f lv)). {
      apply PPO_trans_eq with (t2 := proj_left p).
      - apply fapplies_rec_PPO; assumption.
      - apply (PPO_rule_instance i s p c1 (fapply f lv) c2 v); assumption.
    }

    apply PPO_trans_eq with (t2 := fapply f' lt); [ idtac | assumption ].
    right; f_equal.

    assert (Hltval: Forall (@term_value _ _ _) lt).
    {
      simpl in H_wf.
      destruct H_wf as (_ & lp & _ & _ & _ & Hlvval & _).
      clear i p c1 c2 v proof_tree H_ppo lv' Hin i' s' p'' c1' c2' v' H_p' Hlooklt Hwfp'.
      inversion Hppofapp as [ | Ba Bb Bc Hinval | | Ba v Bc Bd Hin Hppoval Bg Bh | | Ba Bb Bc Bd Hranklt Bf Bg Bh | Ba Bb Bc Bd Be Hprodppo Bg Bh];
        subst.

      - exfalso.
        rewrite in_map_iff in Hinval.
        destruct Hinval as (v & Heq & _).
        destruct v; discriminate.

      - exfalso.
        revert Hppoval.
        apply fapply_not_PPO_value.
        apply term_value_eqv.
        apply in_map_iff in Hin.
        destruct Hin as (v' & Heq & _).
        exists v'; symmetry; assumption.

      - exfalso.
        rewrite H_rank in Hranklt; revert Hranklt.
        apply lt_irrefl.

      - apply product_Forall2 in Hprodppo.
        revert Hprodppo; clear; revert lp.
        induction lt as [ | t lt IH ]; intros lp Hfor2; constructor.
        + inversion Hfor2 as [ | Ba v Bc lv Hppot Hppolt Bg Heq ]; subst.
          destruct Hppot as [ Hppot | Heqt ];
            [ (apply PPO_value_is_value with (v := v); trivial) | subst t ];
            ( destruct lp as [ | p lp ]; simpl in Heq; [ discriminate | idtac ];
              injection Heq; intros _ Heqv;
              apply term_value_eqv;
              exists (psubst s p); assumption ).

        + destruct lp as [ | p lp ].
          * simpl in Hfor2.
            inversion Hfor2.
          * apply IH with (lp := lp).
            inversion Hfor2; assumption.
    }

    revert Hltval Hlooklt; clear; revert lv'.
    induction lt as [ | t lt IH ];
      intros lv Hltval Hlooklt;
      inversion Hlooklt as [ | Ba Bb Bc lv' Be Hlooklt_tl Bg Bh];
      trivial;
      subst.
    f_equal.

    + inversion Hltval as [ | Ba Bb Htval ]; subst.
      apply term_value_eqv in Htval; destruct Htval; subst t.
      apply cache_lookup_value.
    + apply IH; [ inversion Hltval | idtac ]; assumption.
Qed.

Lemma PPO_activations i s p c1 t c2 v p' :
  let proof_tree := cbv_update i s p c1 t c2 v in
  PPO_prog -> wf proof_tree ->
  In p' (activations proof_tree) ->
  p' = proof_tree \/ PPO (proj_left p') (proj_left proof_tree).
Proof.
  revert p'.
  apply cbv_big_induction; try tauto.
  clear i s p c1 t c2 v.
  intros i s p c1 t c2 v Hbig p' proof_tree Hppoprg Hwf Hin.
  unfold proof_tree in Hin;
    rewrite -> activations_first_activations in Hin.
  apply in_inv in Hin.
  destruct Hin as [ Heq | Hin ]; [ left; symmetry; assumption | right ].
  apply in_flat_map in Hin.
  destruct Hin as (p'' & Hinfst & Hin).
  apply PPO_trans_eq with (t2 := proj_left p'');
    [ idtac | apply PPO_first_activations; assumption ].
  assert (Hgen : p' = p'' \/ PPO (proj_left p') (proj_left p'') -> clos_refl PPO (proj_left p') (proj_left p'')).
  { intros H.
    destruct H as [ Heq | Hppo ];
      [ subst; right; trivial | left; assumption ].
  }
  apply Hgen; clear Hgen.
  apply Hbig; try assumption.
  apply activations_wf with (proof_tree := proof_tree); try assumption.
  apply first_activations_incl_activations; assumption.
Qed.

End Ordering.

Lemma same_rank_same_prod vv ff cc lt ls rk rk':
  (forall t s, In t lt -> In s ls ->
      (forall f, In f (functions_of_term t) -> rk f = rk' f) ->
      (forall f, In f (functions_of_term s) -> rk f = rk' f) ->
      PPO rk t s -> PPO rk' t s) ->
  (forall f, In f (flat_map (@functions_of_term vv ff cc) lt) -> rk f = rk' f) ->
  (forall f, In f (flat_map (@functions_of_term _ _ _) ls) -> rk f = rk' f) ->
  product (PPO rk) lt ls -> product (PPO rk') lt ls.
Proof.
intros. assert (length lt = length ls).
- apply product_length in H2; trivial.
- revert H0 H1. induction H2; intros.
  + apply product_conseq; auto.
    apply IHproduct; auto; intros.
    * apply H; simpl; auto.
    * apply H1. simpl. rewrite in_app_iff. auto.
    * apply H4. simpl. rewrite in_app_iff. auto.
  + apply product_consst; auto.
    * {
        apply H; simpl; auto; intros.
        - apply H2. simpl. rewrite in_app_iff. auto.
        - apply H4. simpl. rewrite in_app_iff. auto.
      }
    * {
        induction H1; auto. apply Forall2_cons.
        - unfold clos_refl. unfold clos_refl in H1. destruct H1.
          + left. apply H; simpl; auto; intros.
            * apply H2. simpl. repeat (rewrite in_app_iff). auto.
            * apply H4. simpl. repeat (rewrite in_app_iff). auto.
          + right. auto.
        - apply IHForall2; simpl; intros.
          + apply H; simpl; auto.
            * destruct H6; auto.
            * destruct H7; auto.
          + simpl in H3. omega.
          + apply H2. simpl. repeat (rewrite in_app_iff).
            rewrite in_app_iff in H6. destruct H6; auto.
          + apply H4. simpl. repeat (rewrite in_app_iff).
            rewrite in_app_iff in H6. destruct H6; auto.
      }
Qed.

Hint Constructors PPO.

Lemma same_rank_same_ppo vv ff cc (t : term vv ff cc) s rk rk':
  (forall f, In f (functions_of_term t) -> rk f = rk' f) ->
  (forall f, In f (functions_of_term s) -> rk f = rk' f) ->
  PPO rk t s -> PPO rk' t s.
Proof.
remember (term_size t + term_size s) as whole_size eqn: H_size.
revert t s H_size.
induction whole_size as [whole_size IH] using lt_wf_ind.
intros t s H_size H H0 Hppo.
inversion Hppo; subst.
- auto.
- auto.
- apply ppo_constr_sub with (t:=t0); auto.
  apply IH with (m:=term_size t + term_size t0); auto.
  + apply plus_lt_compat_l.
    apply (in_map (@term_size _ _ _)), in_le_suml in H1.
    apply le_lt_n_Sm; auto.
  + intros. apply H0. simpl. rewrite in_flat_map.
    exists t0. auto.
- apply ppo_fun_sub with (t:=t0); auto.
  apply IH with (m:=term_size t + term_size t0); auto.
  + apply plus_lt_compat_l.
    apply (in_map (@term_size _ _ _)), in_le_suml in H1.
    apply le_lt_n_Sm; auto.
  + intros. apply H0. simpl. right. rewrite in_flat_map.
    exists t0. auto.
- apply ppo_constr_split. intros.
  apply IH with (m:=term_size s + term_size (fapply f lt)); auto.
  + apply plus_lt_compat_r.
    apply (in_map (@term_size _ _ _)), in_le_suml in H2.
    apply le_lt_n_Sm; auto.
  + intros. apply H. simpl. rewrite in_flat_map.
    exists s. auto.
- apply ppo_funlt_split.
  + replace (rk' g) with (rk g). replace (rk' f) with (rk f).
    * trivial.
    * apply H0. simpl. auto.
    * apply H. simpl. auto.
  + intros. apply IH with (m:=term_size s + term_size (fapply f lt)); auto.
    * apply plus_lt_compat_r.
      apply (in_map (@term_size _ _ _)), in_le_suml in H3.
      apply le_lt_n_Sm; auto.
    * intros. apply H. simpl. right. rewrite in_flat_map.
      exists s. auto.
- apply ppo_funeqv_split.
  + replace (rk' g) with (rk g). replace (rk' f) with (rk f).
    * trivial.
    * apply H0. simpl. auto.
    * apply H. simpl. auto.
  + apply same_rank_same_prod with (rk:=rk); auto; intros.
    * apply IH with (m:=term_size t + term_size s); auto.
      {
        apply plus_lt_compat.
        - apply (in_map (@term_size _ _ _)), in_le_suml in H3.
          apply le_lt_n_Sm; auto.
        - apply (in_map (@term_size _ _ _)), in_le_suml in H4.
          apply le_lt_n_Sm; auto.
      }
    * apply H. simpl. auto.
    * apply H0. simpl. auto.
Qed.

Lemma same_rank_same_ppo_rule vv ff cc f lp (t : term vv ff cc) rk rk':
  rk f = rk' f ->
  (forall g, g ∈ (functions_of_term t) -> rk g = rk' g) ->
  PPO rk t (fapply f (map (@term_from_pattern _ _ _) lp)) ->
  PPO rk' t (fapply f (map (@term_from_pattern _ _ _) lp)).
Proof.
intros. apply same_rank_same_ppo with (rk:=rk); auto.
intro. simpl. intro. destruct H2.
- subst. auto.
- rewrite no_funcs_in_patterns in H2. simpl in H2. now exfalso.
Qed.

Ltac ppo variable_eq_dec function_eq_dec constructor_eq_dec :=
match goal with
| |- PPO ?rk ?t1 ?t2 =>
    let t := eval compute in (@PPO_dec _ _ _ variable_eq_dec function_eq_dec constructor_eq_dec rk t1 t2) in
    match t with
    | left ?H => try exact H
    | _ => let t := constr:(pair t1 t2) in idtac t
    end
end.