(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.reals.IVT.
Import CRing_Homomorphisms.coercions.

(**
* Roots of polynomials of odd degree *)

Section CPoly_Big.

(**
** Monic polynomials are positive near infinity
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)

Variable R : COrdField.

(* begin hide *)
Let RX := (cpoly R).
(* end hide *)

Lemma Cbigger : forall x y : R, {z : R | x [<=] z | y [<=] z}.
Proof.
 intros.
 elim (less_cotransitive_unfolded _ x (x[+][1]) (less_plusOne _ _) y); intro.
  exists (y[+][1]); apply less_leEq.
   apply less_leEq_trans with y. auto. apply less_leEq; apply less_plusOne.
    apply less_plusOne.
 exists (x[+][1]); apply less_leEq.
  apply less_plusOne.
 auto.
Qed.

Lemma Ccpoly_big : forall (p : RX) n, 0 < n ->
 monic n p -> forall Y, {X : R | forall x, X [<=] x -> Y [<=] p ! x}.
Proof.
 intro. elim p.
 unfold monic in |- *. simpl in |- *. intros. elim H0. intros H1 H2.
  cut ([0][~=] ([1]:R)). intro. elim (H3 H1).
   apply ap_imp_neq. apply ap_symmetric_unfolded. apply ring_non_triv.
  intros c q. intros H n H0 H1 Y.
 elim (O_or_S n); intro y. elim y. intro m. intro y0.
  rewrite <- y0 in H1.
  elim (zerop m); intro y1. simpl in |- *.
   exists (Y[-]c). intros.
   rewrite y1 in H1.
   apply shift_leEq_plus'.
   cut (q ! x [=] [1]). intro.
    astepr (x[*][1]). astepr x. auto.
    apply monic_one with c. auto.
   cut (monic m q). intro H2.
   elim (Cbigger [0] (Y[-]c)). intro Y'. intros H3 H4.
   elim (H m y1 H2 Y'). intro X'. intro H5.
   simpl in |- *.
   elim (Cbigger [1] X'). intro X. intros H6 H7.
   exists X. intros.
   apply shift_leEq_plus'.
   apply leEq_transitive with ([1][*]Y').
    astepr Y'. auto.
    apply mult_resp_leEq_both; auto.
     apply less_leEq. apply pos_one.
     apply leEq_transitive with X; auto.
   change (Y' [<=] q ! x) in |- *.
   apply H5.
   apply leEq_transitive with X; auto.
  apply monic_cpoly_linear with c; auto.
 rewrite <- y in H0.
 elim (lt_irrefl _ H0).
Qed.

Lemma cpoly_pos : forall (p : RX) n, 0 < n -> monic n p -> {x : R | [0] [<=] p ! x}.
Proof.
 intros.
 elim (Ccpoly_big _ _ H H0 [0]). intros x H1.
 exists (x[+][1]).
 apply H1. apply less_leEq. apply less_plusOne.
Qed.

Lemma Ccpoly_pos' : forall (p : RX) a n, 0 < n -> monic n p -> {x : R | a [<] x | [0] [<=] p ! x}.
Proof.
 intros.
 elim (Ccpoly_big _ _ H H0 [0]). intro x'. intro H1.
 elim (Cbigger (a[+][1]) x'). intro x. intros.
 exists x; auto.
 apply less_leEq_trans with (a[+][1]).
  apply less_plusOne. auto.
Qed.

End CPoly_Big.

Section Flip_Poly.

(**
** Flipping a polynomial
%\begin{convention}% Let [R] be a ring.
%\end{convention}%
*)

Variable R : CRing.

Add Ring R: (CRing_Ring R).

(* begin hide *)
Let RX := (cpoly R).
(* end hide *)

Fixpoint flip (p : RX) : RX :=
  match p with
  | cpoly_zero _     => cpoly_zero _
  | cpoly_linear _ c q => cpoly_inv _ (cpoly_linear _ c (flip q))
  end.

Lemma flip_poly : forall (p : RX) x, (flip p) ! x [=] [--]p ! ( [--]x).
Proof.
 intro p. elim p.
 intros. simpl in |- *. algebra.
  intros c q. intros.
 change ( [--]c[+]x[*] (cpoly_inv _ (flip q)) ! x [=] [--] (c[+][--]x[*]q ! ( [--]x))) in |- *.
 astepl ( [--]c[+]x[*][--] (flip q) ! x).
 astepl ( [--]c[+]x[*][--][--]q ! ( [--]x)).
 ring.
Qed.

Lemma flip_coefficient : forall (p : RX) i,
 nth_coeff i (flip p) [=] [--] ( [--][1][^]i) [*]nth_coeff i p.
Proof.
 intro p. elim p.
 simpl in |- *. algebra.
  intros c q. intros.
 elim i. simpl in |- *. ring.
  intros. simpl in |- *.
 astepl ( [--] (nth_coeff n (flip q))).
 astepl ( [--] ( [--] ( [--][1][^]n) [*]nth_coeff n q)).
 simpl in |- *. ring.
Qed.

Hint Resolve flip_coefficient: algebra.

Lemma flip_odd : forall (p : RX) n, odd n -> monic n p -> monic n (flip p).
Proof.
 unfold monic in |- *. unfold degree_le in |- *.
 intros.
 elim H0. clear H0. intros.
 split.
  astepl ( [--] ( [--][1][^]n) [*]nth_coeff n p).
  astepl ( [--][--] ([1][^]n) [*]nth_coeff n p).
  astepl ([1][^]n[*]nth_coeff n p).
  astepl ([1][*]nth_coeff n p).
  Step_final ([1][*] ([1]:R)).
 intros.
 astepl ( [--] ( [--][1][^]m) [*]nth_coeff m p).
 Step_final ( [--] ( [--][1][^]m) [*] ([0]:R)).
Qed.

End Flip_Poly.

#[global]
Hint Resolve flip_poly: algebra.

Section OddPoly_Signs.

(**
** Sign of a polynomial of odd degree
%\begin{convention}% Let [R] be an ordered field.
%\end{convention}%
*)

Variable R : COrdField.

(* begin hide *)
Let RX := (cpoly R).
(* end hide *)

Lemma oddpoly_pos : forall (p : RX) n, odd n -> monic n p -> {x : R | [0] [<=] p ! x}.
Proof.
 intros.
 apply cpoly_pos with n; auto.
 elim H. intros. auto with arith.
Qed.

Lemma oddpoly_pos' : forall (p : RX) a n,
 odd n -> monic n p -> {x : R | a [<] x | [0] [<=] p ! x}.
Proof.
 intros.
 elim (Ccpoly_pos' _ p a n). intros x H1 H2.
   exists x; assumption.
  elim H; auto with arith.
 assumption.
Qed.

Lemma oddpoly_neg : forall (p : RX) n, odd n -> monic n p -> {x : R | p ! x [<=] [0]}.
Proof.
 intros.
 elim (oddpoly_pos _ _ H (flip_odd _ _ _ H H0)). intro x. intros.
 exists ( [--]x).
 astepl ( [--][--]p ! ( [--]x)). astepr ( [--] ([0]:R)).
 apply inv_resp_leEq.
 astepr (flip _ p) ! x. auto.
Qed.

End OddPoly_Signs.

Section Poly_Norm.

(**
** The norm of a polynomial
%\begin{convention}% Let [R] be a field, and [RX] the polynomials over
this field.
%\end{convention}%
*)

Variable R : CField.
(* begin hide *)
Let RX := cpoly_cring R.
(* end hide *)

Lemma poly_norm_aux : forall (p : RX) n, degree n p -> nth_coeff n p [#] [0].
Proof.
 unfold degree in |- *. intros p n H.
 elim H. auto.
Qed.

Definition poly_norm p n H := _C_ ([1][/] _[//]poly_norm_aux p n H) [*]p.

Lemma poly_norm_monic : forall p n H, monic n (poly_norm p n H).
Proof.
 unfold poly_norm in |- *. unfold monic in |- *. unfold degree in |- *. unfold degree_le in |- *. intros.
 elim H. intros H0 H1.
 split.
  Step_final (([1][/] nth_coeff n p[//]poly_norm_aux p n (pair H0 H1)) [*] nth_coeff n p).
 intros.
 astepl (([1][/] nth_coeff n p[//]poly_norm_aux p n (pair H0 H1)) [*] nth_coeff m p).
 Step_final (([1][/] nth_coeff n p[//]poly_norm_aux p n H) [*][0]).
Qed.

Lemma poly_norm_apply : forall p n H x, (poly_norm p n H) ! x [=] [0] -> p ! x [=] [0].
Proof.
 unfold poly_norm in |- *. intros.
 apply mult_cancel_lft with ([1][/] nth_coeff n p[//]poly_norm_aux p n H).
  apply div_resp_ap_zero_rev. apply ring_non_triv.
  astepl ((_C_ ([1][/] nth_coeff n p[//]poly_norm_aux p n H)) ! x[*]p ! x).
 astepl (_C_ ([1][/] nth_coeff n p[//]poly_norm_aux p n H) [*]p) ! x.
 Step_final ([0]:R).
Qed.

End Poly_Norm.

Section OddPoly_Root.

(**
** Roots of polynomials of odd degree
Polynomials of odd degree over the reals always have a root. *)

Lemma oddpoly_root' : forall f n, odd n -> monic n f -> {x : IR | f ! x [=] [0]}.
Proof.
 intros.
 elim (oddpoly_neg _ f n); auto. intro a. intro H1.
 elim (oddpoly_pos' _ f a n); auto. intro b. intros H2 H3.
 cut {x : IR | a [<=] x /\ x [<=] b /\ f ! x [=] [0]}.
  intro H4.
  elim H4. clear H4. intros x H4.
  elim H4. clear H4. intros H4 H5.
  elim H5. clear H5. intros.
  exists x. auto.
  apply Civt_poly; auto.
 apply monic_apzero with n; auto.
Qed.

Lemma oddpoly_root : forall f n, odd n -> degree n f -> {x : IR | f ! x [=] [0]}.
Proof.
 intros f n H H0.
 elim (oddpoly_root' (poly_norm _ f n H0) n); auto.
  intros. exists x.
  apply poly_norm_apply with n H0; auto.
 apply poly_norm_monic; auto.
Qed.

Lemma realpolyn_oddhaszero : forall f, odd_cpoly _ f -> {x : IR | f ! x [=] [0]}.
Proof.
 unfold odd_cpoly in |- *.
 intros f H.
 elim H. clear H. intro n. intros H H0.
 cut (odd n).
  intro.
  elim (oddpoly_root f n H1 H0). intros. exists x. auto.
  apply Codd_to.
 assumption.
Qed.

End OddPoly_Root.


(* generated by Ott 0.31, locally-nameless from: Stlc.ott *)
Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
Require Import Ott.ott_list_core.

(** For F_p *)
Require Import Coqprime.elliptic.ZEll.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.ZArith.BinInt.

From STLCZK Require Import GaloisField.

Module Stlc_Ott(Import PF: GaloisField.GaloisField).
  Import PF.

  (** syntax *)
  Definition expvar : Set := var.

  Inductive op : Set :=
  | op_add : op
  | op_sub : op
  | op_mul : op
  | op_div : op
  | op_and : op
  | op_or : op
  | op_eq: op.

  Inductive typ : Set :=
  | ty_bool : typ
  | ty_field : typ
  | ty_arrow (T1:typ) (T2:typ).

  Inductive constant : Set :=
  | const_bool (b5:bool)
  | const_field (n5:Fp).

  Inductive exp : Set :=
  | tm_var_b (_:nat)
  | tm_var_f (x:expvar)
  | tm_abs (T:typ) (e:exp)
  | tm_app (e1:exp) (e2:exp)
  | tm_let (e1:exp) (e2:exp)
  | tm_constant (constant5:constant)
  | tm_binop (e1:exp) (op5:op) (e2:exp)
  | tm_not (e:exp)
  | tm_ifthenelse (e:exp) (e1:exp) (e2:exp).

  Definition typing_env : Set := list (atom*typ).
  Lemma eq_op: forall (x y : op), {x = y} + {x <> y}.
  Proof.
    decide equality; auto with ott_coq_equality arith.
  Defined.
  Hint Resolve eq_op : ott_coq_equality.
  Hint Resolve eq_field: ott_coq_equality.
  Lemma eq_bool: forall (x y: bool), {x = y} + {x <> y}.
  Proof.
    decide equality; auto.
  Qed.
  Hint Resolve eq_bool: ott_coq_equality.
  Lemma eq_typ: forall (x y : typ), {x = y} + {x <> y}.
  Proof.
    decide equality; auto with ott_coq_equality arith.
  Defined.
  Hint Resolve eq_typ : ott_coq_equality.
  Lemma eq_constant: forall (x y : constant), {x = y} + {x <> y}.
  Proof.
    decide equality; auto with ott_coq_equality arith.
  Defined.
  Hint Resolve eq_constant : ott_coq_equality.
  Lemma eq_exp: forall (x y : exp), {x = y} + {x <> y}.
  Proof.
    decide equality; auto with ott_coq_equality arith.
  Defined.
  Hint Resolve eq_exp : ott_coq_equality.

  (* EXPERIMENTAL *)
  (** auxiliary functions on the new list types *)
  (** library functions *)
  (** subrules *)
  Definition is_value_of_exp (e_5:exp) : bool :=
    match e_5 with
    | (tm_var_b nat) => false
    | (tm_var_f x) => false
    | (tm_abs T e) => (true)
    | (tm_app e1 e2) => false
    | (tm_let e1 e2) => false
    | (tm_constant constant5) => (true)
    | (tm_binop e1 op5 e2) => false
    | (tm_not e) => false
    | (tm_ifthenelse e e1 e2) => false
    end.

  (** arities *)
  (** opening up abstractions *)
  Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
    match e__6 with
    | (tm_var_b nat) => if (k === nat) then e_5 else (tm_var_b nat)
    | (tm_var_f x) => tm_var_f x
    | (tm_abs T e) => tm_abs T (open_exp_wrt_exp_rec (S k) e_5 e)
    | (tm_app e1 e2) => tm_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
    | (tm_let e1 e2) => tm_let (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec (S k) e_5 e2)
    | (tm_constant constant5) => tm_constant constant5
    | (tm_binop e1 op5 e2) => tm_binop (open_exp_wrt_exp_rec k e_5 e1) op5 (open_exp_wrt_exp_rec k e_5 e2)
    | (tm_not e) => tm_not (open_exp_wrt_exp_rec k e_5 e)
    | (tm_ifthenelse e e1 e2) => tm_ifthenelse (open_exp_wrt_exp_rec k e_5 e) (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
    end.

  Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

  (** terms are locally-closed pre-terms *)
  (** definitions *)

  (* defns LC_exp *)
  Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
  | lc_tm_var_f : forall (x:expvar),
      (lc_exp (tm_var_f x))
  | lc_tm_abs : forall (L:vars) (T:typ) (e:exp),
      ( forall x , x \notin  L  -> lc_exp  ( open_exp_wrt_exp e (tm_var_f x) )  )  ->
      (lc_exp (tm_abs T e))
  | lc_tm_app : forall (e1 e2:exp),
      (lc_exp e1) ->
      (lc_exp e2) ->
      (lc_exp (tm_app e1 e2))
  | lc_tm_let : forall (L:vars) (e1 e2:exp),
      (lc_exp e1) ->
      ( forall x , x \notin  L  -> lc_exp  ( open_exp_wrt_exp e2 (tm_var_f x) )  )  ->
      (lc_exp (tm_let e1 e2))
  | lc_tm_constant : forall (constant5:constant),
      (lc_exp (tm_constant constant5))
  | lc_tm_binop : forall (e1:exp) (op5:op) (e2:exp),
      (lc_exp e1) ->
      (lc_exp e2) ->
      (lc_exp (tm_binop e1 op5 e2))
  | lc_tm_not : forall (e:exp),
      (lc_exp e) ->
      (lc_exp (tm_not e))
  | lc_tm_ifthenelse : forall (e e1 e2:exp),
      (lc_exp e) ->
      (lc_exp e1) ->
      (lc_exp e2) ->
      (lc_exp (tm_ifthenelse e e1 e2)).
  (** free variables *)
  Fixpoint fv_exp (e_5:exp) : vars :=
    match e_5 with
    | (tm_var_b nat) => {}
    | (tm_var_f x) => {{x}}
    | (tm_abs T e) => (fv_exp e)
    | (tm_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
    | (tm_let e1 e2) => (fv_exp e1) \u (fv_exp e2)
    | (tm_constant constant5) => {}
    | (tm_binop e1 op5 e2) => (fv_exp e1) \u (fv_exp e2)
    | (tm_not e) => (fv_exp e)
    | (tm_ifthenelse e e1 e2) => (fv_exp e) \u (fv_exp e1) \u (fv_exp e2)
    end.

  (** substitutions *)
  Fixpoint subst_exp (e_5:exp) (x5:expvar) (e__6:exp) {struct e__6} : exp :=
    match e__6 with
    | (tm_var_b nat) => tm_var_b nat
    | (tm_var_f x) => (if eq_var x x5 then e_5 else (tm_var_f x))
    | (tm_abs T e) => tm_abs T (subst_exp e_5 x5 e)
    | (tm_app e1 e2) => tm_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
    | (tm_let e1 e2) => tm_let (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
    | (tm_constant constant5) => tm_constant constant5
    | (tm_binop e1 op5 e2) => tm_binop (subst_exp e_5 x5 e1) op5 (subst_exp e_5 x5 e2)
    | (tm_not e) => tm_not (subst_exp e_5 x5 e)
    | (tm_ifthenelse e e1 e2) => tm_ifthenelse (subst_exp e_5 x5 e) (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
    end.

  (** definitions *)
  Definition booleqb(a b: bool): bool :=
    match a, b with
    | true, true => true
    | false, false => true
    | _, _ => false
    end.

  Definition op_helper(o: op)(a b: constant): constant -> Prop :=
    match o, a, b with
    | op_add, const_field a, const_field b => fun e => e = const_field (pkplus a b)
    | op_sub, const_field a, const_field b => fun e => e = const_field (pksub a b)
    | op_mul, const_field a, const_field b => fun e => e = const_field (pkmul a b)
    | op_div, const_field a, const_field b => fun e => b <> 0:%p -> e = const_field (pkdiv a b)
    | op_and, const_bool a, const_bool b => fun e => e = const_bool (andb a b)
    | op_or, const_bool a, const_bool b => fun e => e = const_bool (orb a b)
    | op_eq, const_bool a, const_bool b => fun e => e = const_bool (booleqb a b)
    | op_eq, const_field a, const_field b => fun e => e = const_bool
                                                        (if eq_field a b then true else false)
    | _, _, _ => fun e => False
    end.

  (* defns Jtyping *)
  Inductive typing : typing_env -> exp -> typ -> Prop :=    (* defn typing *)
  | typing_var : forall (G:typing_env) (x:expvar) (T:typ),
      binds ( x ) ( T ) ( G )  ->
      uniq ( G )  ->
      typing G (tm_var_f x) T
  | typing_abs : forall (L:vars) (G:typing_env) (T1:typ) (e:exp) (T2:typ),
      ( forall x , x \notin  L  -> typing  ((one (pair  x   T1 )) ++  G )   ( open_exp_wrt_exp e (tm_var_f x) )  T2 )  ->
      typing G (tm_abs T1 e) (ty_arrow T1 T2)
  | typing_app : forall (G:typing_env) (e1 e2:exp) (T2 T1:typ),
      typing G e1 (ty_arrow T1 T2) ->
      typing G e2 T1 ->
      typing G (tm_app e1 e2) T2
  | typing_true : forall (G:typing_env),
      typing G (tm_constant (const_bool  true )) ty_bool
  | typing_false : forall (G:typing_env),
      typing G (tm_constant (const_bool  false )) ty_bool
  | typing_field : forall (G:typing_env) (n5:Fp),
      typing G (tm_constant (const_field n5)) ty_field
  | typing_boolop : forall (G:typing_env) (e1:exp) (op5:op) (e2:exp),
      typing G e1 ty_bool ->
      typing G e2 ty_bool ->
      typing G (tm_binop e1 op5 e2) ty_bool
  | typing_boolnot : forall (G:typing_env) (e:exp),
      typing G e ty_bool ->
      typing G (tm_not e) ty_bool
  | typing_fieldop : forall (G:typing_env) (e1:exp) (op5:op) (e2:exp),
      typing G e1 ty_field ->
      typing G e2 ty_field ->
      typing G (tm_binop e1 op5 e2) ty_field
  | typing_if : forall (G:typing_env) (e e1 e2:exp) (T:typ),
      typing G e ty_bool ->
      typing G e1 T ->
      typing G e2 T ->
      typing G (tm_ifthenelse e e1 e2) T
  | typing_let : forall (L:vars) (G:typing_env) (e1 e2:exp) (T2 T1:typ),
      typing G e1 T1 ->
      ( forall x , x \notin  L  -> typing  ((one (pair  x   T1 )) ++  G )   ( open_exp_wrt_exp e2 (tm_var_f x) )  T2 )  ->
      typing G (tm_let e1 e2) T2.

  (* defns Jop *)
  Inductive step : exp -> exp -> Prop :=    (* defn step *)
  | step_app_1 : forall (e1 e2 e1':exp),
      lc_exp e2 ->
      step e1 e1' ->
      step (tm_app e1 e2) (tm_app e1' e2)
  | step_app_2 : forall (e2 e2' v1:exp),
      Is_true (is_value_of_exp v1) ->
      lc_exp v1 ->
      step e2 e2' ->
      step (tm_app v1 e2) (tm_app v1 e2')
  | step_beta : forall (T:typ) (e1 v2:exp),
      Is_true (is_value_of_exp v2) ->
      lc_exp (tm_abs T e1) ->
      lc_exp v2 ->
      step (tm_app  ( (tm_abs T e1) )  v2)  (open_exp_wrt_exp  e1   v2 )
  | step_if_cog : forall (e1 e2 e3 e1':exp),
      lc_exp e2 ->
      lc_exp e3 ->
      step e1 e1' ->
      step (tm_ifthenelse e1 e2 e3) (tm_ifthenelse e1' e2 e3)
  | step_if_true : forall (e1 e2:exp),
      lc_exp e2 ->
      lc_exp e1 ->
      step (tm_ifthenelse (tm_constant (const_bool  true )) e1 e2) e1
  | step_if_false : forall (e1 e2:exp),
      lc_exp e1 ->
      lc_exp e2 ->
      step (tm_ifthenelse (tm_constant (const_bool  false )) e1 e2) e2
  | step_not_true :
      step (tm_not (tm_constant (const_bool  true ))) (tm_constant (const_bool  false ))
  | step_not_false :
      step (tm_not (tm_constant (const_bool  false ))) (tm_constant (const_bool  true ))
  | step_let_v : forall (e2 v1:exp),
      Is_true (is_value_of_exp v1) ->
      lc_exp (tm_let v1 e2) ->
      lc_exp v1 ->
      step (tm_let v1 e2)  (open_exp_wrt_exp  e2   v1 )
  | step_let_cog : forall (e1 e2 e1':exp),
      lc_exp (tm_let e1 e2) ->
      step e1 e1' ->
      step (tm_let e1 e2) (tm_let e1' e2)
  | step_binop_cog_1 : forall (e1:exp) (op5:op) (e2 e1':exp),
      lc_exp e2 ->
      step e1 e1' ->
      step (tm_binop e1 op5 e2) (tm_binop e1' op5 e2)
  | step_binop_cog_2 : forall (c1:constant) (op5:op) (e2 e2':exp),
      step e2 e2' ->
      step (tm_binop (tm_constant c1) op5 e2) (tm_binop (tm_constant c1) op5 e2')
  | step_op_const : forall (c1 c2 ans: constant)(o: op),
      op_helper o c1 c2 ans ->
      step (tm_binop (tm_constant c1) o (tm_constant c2)) (tm_constant ans).

  (** infrastructure *)
  Hint Constructors typing step lc_exp : core.

End Stlc_Ott.

Module Stlc(PF: GaloisField).
  Import PF.
  Include Stlc_Ott PF.

  Coercion tm_var_f: expvar >-> exp.
  Coercion tm_constant: constant >-> exp.
  Declare Custom Entry stlc_ty.
  Declare Custom Entry stlc.

  Notation "'fp' n" := (tm_constant (const_field n)) (in custom stlc at level 0).
  Notation "'true'"  := true (at level 1).
  Notation "'true'" := (tm_constant (const_bool true)) (in custom stlc at level 0).
  Notation "'false'"  := false (at level 1).
  Notation "'false'" := (tm_constant (const_bool false)) (in custom stlc at level 0).
  Notation "<{ e }>" := e (e custom stlc at level 99).
  Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
  Notation "( x )" := x (in custom stlc, x at level 99).
  Notation "( x )" := x (in custom stlc_ty, x at level 99).
  Notation "x" := x (in custom stlc at level 0, x constr at level 0).
  Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
  Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
  Notation "\_ : t , y" :=
    (tm_abs t y) (in custom stlc at level 90,
                     t custom stlc_ty at level 99,
                     y custom stlc at level 80,
                     left associativity).
  Notation "# n" := (tm_var_b n%nat) (in custom stlc at level 0).
  Notation "{ x }" := x (in custom stlc at level 1, x constr).
  Notation "S -> T" := (ty_arrow S T) (in custom stlc_ty at level 2, right associativity).
  Notation "Gamma '|-' t '::' T" := (typing Gamma t T) (in custom stlc_ty at level 40, t custom stlc, T custom stlc_ty at level 1).
  Notation "'Field'" := ty_field (in custom stlc_ty at level 0).
  Notation "'Bool'" := ty_bool (in custom stlc_ty at level 0).
  Notation "x + y" := (tm_binop x op_add y) (in custom stlc at level 2,
                                                left associativity).
  Notation "x - y" := (tm_binop x op_sub y) (in custom stlc at level 2,
                                                left associativity).
  Notation "x * y" := (tm_binop x op_mul y) (in custom stlc at level 1,
                                                left associativity).
  Notation "x / y" := (tm_binop x op_div y) (in custom stlc at level 1,
                                                left associativity).
  Notation "x && y" := (tm_binop x op_and y) (in custom stlc at level 4,
                                                 left associativity).
  Notation "x || y" := (tm_binop x op_or y) (in custom stlc at level 4,
                                                left associativity).
  Notation "x == y" := (tm_binop x op_eq y) (in custom stlc at level 3,
                                       left associativity).
  Notation "! x " := (tm_not x) (in custom stlc at level 3).

  Notation "'if' x 'then' y 'else' z" :=
    (tm_ifthenelse x y z) (in custom stlc at level 89,
                              x custom stlc at level 99,
                              y custom stlc at level 99,
                              z custom stlc at level 99,
                              left associativity).
  Notation "'let' t1 'in' t2" :=
    (tm_let t1 t2) (in custom stlc at level 88,
                       t1 custom stlc at level 99,
                       t2 custom stlc at level 99,
                       left associativity).

  (** Equality projections *)
  Lemma eq_stlc_fp: forall n w, <{ fp n }> = <{ fp w }> <-> n = w.
  Proof.
    intros; split; intros; (inversion H || rewrite H); reflexivity.
  Qed.

  Lemma neq_stlc_fp: forall n w, <{ fp n }> <> <{ fp w }> <-> n <> w.
  Proof.
    intros.
    split.
    intros;intro.
    apply eq_stlc_fp in H0.
    contradiction.
    intros; intro.
    apply eq_stlc_fp in H0.
    contradiction.
  Qed.
  Hint Resolve eq_stlc_fp: pk.
  Hint Resolve neq_stlc_fp: pk.

End Stlc.


Require Import List.
Require Import Compare_dec.

Require Import SimpSyntax.

Require Import Le Lt.
Require Import Plus Minus.

(*
X0 : Type
X1 : forall (x0:X0),Type
X2 : forall (x0:X0) (x1:X1 x0),Type
X3 : forall (x0:X0) (x1:X1 x0) (x2:X2 x0 x1),Type
X4 : forall (x0:X0) (x1:X1 x0) (x2:X2 x0 x1) (x3:X3 x0 x1 x2),Type
...
*)

(* Definition of chained types as raw terms *)

Definition chArgs m := seq O m.

Fixpoint chFam n m : simpFam := match n with
	O => nil |
	S n => (n,chArgs m) :: chFam n (S m)
end.

(* Not actually part of the definition, but related to chSig *)
Fixpoint chCtxD n := match n with
	O => nil |
	S n => chFam n O :: chCtxD n
end.

Fixpoint chSig n l := match n with
	O => l |
	S n => chSig n (chFam n O :: l)
end.

Lemma chFam_length n : forall m,length (chFam n m) = n.
	induction n;intro.

	reflexivity.

	simpl.
	rewrite IHn.
	reflexivity.
Qed.

Lemma chFam_nth s : forall n m,(s <= n)->(nth s (chFam (S n) m) (O,nil) = (n - s,chArgs (s + m))).
	induction s;intros ? ?.

	destruct n;intro;reflexivity.

	destruct n;intro.
		destruct le_Sn_O with (1 := H).
	change (nth s (chFam (S n) (S m)) (O,nil) = (n - s,chArgs (S (s + m)))).
	rewrite plus_n_Sm.
	apply IHs.
	apply le_S_n with (1 := H).
Qed.

Lemma chCtxD_length n : length (chCtxD n) = n.
	induction n.

	reflexivity.

	simpl.
	rewrite IHn.
	reflexivity.
Qed.

Lemma chCtxD_skipn s : forall n,skipn s (chCtxD n) = chCtxD (n - s).
	induction s;intro;(destruct n;[reflexivity |]).

	reflexivity.

	simpl.
	apply IHs.
Qed.

Lemma chCtxD_nth s : forall n,(s <= n)->(nth s (chCtxD (S n)) nil = chFam (n - s) O).
	induction s;intro.

	destruct n;intro;reflexivity.

	destruct n;intro.
		destruct le_Sn_O with (1 := H).
	change (nth s (chCtxD (S n)) nil = chFam (n - s) O).
	apply IHs.
	apply le_S_n with (1 := H).
Qed.

Lemma chSig_unzip n : forall l,chSig (S n) l = unzip n (chCtxD n) (chFam n O :: l).
	induction n;intro.

	reflexivity.

	apply IHn.
Qed.

(* Proof that chained types are well-typed *)

Lemma chArgsFree l : laBumpG 1 l (chArgs l) = chArgs l.
	assert (forall s,(s <= l)->(laBumpG 1 l (seq (l - s) s) = seq (l - s) s));
	[|
		pose proof (H _ (le_n _));
		rewrite <- minus_n_n in H0;
		exact H0
	].
	intro.
	induction s;intro.

	reflexivity.

	simpl.
	rewrite (proj1 (nat_compare_lt _ _));
	[|
		unfold lt;
		rewrite minus_Sn_m with (1 := H);
		simpl;
		apply le_minus
	].
	rewrite minus_Sn_m with (1 := H).
	simpl.
	rewrite IHs with (1 := lt_le_weak _ _ H).
	reflexivity.
Qed.

Lemma chFamFree n m : forall l,fBumpG 1 l (fBumpD m (chFam n l)) = fBumpD m (chFam n l).
	induction n;intro.

	reflexivity.

	simpl.
	rewrite chArgsFree.
	rewrite IHn.
	reflexivity.
Qed.

Lemma chArgsOK n m : (m < n)->SimpParamOK (unzip m (chFam n O) nil) (fBumpD (n - m) (chFam m O)) (chArgs m) nil.
	intro.
	pose (T s := fApply (fBumpD (n - m) (chFam m O)) (seq (m - s) s)).
	assert (Tlen : forall s,length (T s) = m - s).
		intro.
		unfold T.
		rewrite fApply_length.
		rewrite fBumpD_length.
		rewrite chFam_length.
		rewrite seq_length.
		reflexivity.
	assert (forall s,(s <= m)->SimpParamOK (unzip m (chFam n O) nil) (fBumpD (n - m) (chFam m O)) (seq (m - s) s) (T s));
	[|
		pose proof (H0 _ (le_n _));
		pose proof (Tlen m);
		rewrite <- minus_n_n in H1,H2;
		destruct (T m);[exact H1 | destruct O_S with (1 := eq_sym H2)]
	].
	intro.
	induction s;intro;unfold T;simpl.

	apply spOKNil.
	apply chFamFree.

	rewrite minus_Sn_m with (1 := H0).
	simpl.
	assert (Hmn := lt_le_weak _ _ H).
	assert (Hsm := lt_le_weak _ _ H0).
	apply spOKCons.
		unfold lt.
		rewrite minus_Sn_m with (1 := H0).
		rewrite unzip_length;[| rewrite chFam_length;exact Hmn].
		simpl.
		rewrite <- plus_n_O.
		apply le_minus.
	fold (T s).
	rewrite minus_Sn_m with (1 := H0).
	simpl.
	assert (O < length (T s)).
		rewrite Tlen.
		apply plus_lt_reg_l with s.
		rewrite <- plus_n_O.
		rewrite <- le_plus_minus with (1 := Hsm).
		exact H0.
	replace (pBumpG (m - s) O (nth (m - S s) (unzip m (chFam n O) nil) (O,nil))) with (hd (O,nil) (T s)).
		destruct (T s);[destruct lt_n_O with (1 := H1) | exact (IHs Hsm)].
	unfold T.
	clear T Tlen IHs H1.
	rewrite unzip_nthLo;
	[|
		unfold lt;
		rewrite minus_Sn_m with (1 := H0);
		simpl;
		apply le_minus
	|
		rewrite chFam_length;
		exact Hmn
	].
	rewrite minus_Sn_m with (1 := H0).
	simpl.
	replace (m - (m - s)) with s;
	[|
		apply plus_reg_l with (m - s);
		rewrite <- le_plus_minus with (1 := le_minus _ _);
		rewrite <- plus_comm;
		rewrite <- le_plus_minus with (1 := Hsm);
		reflexivity
	].
	clear Hmn.
	destruct n.
		destruct lt_n_O with (1 := H).
	rewrite chFam_nth with (1 := le_trans _ _ _ Hsm (le_S_n _ _ H)).
	rewrite <- plus_n_O.
	clear Hsm.
	destruct m.
		destruct le_Sn_O with (1 := H0).
	assert (Hmn := lt_le_weak _ _ (lt_S_n _ _ H)).
	assert (Hsm := le_S_n _ _ H0).
	clear H.
	simpl (S n - S m).
	rewrite fApply_hd;rewrite seq_length;
	[| rewrite fBumpD_length;rewrite chFam_length;exact H0].
	rewrite fBumpD_nth;[| rewrite chFam_length;exact H0].
	rewrite chFam_nth with (1 := Hsm).
	rewrite <- plus_n_O.
	replace (n - m + (m - s)) with (n - s);
	[|
		apply plus_reg_l with s;
		rewrite <- le_plus_minus with (1 := le_trans _ _ _ Hsm Hmn);
		rewrite <- plus_comm;
		rewrite <- plus_assoc;
		rewrite <- (plus_comm s);
		rewrite <- le_plus_minus with (1 := Hsm);
		rewrite <- plus_comm;
		apply le_plus_minus with (1 := Hmn)
	].
	unfold pMSubstG.
	rewrite seq_length.
	unfold pBumpG.
	refine (match _ in _ = b return (_,_) = (_,b) with eq_refl => eq_refl _ end).
	clear n H0 Hmn Hsm.
	unfold laBumpG.
	apply map_ext_In.
	intros.
	pose proof (seq_In _ _ _ H).
	clear H.
	destruct H0 as (_,?).
	simpl in H.
	rewrite seq_nth with (1 := H).
	rewrite (proj1 (nat_compare_lt _ _) H).
	destruct (nat_compare_spec a O);try reflexivity.
	destruct lt_n_O with (1 := H0).
Qed.

Lemma chFamOK n : SimpFamOK (chCtxD n) nil (chFam n O).
	assert (forall s,(s <= n)->SimpFamOK (chCtxD n) (unzip (n - s) (chFam n O) nil) (chFam s (n - s)));
	[|
		pose proof (H _ (le_n _));
		rewrite <- minus_n_n in H0;
		exact H0
	].
	intro.
	induction s;intro.

	apply sfOKNil.

	destruct n.
		destruct le_Sn_O with (1 := H).
	assert (Hsn := le_S_n _ _ H).
	simpl minus.
	simpl (chFam (S s)).
	lazy beta.
	set (s' := n - s).
	assert (Hs'n : s' <= n).
		apply le_minus.
	assert (Hs : s = n - s').
		apply plus_reg_l with s'.
		rewrite <- le_plus_minus with (1 := Hs'n).
		unfold s'.
		rewrite <- plus_comm.
		rewrite <- le_plus_minus with (1 := Hsn).
		reflexivity.
	apply sfOKCons.
		rewrite chCtxD_length.
		exact H.

		rewrite chCtxD_nth with (1 := Hsn).
		fold s'.
		rewrite Hs.
		rewrite minus_Sn_m with (1 := Hs'n).
		apply chArgsOK.
		apply le_n_S with (1 := Hs'n).

		set (s'' := s) at 2.
		rewrite Hs.
		subst s''.
		set (s'' := s') at 2.
		rewrite (plus_n_O s'').
		subst s''.
		rewrite <- chFam_nth with (1 := Hs'n).
		rewrite unzip_consNth;[| rewrite chFam_length;apply le_n_S with (1 := Hs'n)].
		unfold s'.
		rewrite minus_Sn_m with (1 := Hsn).
		apply IHs.
		apply le_S with (1 := Hsn).
Qed.

Lemma chSigOK n : SimpFamsOK nil (chSig (S n) nil).
	rewrite chSig_unzip.
	set (n' := n) at 1.
	rewrite <- (chCtxD_length n').
	subst n'.
	apply sfsOKUnzip.
		apply chFamOK.
	rewrite chCtxD_length.
	intros.
	destruct n.
		destruct lt_n_O with (1 := H).
	rewrite chCtxD_skipn.
	rewrite chCtxD_nth with (1 := le_S_n _ _ H).
	apply chFamOK.
Qed.

(* <Under construction> *)

Lemma sfsUnzip' D F P : SimpFamOK D nil F->(forall Fs,SimpFamsOK nil Fs->P)->P.
	intros.
	assert (forall s,(s <= length D)->SimpFamsOK (skipn s D) (unzip s D (F :: nil)));
	[|
		pose proof (H1 _ (le_n _));
		rewrite skipnSkipAll in H2;
		exact H2
	].
	intro.
	induction s;intro.

	apply sfsOKOne with (1 := H).

	rewrite <- unzip_consNth with (d := nil) (1 := H1).
	apply sfsOKCons with (1 := H0 _ H1).
	rewrite skipn_consNth with (1 := H1).
	apply IHs.
	apply lt_le_weak with (1 := H1).
Qed.

Lemma chSig' n P : (forall Fs,SimpFamsOK nil Fs->P)->P.
	rewrite chSig_unzip.
	set (n' := n) at 1.
	rewrite <- (chCtxD_length n').
	subst n'.
	apply sfsOKUnzip.
		apply chFamOK.
	rewrite chCtxD_length.
	intros.
	destruct n.
		destruct lt_n_O with (1 := H).
	rewrite chCtxD_skipn.
	rewrite chCtxD_nth with (1 := le_S_n _ _ H).
	apply chFamOK.
Qed.

Inductive Ctx : Type->Type :=
	nilCtx : Ctx unit |
	consCtx G (T:G->Type) : Ctx G->Ctx (sigT T).

(*
Inductive Ctx' G : Type :=
	nilCtx' : ((unit:Type) = G)->Ctx' G |
	consCtx' G' (T:G'->Type) : Ctx' G'->(sigT T = G)->Ctx' G.

Definition prime G : Ctx G->Ctx' G.
	intro.
	induction X.

	apply nilCtx'.
	reflexivity.

	apply (consCtx' _ _ T IHX).
	reflexivity.
Defined.
Implicit Arguments prime [G].

Definition unprime G : Ctx' G->Ctx G.
	intro.
	induction X.

	rewrite <- e.
	apply nilCtx.

	rewrite <- e.
	exact (consCtx _ _ IHX).
Defined.
Implicit Arguments unprime [G].

Lemma prime_unprime G (X:Ctx' G) : prime (unprime X) = X.
	induction X.

	rewrite <- e.
	reflexivity.

	rewrite <- e.
	simpl.
	rewrite IHX.
	reflexivity.
Qed.

Lemma unprime_prime G (X:Ctx G) : unprime (prime X) = X.
	induction X.

	reflexivity.

	simpl.
	rewrite IHX.
	reflexivity.
Qed.

(* What we _really_ want *)
Inductive ctx : Type :=
	cnil |
	ccons (G:ctx) (T:ictx G->Type).
with
Fixpoint ictx (G:ctx) : Type := match G with
	cnil => unit |
	ccons G T => sigT T
end.
*)

Inductive Chain : nat->Type->Type :=


Require Import Program.Equality ssreflect ssrfun List.
Require Import MMap Subst Size util lib Decidable Ctxts.

Inductive type : Type :=
| TyVar (x : var)
| Top
| Arr (A1 A2 : type)
| All (A1 : type) (A2 : bind type).

Instance subst_type : Subst type. gen_Subst. Defined.
Instance substLemmas_type : SubstLemmas _ subst_type.
admit;gen_SubstLemmas. Qed.
Instance size_type : Size type.
assert(Size var). exact(fun _ => 0).
gen_Size. Defined.

Lemma ren_size_inv A : forall xi, size A.[ren xi] = size A.
Proof.
  induction A; intros; sizesimpl; repeat(ssimpl; try autorew); try somega.
Qed.

Fixpoint wf_ty Delta A := match A with
  | TyVar x => exists B, dget Delta x B
  | Top => True
  | Arr A B => wf_ty Delta A /\ wf_ty Delta B
  | All A B => wf_ty Delta A /\ wf_ty Delta,,A B
end.

Reserved Notation "'SUB' Delta |- A <: B" (at level 68, A at level 99, no associativity).
Inductive sub (Delta : list type) : type -> type -> Prop :=
| SA_Top A : wf_ty Delta A -> SUB Delta |- A <: Top
| SA_Refl x : wf_ty Delta (Var x) -> SUB Delta |- Var x <: Var x
| SA_Trans x A B : dget Delta x A -> SUB Delta |- A <: B -> SUB Delta |- Var x <: B
| SA_Arrow A1 A2 B1 B2 : SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 -> SUB Delta |- Arr A1 A2 <: Arr B1 B2
| SA_All A1 A2 B1 B2 : SUB Delta |- B1 <: A1 -> wf_ty Delta B1 -> SUB Delta,,B1 |- A2 <: B2 -> SUB Delta |- All A1 A2 <: All B1 B2
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Lemma wf_weak Delta1 Delta2 A xi :
  wf_ty Delta1 A ->
  (forall x B, dget Delta1  x B -> exists B', dget Delta2 (xi x) B') ->
  wf_ty Delta2 A.[ren xi].
Proof.
  intros H. aind A. ssimpl.
  eapply IHA0. eassumption. intros.
  destruct x; ssimpl; arew; ssimpl. unfold lift. simpl.
  edestruct H0; arew.
Qed.

Corollary wf_weak' Delta1 Delta2 A :
  wf_ty Delta1 A ->
  (length Delta1 <= length Delta2) ->
  wf_ty Delta2 A.
Proof.
  intros.
  cutrewrite(A = A.[ren id]);[idtac|now ssimpl].
  eapply wf_weak; eauto.
  intros.
  apply dget_defined.
  cut(id x < length Delta1). omega.
  apply dget_defined.
  eexists. eassumption.
Qed.

Lemma sub_refl Delta A : wf_ty Delta A -> SUB Delta |- A <: A.
Proof.
  revert Delta. induction A; simpl; intuition; eauto using sub.
Qed.

Lemma sub_weak Delta1 Delta2 A1 A2 xi : SUB Delta1 |- A1 <: A2 ->
  (forall x B, dget Delta1 x B -> dget Delta2 (xi x) B.[ren xi]) ->
  SUB Delta2 |- A1.[ren xi] <: A2.[ren xi] .
Proof.
   intros H. aind H.
   - constructor. eapply wf_weak; now eauto.
   - econstructor; ssimpl.
     + now eauto.
     + eapply wf_weak; now eauto.
     + apply IHsub2. intros.
       destruct x; ssimpl; arew; ssimpl; rewrite (ren_uncomp _ _ (+1)); arew.
Qed.

Lemma sub_wf {Delta A B} : SUB Delta |- A <: B -> wf_ty Delta A /\ wf_ty Delta B.
Proof.
  intros H. aind H.
  eapply wf_weak'. eassumption.
  now simpl.
Qed.

Lemma sub_trans' n :
  (forall Delta A B C, n = size B ->
     SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C) /\
  (forall Delta' Delta B B' A C, n = size B ->
     SUB Delta,,B,,,Delta' |- A <: C ->
     SUB Delta |- B' <: B ->
     SUB Delta,,B',,,Delta' |- A <: C).
Proof.
  induction n as [n IH] using (size_rec (fun x => x)).
  apply conj'.
  {
    intros Delta A B C ? H_AB H_BC. subst.
    revert C H_BC.
    induction H_AB; prepare.
    - now arew.
    - econstructor; now eauto.
    - inv H_BC.
      + constructor. simpl. intuition. now eapply (sub_wf H_AB1). now eapply (sub_wf H_AB2).
      + constructor; eapply IH; eauto; somega.
    - inv H_BC.
      + constructor; constructor.
        * eapply sub_wf; now eauto.
        * eapply wf_weak'. now eapply (sub_wf H_AB2). now simpl.
      + rename B0 into C1. rename B3 into C2.
        constructor; eauto.
        * eapply IH; eauto; somega.
        * eapply IH; eauto; try somega.
          refine (proj2 (IH _ _) nil _ _ _ _ _ _ _ _); eauto; somega.
  }
  {
    intros H_trans Delta' Delta B B' A C ? H H_B'B. subst.
    revert B' H_B'B.
    depind H; prepare.
    - constructor.
      eapply wf_weak'. eassumption.
      repeat rewrite app_length. simpl. omega.
    - constructor. simpl.
      apply dget_defined. apply dget_defined in H.
      repeat rewrite -> app_length in *. simpl in *. omega.
    - decide (x = length Delta').
      + subst.
        econstructor. { apply dget_repl. }
        apply dget_steps' with (x := 0) in H.
        destruct H as [? [? H]]. inv H.
        eapply H_trans;[idtac | eapply sub_weak; try eassumption | idtac].
        * now rewrite ren_size_inv.
        * intros. change Delta,,B' with Delta,,,(nil,,B'). rewrite app_assoc.
          cutrewrite (S (length Delta') = length (nil,,B',,,Delta'));
            first by apply dget_steps.
          rewrite app_length. simpl. omega.
        * ssimpl in IHsub.
          eapply IHsub; now eauto.
      + econstructor; eauto.
        eapply dget_repl; now eauto.
    - constructor; now eauto.
    - constructor.
      + now eauto.
      + eapply wf_weak'. eassumption.
        repeat rewrite app_length. simpl. omega.
      + change Delta,,B',,,Delta',,B1 with Delta,,B',,,(Delta',,B1).
        eapply IHsub2; eauto. reflexivity.
  }
Qed.

Theorem sub_trans Delta A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof.
  intros. eapply sub_trans'; eauto.
Qed.

Inductive term :=
| TeVar (x : var)
| Abs (A : type) (s : bind term)
| App (s t : term)
| TAbs (A : type) (s : bind term)
| TApp (s : term) (A : type)
.

Instance subst_term : Subst term. gen_Subst. Defined.
Instance substLemmas_term : SubstLemmas _ subst_term.
gen_SubstLemmas. Defined.
Instance size_term : Size term.
assert(Size var). exact(fun _ => 0).
gen_Size. Defined.

Instance mmap_term : MMap type term.
gen_MMap.
Defined.

Instance mmapLemmas_term : MMapLemmas mmap_term.
gen_MMapLemmas.
Defined.

Inductive value : term -> Prop :=
| Value_Abs A s : value(Abs A s)
| Value_TAbs A s : value(TAbs A s).

(*
Fixpoint wf_term Delta Gamma A :=
  match A with
    | TeVar x => exists B, get Gamma x B
    | Abs A s => wf_ty Delta A /\ wf_term Delta Gamma,,A s
    | App s t => wf_term Delta Gamma s /\ wf_term Delta Gamma t
    | TAbs A s => wf_ty Delta A -> wf_term Delta,,A Gamma s
    | TApp s A => wf_term Delta Gamma s /\ wf_ty Delta A
  end.
*)

Reserved Notation "'TY' Delta ; Gamma |- A : B" (at level 68, A at level 99, no associativity, format "'TY'  Delta ; Gamma  |-  A  :  B").
Inductive ty (Delta Gamma : list type) : term -> type -> Prop :=
| T_Var A x :
    get Gamma x A   ->
    TY Delta;Gamma |- Var x : A
| T_Abs A B s:
    TY Delta;Gamma,,A |- s : B   ->   wf_ty Delta A   ->
    TY Delta;Gamma |- Abs A s : Arr A B
| T_App A B s t:
    TY Delta;Gamma |- s : Arr A B   ->   TY Delta;Gamma |- t : A   ->
    TY Delta;Gamma |- App s t : B
| T_TAbs A B s :
    TY Delta,,A;Gamma |- s : B   ->   wf_ty Delta A   ->
    TY Delta;Gamma |- TAbs A s : All A B
| T_TApp A B A' s B' :
    TY Delta;Gamma |- s : All A B   ->   SUB Delta |- A' <: A   -> B' = B.[A' .: Var] ->
    TY Delta;Gamma |- TApp s A' : B'
| T_Sub A B s :
    TY Delta;Gamma |- s : A   ->   SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (ty Delta Gamma s A).

Reserved Notation "'EV' s => t" (at level 68, s at level 80, no associativity, format "'EV'   s  =>  t").
Inductive eval : term -> term -> Prop :=
| E_AppAbs A s t : EV  App (Abs A s) t => s.[t .: Var]
| E_TAppTAbs A s B : EV  TApp (TAbs A s) B => s..[B .: Var]
| E_AppFun s s' t :
    EV  s => s' ->
    EV  App s t => App s' t
| E_AppArg s s' v:
    EV  s => s' -> value v ->
    EV  App v s => App v s'
| E_TypeFun s s' A :
    EV  s => s' ->
    EV  TApp s A => TApp s' A
where "'EV' s => t" := (eval s t).

Lemma ty_weak Delta1 Delta2 Gamma1 Gamma2 s A xi zeta :
  TY Delta1;Gamma1 |- s : A ->
  (forall x B, dget Delta1 x B -> dget Delta2 (xi x) B.[ren xi]) ->
  (forall x B, get Gamma1 x B -> get Gamma2 (zeta x) B.[ren xi]) ->
  TY Delta2;Gamma2 |- s.[ren zeta]..[ren xi] : A.[ren xi] .
Proof.
   intros H. autorevert H; induction H; intros.
   - econstructor; now eauto.
   - ssimpl. econstructor.
     + apply IHty; eauto. intros [|]; arew.
     + eapply wf_weak; now eauto.
   - ssimpl. econstructor; arew.
   - ssimpl. econstructor.
     + apply IHty; eauto. intros [|]; arew.

ineconstructor.
 (econstructor; try now
   match goal with [H : _ |- _ ] => ssimpl; eapply H; now eauto end). ssimpl. eapply sub_weak; now intuition.

 ssimpl.

ssimpl'. eapply IHty.
intuition. eauto. ; arew.
   - constructor. eapply wf_weak; now eauto.
   - econstructor; ssimpl.
     + now eauto.
     + eapply wf_weak; now eauto.
     + apply IHsub2. intros.
       destruct x; ssimpl; arew; ssimpl; rewrite (ren_uncomp _ _ (+1)); arew.
Qed.


(*
 ============================================================================
 Project     : Nominal A, AC and C Unification
 File        : AAAC_Equiv.v
 Authors     : Washington Luis R. de Carvalho Segundo and
               Mauricio Ayala Rincon
               Universidade de Brasilia (UnB) - Brazil
               Group of Theory of Computation

 Description : This file contains the soundness proofs of
               the relations ~aacc, ~a, ~c and ~ac.

 Last Modified On: Sep 17, 2018.
 ============================================================================
*)

Require Export Equiv_Tuples.

Lemma alpha_to_aacc_equiv : forall C t t',
 C |- t ~alpha t' -> C |- t ~aacc t'.
Proof.
 intros. induction H; auto;
 simpl in H; try contradiction.
 apply aacc_equiv_Fc; trivial.
Qed.

Hint Resolve alpha_to_aacc_equiv.

(** Some auxiliary lemmas about is_Pr *)

Lemma alpha_neg_is_Pr : forall C t t', C |- t ~alpha t' -> (~ is_Pr t <-> ~ is_Pr t').
Proof.
  intros. inverts H; simpl in *|-*; split~; intros; trivial.
Qed.

Lemma aacc_neg_is_Pr : forall C t t', C |- t ~aacc t' -> (~ is_Pr t <-> ~ is_Pr t').
Proof.
  intros. inverts H; simpl in *|-*; split~; intros; trivial.
Qed.

Lemma perm_neg_is_Pr : forall pi t, ~ is_Pr (pi @ t) <-> ~ is_Pr t.
Proof.
  intros. destruct t; autorewrite with perm; simpl; split~; intros; trivial.
Qed.

(** Intermediate transitivity for aacc_equiv with alpha_equiv *)

Lemma aacc_alpha_equiv_trans : forall C t1 t3,
  (exists t2, C |- t1 ~aacc t2 /\ C |- t2 ~alpha t3) <-> C |- t1 ~aacc t3.
Proof.
  intros. split~; intro.
  case H; clear H; intros t2 H. destruct H.

  (* -> *)

  gen t3 H0. induction H; intros; auto.
  inverts H1. apply equiv_Pr; [apply IHequiv1 | apply IHequiv2]; trivial.
  inverts H1. apply equiv_Fc; auto. destruct H.
  left~. destruct H. right~. split~. destruct H1. left~.
  right~. apply alpha_neg_is_Pr in H7. apply H7; trivial.
  inverts H0. apply equiv_Ab_1; apply IHequiv; trivial.
  apply equiv_Ab_2; trivial. apply IHequiv; trivial.
  inverts H2. apply equiv_Ab_2; trivial.
  apply IHequiv. apply alpha_equiv_eq_equiv.
  apply alpha_equiv_eq_equiv; trivial.
  apply alpha_equiv_equivariance; trivial.
  apply alpha_equiv_fresh with (t1 := t'); trivial.
  case (atom_eqdec a a'0); intro H10. rewrite H10.
  apply equiv_Ab_1. apply IHequiv. apply alpha_equiv_sym.
  replace (|[(a, a')]|) with (! (|[(a, a')]|)). apply perm_inv_side.
  apply alpha_equiv_trans with (t2 := (|[(a', a)]|) @ t'0).
  apply alpha_equiv_pi. intros b H11. false. apply H11. apply swap_comm.
  apply alpha_equiv_sym. rewrite H10; trivial. simpl; trivial.
  assert (Q : C |- a # t'0).
   apply alpha_equiv_fresh with (a := a) in H7; trivial.
   apply fresh_lemma_1 in H7. simpl rev in H7.
   rewrite swap_neither in H7; auto.
  apply equiv_Ab_2; trivial. apply IHequiv.
  replace (|[(a, a')]|) with (!(|[(a, a')]|)).
  apply perm_inv_side. simpl.
  apply alpha_equiv_trans with (t2 := (|[(a', a'0)]|) @ t'0); trivial.
  apply alpha_equiv_trans with
  (t2 := (|[(|[(a, a')]| $ a, |[(a, a')]| $ a'0)]|) @ ((|[(a, a')]|) @ t'0)); trivial.
  rewrite swap_left. rewrite swap_neither; auto.
  apply alpha_equiv_equivariance. apply alpha_equiv_sym.
  apply alpha_equiv_swap_neither; trivial. apply alpha_equiv_sym.
  apply alpha_equiv_pi_comm. simpl; trivial.

  inverts H0. apply equiv_Su. intros. unfold In_ds in *|-.
  case (atom_eqdec a (!p $ (p' $ a))); intro H1. rewrite H1. apply H5.
  rewrite <- H1. apply perm_inv_side_atom in H1. rewrite <- H1. trivial.
  rewrite perm_diff_atom with (p:=p) in H1. gen_eq g : (!p). intro H2.
  replace (p $ (g $ (p' $ a))) with (!g $ (g $ (p' $ a))) in H1.
  rewrite perm_inv_atom in H1. apply H; trivial. rewrite H2.
  rewrite perm_inv_inv_atom; trivial.

  inverts H2.
  apply equiv_A; simpl set_In; try omega.
  apply IHequiv1. apply alpha_equiv_TPith; auto.
  generalize H8; intro H8'.
  assert (Q : C |- Fc 0 n t ~aacc Fc 0 n t').
   apply equiv_A; simpl set_In; try omega; trivial.
  apply alpha_equiv_TPlength with (E:=0) (n:=n) in H8'.
  apply aacc_equiv_TPlength with (E:=0) (n:=n) in Q.
  autorewrite with tuples in Q.
  case (nat_eqdec (TPlength t 0 n) 1); intro H9.
  rewrite 2 TPithdel_TPlength_1;
  autorewrite with tuples; try omega; auto.
  apply IHequiv2.
  rewrite 2 TPithdel_Fc_eq; autorewrite with tuples; try omega.
  apply alpha_equiv_Fc. apply alpha_equiv_TPithdel; trivial.

  inverts H2. generalize H8; intro H8'.
  assert (Q : C |- Fc 1 n t ~aacc Fc 1 n t').
   apply equiv_AC with (i:=i); repeat split~; simpl set_In; try omega; trivial.
  apply alpha_equiv_TPlength with (E:=1) (n:=n) in H8'.
  apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q.
  autorewrite with tuples in Q.
  apply equiv_AC with (i:=i); simpl set_In; repeat split~; try omega.
  apply IHequiv1. apply alpha_equiv_TPith; auto.
  case (nat_eqdec (TPlength t 1 n) 1); intro H9.
  rewrite 2 TPithdel_TPlength_1;
  autorewrite with tuples; try omega; auto.
  apply IHequiv2.
  rewrite 2 TPithdel_Fc_eq; autorewrite with tuples; try omega.
  apply alpha_equiv_Fc. apply alpha_equiv_TPithdel; trivial.

  inverts H2. inverts H8.
  apply IHequiv1 in H5.
  apply IHequiv2 in H7.
  apply equiv_C1; trivial.

  inverts H2. inverts H8.
  apply IHequiv1 in H7.
  apply IHequiv2 in H5.
  apply equiv_C2; trivial.

  (* <- *)

  induction H.
  exists (<<>>). split~.
  exists (%a). split~.
  case IHequiv1; clear IHequiv1; intros t1'' IH1.
  case IHequiv2; clear IHequiv2; intros t2'' IH2.
  destruct IH1. destruct IH2. exists (<|t1'',t2''|>). split~.
  case IHequiv; clear IHequiv; intros t'' H1. destruct H1.
  exists (Fc E n t''). split~. apply equiv_Fc; trivial.
  destruct H. left~. right~. destruct H. split~.
  destruct H3. left~. left~. apply aacc_neg_is_Pr in H0. apply H0; trivial.
  case IHequiv; clear IHequiv; intros t'' H0. destruct H0.
  exists ([a]^t''). split~.
  case IHequiv; clear IHequiv; intros t'' H2. destruct H2.
  exists ([a]^t''). split~.
  exists (p|.X). split~. apply equiv_Su; intros. false.
  case IHequiv1; clear IHequiv1; intros t3 H2.
  case IHequiv2; clear IHequiv2; intros t4 H3.
  destruct H2. destruct H3.
  assert (Q : C |- Fc 0 n t ~aacc Fc 0 n t').
   apply equiv_A; trivial.
  exists (Fc 0 n t'). split~. apply alpha_equiv_refl.
  assert (Q : C |- Fc 1 n t ~aacc Fc 1 n t').
   apply equiv_AC with (i:=i); trivial.
  exists (Fc 1 n t'). split~. apply alpha_equiv_refl.
  assert (Q : C |- Fc 2 n (<| s0, s1 |>) ~aacc Fc 2 n (<| t0, t1 |>)).
   apply equiv_C1; trivial.
  exists (Fc 2 n (<| t0, t1 |>)). split~. apply alpha_equiv_refl.
  assert (Q : C |- Fc 2 n (<| s0, s1 |>) ~aacc Fc 2 n (<| t0, t1 |>)).
   apply equiv_C2; trivial.
  exists (Fc 2 n (<| t0, t1 |>)). split~. apply alpha_equiv_refl.

Qed.

(** Equivariance of aacc_equiv *)

Lemma aacc_equivariance : forall C t1 t2 pi,
 C |- t1 ~aacc t2 -> C |- (pi @ t1) ~aacc (pi @ t2).
Proof.
  intros. induction H; intros;
      autorewrite with tuples in *|-*; simpl perm_act in *|-*; auto.

 destruct H. apply equiv_Fc; trivial.
 left~. destruct H. apply equiv_Fc; trivial.
 right~; intros. split~; intros.
 destruct H1; [left~ | right~]; apply perm_neg_is_Pr; trivial.

 apply equiv_Ab_2. apply perm_diff_atom; trivial.
 apply aacc_alpha_equiv_trans.
 exists (pi @ ((|[(a, a')]|) @ t')). split~.
 apply alpha_equiv_pi_comm.
 apply fresh_lemma_2; trivial.

 apply equiv_Su. intros. apply H. intro. apply H0.
 rewrite <- 2 perm_comp_atom. rewrite H1; trivial.

 apply equiv_AC with (i:=i); repeat split~; simpl set_In; try omega.
 autorewrite with tuples in *|-*; trivial.
 assert (Q : C |- Fc 1 n t ~aacc Fc 1 n t').
  apply equiv_AC with (i:=i); repeat split~; simpl set_In; try omega;
  autorewrite with tuples; trivial.
 apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q.
 autorewrite with tuples in Q.
 case (nat_eqdec (TPlength t 1 n) 1); intro H4.
 rewrite 2 TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq in *|-*; autorewrite with tuples; try omega.
 autorewrite with perm in IHequiv2; trivial.
Qed.

(** A corollary about the swapping inversion of side in aacc_equiv *)

Lemma aacc_equiv_swap_inv_side : forall C a a' t t',
 C |- t ~aacc ((|[(a, a')]|) @ t') -> C |- ((|[(a', a)]|) @ t) ~aacc t'.
Proof.
 intros.
 apply aacc_alpha_equiv_trans.
 exists ((|[(a', a)]|) @ ((|[(a, a')]|) @ t')). split~.
 apply aacc_equivariance; trivial.
 apply perm_inv_side. simpl.
 apply alpha_equiv_pi. intros b H11. false. apply H11. apply swap_comm.
Qed.

(** Freshness preservation under aacc_equiv *)

Lemma aacc_equiv_fresh : forall C a t1 t2,
                          C |- t1 ~aacc t2 ->
                          C |- a # t1 ->
                          C |- a # t2.
Proof.
 intros. induction H; trivial.
 apply fresh_Pr_elim in H0. destruct H0.
 apply fresh_Pr; [apply IHequiv1 | apply IHequiv2]; trivial.
 apply fresh_Fc_elim in H0. apply fresh_Fc; apply IHequiv; trivial.
 apply fresh_Ab_elim in H0. destruct H0. rewrite H0. apply fresh_Ab_1.
 destruct H0. apply fresh_Ab_2; trivial. apply IHequiv; trivial.
 apply fresh_Ab_elim in H0. destruct H0. apply fresh_Ab_2.
 intro. apply H. rewrite <- H0. trivial. rewrite <- H0 in H2. trivial.
 destruct H0. case (atom_eqdec a a'); intros.
 rewrite e. apply fresh_Ab_1. apply fresh_Ab_2; trivial.
 assert (Q : C |- a # ((|[(a0, a')]|) @ t')).  apply IHequiv; trivial.
 apply fresh_lemma_1 in Q. simpl rev in Q. rewrite swap_neither in Q; trivial.
 intro. apply H0. rewrite H4; trivial. intro. apply n. rewrite H4; trivial.
 apply fresh_Su. apply fresh_Su_elim in H0.
 case (atom_eqdec ((!p) $ a) ((!p') $ a)); intros. rewrite <- e; trivial.
 apply H; intros. intro. apply n. gen_eq g : (!p'); intro.
 replace p' with (!g) in H1. rewrite perm_inv_atom in H1.
 replace ((!p) $ a) with ((!p) $ (p $ (g $ a))). rewrite perm_inv_atom. trivial.
 rewrite H1. trivial. rewrite H2. rewrite rev_involutive. trivial.

 apply fresh_Fc. apply fresh_Fc_elim in H0.
 apply fresh_TPith_TPithdel with (i:=1) (E:=0) (n:=n).
 apply fresh_TPith_TPithdel with (i:=1) (E:=0) (n:=n) in H0.
 destruct H0. split~. autorewrite with tuples in *|-. auto.
 assert (Q : C |- Fc 0 n t ~aacc Fc 0 n t').
  apply equiv_A; simpl set_In; try omega; trivial.
 apply aacc_equiv_TPlength with (E:=0) (n:=n) in Q.
 autorewrite with tuples in Q.
 case (nat_eqdec (TPlength t 0 n) 1); intro H4.
 rewrite TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq in *|-; autorewrite with tuples; try omega.
 apply fresh_Fc_elim with (E:=0) (n:=n).
 apply IHequiv2. apply fresh_Fc; trivial.

 apply fresh_Fc. apply fresh_Fc_elim in H0.
 apply fresh_TPith_TPithdel with (i:=i) (E:=1) (n:=n).
 apply fresh_TPith_TPithdel with (i:=1) (E:=1) (n:=n) in H0.
 destruct H0. split~. autorewrite with tuples in *|-. auto.
 assert (Q : C |- Fc 1 n t ~aacc Fc 1 n t').
  apply equiv_AC with (i:=i); repeat split~; simpl set_In; try omega; trivial.
 apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q.
 autorewrite with tuples in Q.
 case (nat_eqdec (TPlength t 1 n) 1); intro H7.
 rewrite TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq in *|-; autorewrite with tuples; try omega.
 apply fresh_Fc_elim with (E:=1) (n:=n).
 apply IHequiv2. apply fresh_Fc; trivial.

 apply fresh_Fc. apply fresh_Fc_elim in H0.
 apply fresh_Pr_elim in H0. destruct H0.
 apply fresh_Pr; [apply IHequiv1 | apply IHequiv2]; trivial.

 apply fresh_Fc. apply fresh_Fc_elim in H0.
 apply fresh_Pr_elim in H0. destruct H0.
 apply fresh_Pr; [apply IHequiv2 | apply IHequiv1]; trivial.

Qed.

(** Reflexivity of aacc_equiv *)

Lemma aacc_equiv_refl : forall C t, C |- t ~aacc t.
Proof.
  intros. induction t; auto.
  apply aacc_equiv_Fc; trivial.
  apply equiv_Su; intros. false.
Qed.

Hint Resolve aacc_equiv_refl.

(** A Corollary: the order of the atoms inside a swapping doesn't matter in aacc_equiv *)

Corollary aacc_equiv_swap_comm : forall C t a a',
  C |- (|[(a, a')]|) @ t ~aacc ((|[(a', a)]|) @ t) .
Proof.
 intros. apply aacc_alpha_equiv_trans.
 exists ((|[(a, a')]|) @ t). split~.
 apply alpha_equiv_pi. intros b H11. false. apply H11. apply swap_comm.
Qed.

(** Combination of AC arguments *)

Lemma aacc_equiv_TPith_l : forall C t t' i E n, C |- t ~aacc t' ->
                         i > 0 -> i <= TPlength t E n ->
               exists j, j > 0 /\ j <= TPlength t' E n /\
                         C |- TPith i t E n ~aacc TPith j t' E n /\
                         C |- TPithdel i t E n ~aacc TPithdel j t' E n.
Proof.
  intros. gen_eq l : (term_size t).
  intro H2. gen i t t' H2 H0 H1. induction l using peano_induction; intros.
  destruct H0.

  exists 1. simpl. repeat split~; try omega; auto.
  exists 1. simpl. repeat split~; try omega; auto.

  simpl in H2. generalize H0_ H0_0. intros H0' H0_0'.
  apply aacc_equiv_TPlength with (E:=E) (n:=n) in H0'.
  apply aacc_equiv_TPlength with (E:=E) (n:=n) in H0_0'.
  assert (Q:TPlength t1 E n >= 1 /\ TPlength t2 E n >= 1). auto. destruct Q.
  case (le_dec i (TPlength t1 E n)); intro H5.
  case H with (m:=term_size t1) (i:=i) (t:=t1) (t':=t1'); try omega; trivial; clear H.
  intros j H6. destruct H6. destruct H6. destruct H7. exists j.
  rewrite 2 TPith_Pr_le; try omega.
  case (nat_eqdec (TPlength t1 E n) 1); intro H9.
  rewrite 2 TPithdel_t1_Pr; try omega. simpl.
  repeat split~; try omega; trivial.
  rewrite 2 TPithdel_Pr_le; try omega.
  simpl; repeat split~; try omega; auto.
  case H with (m:=term_size t2)
              (i:=i - TPlength t1 E n) (t:=t2) (t':=t2'); try omega; trivial; clear H.
  simpl in H3. omega.
  intros j H6. destruct H6. destruct H6. destruct H7. exists (TPlength t1 E n + j).
  rewrite 2 TPith_Pr_gt; try omega. rewrite <- H0'.
  replace (TPlength t1 E n + j - TPlength t1 E n) with j; try omega.
  case (nat_eqdec (TPlength t2 E n) 1); intro H9.
  rewrite 2 TPithdel_t2_Pr; try omega.
  repeat split~; try omega; trivial. simpl; omega.
  rewrite 2 TPithdel_Pr_gt; try omega.
  replace (TPlength t1 E n + j - TPlength t1' E n) with j; try omega.
  simpl; repeat split~; try omega; auto.

  case (nat_pair_eqdec (E0,n0) (E,n)); intro H5. inverts H5.
  generalize H4; intro H4'.
  apply aacc_equiv_TPlength with (E:=E) (n:=n) in H4'.
  case (nat_eqdec (TPlength t E n) 1); intro H5. exists 1.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples; try omega; auto.
  assert (i=1). autorewrite with tuples in H3. omega. rewrite H6 in *|-*.
  repeat split~; try omega; trivial.
  apply aacc_equiv_TPith_l1 with (E:=E) (n:=n) in H4.
  destruct H4. destruct H4. destruct H7. destruct H8.
  assert (x = 1). omega. rewrite H10 in H8; trivial.
  destruct H0. exists i.
  autorewrite with tuples in *|-*.
  generalize H4; intro H4''.
  apply aacc_equiv_TPith_E_diff_1_2 with (i:=i) (E:=E) (n:=n) in H4. destruct H4.
  rewrite 2 TPithdel_Fc_eq; try omega.
  repeat split~; try omega; trivial.
  simpl in *|-*. omega.
  destruct H0. rewrite H0 in *|-*.
  autorewrite with tuples in H3. simpl in H2.
  case H with (m := term_size t) (i := i) (t := t) (t' := t'); try omega; trivial.
  intros j Hj. exists j. autorewrite with tuples.
  rewrite 2 TPithdel_Fc_eq; try omega.
  destruct Hj. destruct H8. destruct H9. repeat split~.
  apply equiv_Fc_c; trivial.
  exists 1. rewrite TPlength_Fc_diff in *|-*; trivial.
  rewrite 2 TPith_Fc_diff; trivial.
  rewrite 2 TPithdel_Fc_diff; trivial.
  repeat split~; try omega; auto.

  exists 1. simpl. repeat split~; try omega; auto.
  exists 1. simpl. repeat split~; try omega; auto.
  exists 1. simpl. repeat split~; try omega; auto.

  clear H0. case (set_In_dec nat_eqdec E (1::(|[2]|))); intro H4.
  exists 1. assert (Q:(0,n0) <> (E,n)). intro. inverts H0.
  simpl in H4. omega.
  rewrite TPlength_Fc_diff in *|-*; trivial.
  rewrite 2 TPith_Fc_diff; trivial.
  rewrite 2 TPithdel_Fc_diff; trivial.
  repeat split~; try omega; auto.
  apply equiv_A; simpl set_In; try omega; trivial.
  exists i. split~; auto.
  assert (Q: C |- Fc 0 n0 t ~aacc Fc 0 n0 t').
   apply equiv_A; simpl set_In; try omega; trivial.
  generalize Q; intro Q'. apply aacc_equiv_TPlength with (E:=E) (n:=n) in Q'.
  apply aacc_equiv_TPith_E_diff_1_2 with (E:=E) (n:=n) (i:=i) in Q; trivial.
  destruct Q. repeat split~; try omega; trivial.

  clear H0. case (nat_pair_eqdec (1,n0) (E,n)); intro H4. inverts H4.
  autorewrite with tuples in *|-*.

  case (nat_eqdec i 1); intro H4. rewrite H4.
  case (le_dec i0 1); intro H5.
  exists 1. case (nat_eqdec i0 0); intro H6; repeat rewrite H6 in *|-;
  repeat rewrite TPith_0 in *|-; repeat rewrite TPithdel_0 in *|-.
  repeat split~; trivial; autorewrite with tuples; auto.
  assert (Qi0:i0=1). omega. rewrite Qi0 in *|-.
  repeat split~; trivial; autorewrite with tuples; auto.

  case (le_dec i0 (TPlength t' 1 n)); intro H6.

  exists i0. repeat split~; autorewrite with tuples; try omega; trivial.
  exists (TPlength t' 1 n).
  rewrite TPith_overflow with (i:=i0) in H0_; autorewrite with tuples; try omega.
  rewrite TPithdel_overflow with (i:=i0) in H0_0; autorewrite with tuples; try omega.
  repeat split~; try omega; autorewrite with tuples in *|-*; auto.

  assert (Q0 : C |- Fc 1 n t ~aacc Fc 1 n t').
   apply equiv_AC with (i:=i0); repeat split~; simpl set_In;
   autorewrite with tuples; try omega; trivial.
  apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q0.
  autorewrite with tuples in Q0.
  assert (Q: TPlength t 1 n >=1). auto.
  case (nat_eqdec (TPlength t 1 n) 1); intro H5; try omega.
  rewrite 2 TPithdel_Fc_eq in H0_0; try omega.

  case H with (m  := term_size (Fc 1 n (TPithdel 1 t 1 n))) (i := i-1)
              (t  := Fc 1 n (TPithdel 1 t 1 n))
              (t' := Fc 1 n (TPithdel i0 t' 1 n));
              autorewrite with tuples;
              try rewrite TPlength_TPithdel; try omega; trivial; clear H.

  simpl. simpl in H2.
  assert (Q1: term_size (TPithdel 1 t 1 n) < term_size t).
   apply term_size_TPithdel; trivial. omega.
  intros j Hj. destruct Hj. destruct H0 . destruct H6.
  autorewrite with tuples in H6.
  apply aacc_equiv_TPlength with (E:=1) (n:=n) in H0_0.
  autorewrite with tuples in H0_0.
  rewrite 2 TPlength_TPithdel in H0_0; try omega.

  case (le_dec i0 j); intro H8.

  exists (j + 1). autorewrite with tuples.
  rewrite 2 TPith_TPithdel_geq in H6; try omega.
  replace (i - 1 + 1) with i in *|-; try omega.
  rewrite 2 TPithdel_Fc_eq; try omega.
  repeat split~; try omega; trivial.
  case (nat_eqdec i0 0); intro H9. rewrite H9 in *|-.
  rewrite TPith_0 in H0_. rewrite TPithdel_0 in H7.

  apply equiv_AC with (i:=1); simpl set_In;
  repeat split~; try rewrite TPlength_TPithdel; try omega; trivial.
  autorewrite with tuples.
  rewrite 2 TPith_TPithdel_lt; try omega; trivial.
  case (nat_eqdec (TPlength t 1 n) 2); intro H10.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7; try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_geq_comm in H7; try omega.
  rewrite TPithdel_geq_comm with (i:=j) in H7; try omega.
  replace (i - 1 + 1) with i in H7; try omega; trivial.

  apply equiv_AC with (i:=i0); simpl set_In;
  repeat split~; try rewrite TPlength_TPithdel; try omega; trivial.
  autorewrite with tuples.
  rewrite 2 TPith_TPithdel_lt; try omega; trivial.
  case (nat_eqdec (TPlength t 1 n) 2); intro H10.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7; try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_geq_comm in H7; try omega.
  rewrite TPithdel_geq_comm with (i:=j) in H7; try omega.
  replace (i - 1 + 1) with i in H7; try omega; trivial.

  exists j.
  rewrite TPith_TPithdel_geq in H6; try omega.
  rewrite TPith_TPithdel_lt in H6; try omega.
  replace (i - 1 + 1) with i in *|-; try omega.
  rewrite 2 TPithdel_Fc_eq; try omega. autorewrite with tuples.
  repeat split~; try omega; trivial.

  case (le_dec i0 (TPlength t' 1 n)); intro H9.

  apply equiv_AC with (i:=i0-1); simpl set_In;
  repeat split~; try rewrite TPlength_TPithdel; try omega; trivial.
  autorewrite with tuples. rewrite TPith_TPithdel_lt; try omega; trivial.
  rewrite TPith_TPithdel_geq; try omega; trivial.
  replace (i0 - 1 + 1) with i0; try omega; trivial.
  case (nat_eqdec (TPlength t 1 n) 2); intro H10.
  assert (Qi0:i0=2). omega. rewrite Qi0.
  replace (2-1) with 1; try omega.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7; try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_geq_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=j) in H7; try omega.
  replace (i - 1 + 1) with i in H7; try omega; trivial.

  rewrite TPithdel_overflow with (i:=i0) in H7; try omega.
  rewrite TPith_overflow with (i:=i0) in H0_; try omega.

  apply equiv_AC with (i:=TPlength t' 1 n -1); simpl set_In;
  repeat split~; try rewrite TPlength_TPithdel; try omega; trivial.
  autorewrite with tuples. rewrite TPith_TPithdel_lt; try omega; trivial.
  rewrite TPith_TPithdel_geq; try omega; trivial.
  replace (TPlength t' 1 n - 1 + 1) with (TPlength t' 1 n); try omega; trivial.
  case (nat_eqdec (TPlength t 1 n) 2); intro H10.
  assert (Qi0:TPlength t' 1 n=2). omega. rewrite Qi0.
  replace (2-1) with 1; try omega.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7; try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_geq_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=j) in H7; try omega.
  replace (i - 1 + 1) with i in H7; try omega; trivial.

  exists 1.
  rewrite TPlength_Fc_diff;
  try rewrite 2 TPith_Fc_diff;
  try rewrite 2 TPithdel_Fc_diff; trivial.
  repeat split~; try omega.
  apply equiv_AC with (i:=i0); simpl set_In; try omega; trivial.

  simpl in H2. clear H0. case (nat_pair_eqdec (2,n0) (E,n)); intro H4.
  inverts H4. autorewrite with tuples in H3|-*. simpl in H3.
  case H with (m := term_size (<|s0,s1|>)) (i:=i) (t:=<| s0, s1 |>) (t':=<| t0, t1 |>);
    simpl TPlength; simpl term_size; try omega.
  apply equiv_Pr; trivial. intros j Hj. exists j. autorewrite with tuples.
  rewrite 2 TPithdel_Fc_eq. destruct Hj. destruct H4. destruct H5.
  repeat split~. apply equiv_Fc_c; trivial.
  assert (Q: TPlength t0 2 n >=1 /\ TPlength t1 2 n >=1). split~. simpl. omega.
  assert (Q: TPlength s0 2 n >=1 /\ TPlength s1 2 n >=1). split~. simpl. omega.
  exists 1. rewrite TPlength_Fc_diff in *|-*; trivial.
  assert (i=1). omega. rewrite H0. rewrite 2 TPith_Fc_diff; trivial.
  rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
  repeat split~. apply equiv_C1; trivial. simpl. right~.

  simpl in H2. clear H0. case (nat_pair_eqdec (2,n0) (E,n)); intro H4.
  inverts H4. autorewrite with tuples in H3. simpl in H3.

  generalize H0_ H0_0. intros H' H''.
  apply aacc_equiv_TPlength with (E:=2) (n:=n) in H'.
  apply aacc_equiv_TPlength with (E:=2) (n:=n) in H''.
  assert (Q: TPlength s0 2 n >=1 /\ TPlength s1 2 n >=1). split~.

  case (le_dec i (TPlength s0 2 n)); intro H7.

  case H with (m := term_size (<|s0,s1|>)) (i:=TPlength s1 2 n + i) (t:=<| s1, s0 |>) (t':=<| t0, t1 |>);
    simpl term_size; try omega; clear H.
  apply equiv_Pr; trivial.
  simpl; omega. intros j Hj. destruct Hj. destruct H0. destruct H4.
  exists j. autorewrite with tuples.

  rewrite 2 TPithdel_Fc_eq; simpl TPlength; try omega.
  case (le_dec j (TPlength t0 2 n)); intro H8.
  repeat split~; try omega.
  rewrite 2 TPith_Pr_le; trivial.
  rewrite TPith_Pr_gt in H4; try omega. rewrite TPith_Pr_le in H4; trivial.
  replace (TPlength s1 2 n + i - TPlength s1 2 n) with i in H4;try omega; trivial.
  case (nat_eqdec (TPlength s0 2 n) 1); intro H9.
  rewrite TPithdel_t1_Pr; try omega.
  rewrite TPithdel_t2_Pr in H5; try omega.
  apply equiv_Fc_c; trivial.
  rewrite TPithdel_Pr_le; trivial.
  rewrite TPithdel_Pr_gt in H5; try omega.
  replace (TPlength s1 2 n + i - TPlength s1 2 n) with i in H5; try omega.
  case (nat_eqdec (TPlength t0 2 n) 1); intro H10.
  rewrite TPithdel_t1_Pr; try omega.
  rewrite TPithdel_t1_Pr in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl; right~.
  rewrite TPithdel_Pr_le; try omega.
  rewrite TPithdel_Pr_le in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl; right~.

  repeat split~; try omega.
  rewrite TPith_Pr_le; trivial.
  rewrite TPith_Pr_gt; try omega.
  rewrite TPith_Pr_gt in H4; try omega. rewrite TPith_Pr_gt in H4; try omega.
  replace (TPlength s1 2 n + i - TPlength s1 2 n) with i in H4;try omega; trivial.
  case (nat_eqdec (TPlength s0 2 n) 1); intro H9.
  rewrite TPithdel_t1_Pr; try omega.
  rewrite TPithdel_t2_Pr in H5; try omega.
  apply equiv_Fc_c; trivial.
  rewrite TPithdel_Pr_le; trivial.
  rewrite TPithdel_Pr_gt in H5; try omega.
  replace (TPlength s1 2 n + i - TPlength s1 2 n) with i in H5; try omega.
  case (nat_eqdec (TPlength t1 2 n) 1); intro H10.
  rewrite TPithdel_t2_Pr; try omega.
  rewrite TPithdel_Pr_gt; try omega.
  rewrite TPithdel_Pr_gt in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl; right~.

  case H with (m := term_size (<|s0,s1|>)) (i:=i - TPlength s0 2 n) (t:=<| s1, s0 |>) (t':=<| t0, t1 |>);
    simpl term_size; try omega; clear H.
  apply equiv_Pr; trivial.
  simpl; omega. intros j Hj. destruct Hj. destruct H0. destruct H4.
  exists j. autorewrite with tuples.

  rewrite 2 TPithdel_Fc_eq; simpl TPlength; try omega.
  case (le_dec j (TPlength t0 2 n)); intro H8.
  repeat split~; try omega.
  rewrite TPith_Pr_gt; try omega.
  rewrite TPith_Pr_le; try omega.
  rewrite 2 TPith_Pr_le in H4; try omega; trivial.
   case (nat_eqdec (TPlength s1 2 n) 1); intro H9.
  rewrite TPithdel_t2_Pr; try omega.
  rewrite TPithdel_t1_Pr in H5; try omega.
  apply equiv_Fc_c; trivial.
  rewrite TPithdel_Pr_gt; try omega.
  rewrite TPithdel_Pr_le in H5; try omega.
  case (nat_eqdec (TPlength t0 2 n) 1); intro H10.
  rewrite TPithdel_t1_Pr; try omega.
  rewrite TPithdel_Pr_le; try omega.
  rewrite TPithdel_Pr_le in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl; right~.

  repeat split~; try omega.
  rewrite 2 TPith_Pr_gt; try omega.
  rewrite TPith_Pr_le in H4; try omega. rewrite TPith_Pr_gt in H4; try omega; trivial.
   case (nat_eqdec (TPlength s1 2 n) 1); intro H9.
  rewrite TPithdel_t2_Pr; try omega.
  rewrite TPithdel_t1_Pr in H5; try omega.
  apply equiv_Fc_c; trivial.
  rewrite TPithdel_Pr_gt; try omega.
  rewrite TPithdel_Pr_le in H5; try omega.
   case (nat_eqdec (TPlength t1 2 n) 1); intro H10.
  rewrite TPithdel_t2_Pr; try omega.
  rewrite TPithdel_t2_Pr in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl; right~.
  rewrite TPithdel_Pr_gt; try omega.
  rewrite TPithdel_Pr_gt in H5; try omega. inverts H5.
  apply equiv_C2; trivial. simpl. right~.

  exists 1. rewrite TPlength_Fc_diff in *|-*; trivial.
  assert (i=1). omega. rewrite H0. rewrite 2 TPith_Fc_diff; trivial.
  rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
  repeat split~. apply equiv_C2; trivial. simpl. right~.

Qed.

Lemma aacc_equiv_TPith_l' : forall C t t' E n,  C |- t ~aacc t' ->
                           forall i, exists j, C |- TPith i t E n ~aacc TPith j t' E n /\
                                               C |- TPithdel i t E n ~aacc TPithdel j t' E n.
Proof.
  intros. case (nat_eqdec i 0); intro H0.
  rewrite H0. rewrite TPith_0. rewrite TPithdel_0.
  apply aacc_equiv_TPith_l with (i:=1) (E:=E) (n:=n) in H; try omega; auto.
  destruct H. destruct H. destruct H1. destruct H2.
  exists x. split~.
  case (le_dec i (TPlength t E n)); intro H1.
  apply aacc_equiv_TPith_l with (i:=i) (E:=E) (n:=n) in H; try omega.
  destruct H. destruct H. destruct H2. destruct H3.
  exists x. split~.
  rewrite TPith_overflow; try omega.
  rewrite TPithdel_overflow; try omega.
  apply aacc_equiv_TPith_l with (i:=TPlength t E n) (E:=E) (n:=n) in H; try omega; auto.
  destruct H. destruct H. destruct H2. destruct H3.
  exists x. split~.
Qed.

(** Transitivity of aacc_equiv *)

Lemma aacc_equiv_trans : forall C t1 t2 t3,
 C |- t1 ~aacc t2 -> C |- t2 ~aacc t3 -> C |- t1 ~aacc t3.
Proof.
 introv. gen_eq l : (term_size t1). gen t1 t2 t3.
 induction l using peano_induction; intros.

 inverts H1; inverts H2; auto; simpl term_size in *|-; try omega; try contradiction.

 simpl in H0. apply equiv_Pr.
 apply H with (t2 := t1') (m := term_size t0); try omega; trivial.
 apply H with (t2 := t2') (m := term_size t4); try omega; trivial.

 simpl in H0. apply equiv_Fc; trivial.
 destruct H3. left~. destruct H1. right~. split~.
 destruct H2. left~. right~. apply aacc_neg_is_Pr in H10.
 apply H10; trivial.

 apply H with (t2 := t') (m := term_size t); try omega; trivial.

 false. destruct H3. apply H1. simpl. left~.
 destruct H1. omega.
 false. destruct H3. apply H1. simpl. right~.
 destruct H1. omega.
 inverts H4. destruct H3; try contradiction.
 destruct H1. simpl in H2. false. destruct H2; apply H2; trivial.
 inverts H4. destruct H3; try contradiction.
 destruct H1. simpl in H2. false. destruct H2; apply H2; trivial.

 apply equiv_Ab_1.
 apply H with (t2 := t') (m := term_size t); try omega; trivial.
 simpl in H0. apply equiv_Ab_2; trivial.
 apply H with (t2 := t') (m := term_size t); try omega; trivial.
 simpl in H0. apply equiv_Ab_2; trivial.
 apply H with (t2 := ((|[(a, a')]|) @ t')) (m := term_size t); try omega; trivial.
 apply aacc_equivariance; trivial.
 apply aacc_equiv_fresh with (a:=a) in H9; trivial.

 case (atom_eqdec a a'0); intro H1. rewrite H1.
 simpl in H0. apply equiv_Ab_1.
 apply H with (t2 := ((|[(a, a')]|) @ t')) (m := term_size t); try omega; trivial.
 apply aacc_equiv_swap_inv_side. rewrite H1. trivial.

 assert (Q:  C |- a # t'0).
  apply aacc_equiv_fresh with (a:=a) in H9; trivial.
  apply fresh_lemma_1 in H9. simpl rev in H9.
  rewrite swap_neither in H9; auto.
 apply equiv_Ab_2; trivial.
 assert (Q' : C |- t ~aacc ((|[(a, a')]|) @ ((|[(a', a'0)]|) @ t'0))).
  apply H with (t2 := ((|[(a, a')]|) @ t')) (m := term_size t); trivial.
  simpl in H0. omega. apply aacc_equivariance; trivial.
 apply aacc_alpha_equiv_trans.
 exists (((|[(a, a')]|) @ ((|[(a', a'0)]|) @ t'0))); split~.
 apply alpha_equiv_trans with
 (t2 := (|[((|[(a,a')]|) $ a', (|[(a,a')]|) $ a'0)]|) @ ((|[(a, a')]|) @ t'0)).
 apply alpha_equiv_pi_comm. rewrite swap_right. rewrite swap_neither; trivial.
 apply alpha_equiv_equivariance. apply alpha_equiv_swap_neither; trivial.

 apply equiv_Su; intros.
 case (In_ds_dec p p' a); intros. apply H3; trivial.
 apply H7. apply not_In_ds in H2. unfold In_ds in *|-*.
 rewrite <- H2; trivial.

 false. destruct H10. apply H1. simpl. left~.
 destruct H1. omega.

 apply equiv_A; simpl set_In; try omega.
 autorewrite with tuples in *|-*.
 apply H with (m:=term_size (TPith 1 t 0 n))
              (t2:=  TPith 1 t' 0 n); trivial.
 assert (Q: term_size (TPith 1 t 0 n) <= term_size t).
  apply term_size_TPith.
 omega.
 assert (Q0: C |- Fc 0 n t ~aacc Fc 0 n t').
  apply equiv_A; simpl set_In; try omega; trivial.
 assert (Q1: C |- Fc 0 n t' ~aacc Fc 0 n t'0).
  apply equiv_A; simpl set_In; try omega; trivial.
 apply aacc_equiv_TPlength with (E:=0) (n:=n) in Q0.
 apply aacc_equiv_TPlength with (E:=0) (n:=n) in Q1.
 autorewrite with tuples in *|-.
 case (nat_eqdec (TPlength t 0 n) 1); intro H8.
 rewrite 2 TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq in *|-*; autorewrite with tuples; try omega.
 apply H with (t2:=Fc 0 n (TPithdel 1 t' 0 n))
              (m:=term_size (Fc 0 n (TPithdel 1 t 0 n))); trivial.
 assert (Q2 : term_size (TPithdel 1 t 0 n) < term_size t).
  apply term_size_TPithdel; trivial.
 simpl. omega.

 false. destruct H10. apply H1. simpl. right~.
 destruct H1. omega.

 assert (Q0: C |- Fc 1 n t ~aacc Fc 1 n t').
  apply equiv_AC with (i:=i); repeat split~; simpl set_In; try omega; trivial.
 assert (Q1: C |- Fc 1 n t' ~aacc Fc 1 n t'0).
  apply equiv_AC with (i:=i0); repeat split~; simpl set_In; try omega; trivial.
 generalize Q1; intro Q2.
 apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q0. autorewrite with tuples in Q0.
 apply aacc_equiv_TPlength with (E:=1) (n:=n) in Q1. autorewrite with tuples in Q1.
 apply aacc_equiv_TPith_l' with (i:=i) (E:=1) (n:=n) in Q2;
 autorewrite with tuples; try omega.
 destruct Q2. destruct H1.
 apply equiv_AC with (i:=x); try split~; simpl set_In; try omega;
 autorewrite with tuples in *|-*; trivial.
 apply H with (t2:=TPith i t' 1 n) (m:=term_size (TPith 1 t 1 n)); trivial.
 assert (Q2 : term_size (TPith 1 t 1 n) <= term_size t).
  apply term_size_TPith.
 omega.
 case (nat_eqdec (TPlength t 1 n) 1); intro H12.
 rewrite 2 TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq in *|-*; autorewrite with tuples; try omega.
 apply H with (t2:=Fc 1 n (TPithdel i t' 1 n)) (m:=term_size (Fc 1 n (TPithdel 1 t 1 n))); trivial.
 assert (Q2 : term_size (TPithdel 1 t 1 n) < term_size t).
  apply term_size_TPithdel; trivial.
 simpl. omega.

 inverts H11. destruct H10; try contradiction.
 destruct H1. simpl in H2. false. destruct H2; apply H2; trivial.

 apply equiv_C1. simpl. right~.
  apply H with (t2 := t0) (m := term_size s0); try omega; trivial.
  apply H with (t2 := t4) (m := term_size s1); try omega; trivial.

 apply equiv_C2. simpl. right~.
  apply H with (t2 := t0) (m := term_size s0); try omega; trivial.
  apply H with (t2 := t4) (m := term_size s1); try omega; trivial.

 inverts H11. destruct H10; try contradiction.
 destruct H1. simpl in H2. false. destruct H2; apply H2; trivial.

 apply equiv_C2. simpl. right~.
  apply H with (t2 := t4) (m := term_size s0); try omega; trivial.
  apply H with (t2 := t0) (m := term_size s1); try omega; trivial.

 apply equiv_C1. simpl. right~.
  apply H with (t2 := t4) (m := term_size s0); try omega; trivial.
  apply H with (t2 := t0) (m := term_size s1); try omega; trivial.

Qed.

(** In AC choosing the ith element is arbitrary in both sides *)

Lemma aacc_equiv_AC : forall C t t' i j n,
      C |- TPith i (Fc 1 n t) 1 n ~aacc TPith j (Fc 1 n t') 1 n  ->
      C |- TPithdel i (Fc 1 n t) 1 n ~aacc TPithdel j (Fc 1 n t') 1 n ->
                           C |- Fc 1 n t ~aacc Fc 1 n t'.
Proof.
  intros. gen_eq l : (TPlength t 1 n); intro H1.
  gen t t' H1 i j. induction l using peano_induction; intros.
  case (nat_eqdec i 1); intro Qi. rewrite Qi in *|-.
  apply equiv_AC with (i:=j); repeat split~; simpl set_In;
  try omega; trivial.
  case (nat_eqdec i 0); intro Qi'. rewrite Qi' in *|-.
  repeat rewrite TPith_0 in *|-; repeat rewrite TPithdel_0 in *|-.
  apply equiv_AC with (i:=j); simpl set_In; try omega; trivial.

  case (nat_eqdec (TPlength t 1 n) 1);
  case (nat_eqdec (TPlength t' 1 n) 1); intros H3 H4.
  apply equiv_AC with (i:=j); simpl set_In; try omega.
  autorewrite with tuples in *|-*.
  try rewrite TPith_overflow with (i:=i) in H0; try omega.
  rewrite H4 in H0; trivial.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples; trivial.
  rewrite TPithdel_TPlength_1 in H2; autorewrite with tuples; trivial.
  rewrite TPithdel_Fc_eq in H2; trivial. inverts H2.
  rewrite TPithdel_Fc_eq in H2; trivial.
  rewrite TPithdel_TPlength_1 with (t:= (Fc 1 n t'))in H2;
  autorewrite with tuples; trivial. inverts H2.
  rewrite 2 TPithdel_Fc_eq in H2; try omega.
  autorewrite with tuples in H0.
  generalize H2; intro H2'.
  apply aacc_equiv_TPlength with (E:=1) (n:=n) in H2'.
  autorewrite with tuples in H2'.
  rewrite 2 TPlength_TPithdel in H2'; try omega; trivial.
  apply aacc_equiv_TPith_l1 with (E:=1) (n:=n) in H2.
  destruct H2. destruct H2. destruct H5. destruct H6.
  autorewrite with tuples in *|-.
  rewrite TPlength_TPithdel in *|-; try omega.

  case (le_dec j x); intro H8.

  rewrite TPith_TPithdel_lt in H6; try omega.
  rewrite TPith_TPithdel_geq in H6; try omega.
  apply equiv_AC with (i:=x+1);
  repeat split~; simpl set_In; try omega; trivial;
  try rewrite 2 TPithdel_Fc_eq; try omega.
  autorewrite with tuples; trivial.
  apply H with (i:=i-1) (j:=j) (m:=TPlength (TPithdel 1 t 1 n) 1 n);
  try rewrite TPlength_TPithdel; autorewrite with tuples; try omega.

  case (le_dec i (TPlength t 1 n)); intro H9.
  rewrite TPith_TPithdel_geq; try omega.

  case (nat_eqdec j 0); intro H10; try rewrite H10 in *|-*;
  repeat rewrite TPith_0 in *|-*;
  rewrite TPith_TPithdel_lt; try omega;
  replace (i -1 + 1) with i; try omega; trivial.
  rewrite TPith_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPith_overflow with (i:=i) in H0; try omega.
  rewrite TPith_TPithdel_geq; try omega.
  case (nat_eqdec j 0); intro H10; try rewrite H10 in *|-*;
  repeat rewrite TPith_0 in *|-*;
  rewrite TPith_TPithdel_lt; try omega;
  replace (TPlength t 1 n -1 + 1) with (TPlength t 1 n); try omega; trivial.

  case (nat_eqdec (TPlength t 1 n) 2); intro H9.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.

  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7;
  try rewrite TPlength_TPithdel; try omega.

  case (le_dec i (TPlength t 1 n)); intro H10.

  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_geq_comm with (i:=x) in H7; try omega; trivial.

  rewrite TPithdel_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_overflow with (i:=i) in H7; try omega.
  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_geq_comm with (i:=x) in H7; try omega; trivial.

  rewrite 2 TPith_TPithdel_lt in H6; try omega.
  apply equiv_AC with (i:=x);
  repeat split~; simpl set_In; try omega; trivial;
  try rewrite 2 TPithdel_Fc_eq; try omega. autorewrite with tuples; trivial.

  apply H with (i:=i-1) (j:=j-1) (m:=TPlength (TPithdel 1 t 1 n) 1 n);
  try rewrite TPlength_TPithdel; try omega.
  autorewrite with tuples.

  case (le_dec i (TPlength t 1 n));
  case (le_dec j (TPlength t 1 n)); intros H9 H10.

  rewrite 2 TPith_TPithdel_geq; try omega.
  replace (i -1 + 1) with i; try omega.
  replace (j -1 + 1) with j; try omega; trivial.

  rewrite TPith_overflow with (i:=j-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPith_overflow with (i:=j) in H0; try omega.
  rewrite 2 TPith_TPithdel_geq; try omega.
  replace (i -1 + 1) with i; try omega.
  replace (TPlength t' 1 n -1 + 1) with (TPlength t' 1 n); try omega; trivial.

  rewrite TPith_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPith_overflow with (i:=i) in H0; try omega.
  rewrite 2 TPith_TPithdel_geq; try omega.
  replace (j -1 + 1) with j; try omega.
  replace (TPlength t 1 n -1 + 1) with (TPlength t 1 n); try omega; trivial.

  rewrite TPith_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPith_overflow with (i:=j-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPith_overflow with (i:=i) in H0; try omega.
  rewrite TPith_overflow with (i:=j) in H0; try omega.
  rewrite 2 TPith_TPithdel_geq; try omega.
  replace (TPlength t' 1 n -1 + 1) with (TPlength t' 1 n); try omega; trivial.
  replace (TPlength t 1 n -1 + 1) with (TPlength t 1 n); try omega; trivial.

  case (nat_eqdec (TPlength t 1 n) 2); intro H10.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples;
  try rewrite TPlength_TPithdel; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPithdel_Fc_eq in H7;
  try rewrite TPlength_TPithdel; try omega.

  case (le_dec i (TPlength t 1 n));
  case (le_dec j (TPlength t 1 n)); intros H11 H12.

  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=x) in H7; try omega; trivial.

  rewrite TPithdel_overflow with (i:=j-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_overflow with (i:=j) in H7; try omega.
  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=x) in H7; try omega; trivial.

  rewrite TPithdel_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_overflow with (i:=i) in H7; try omega.
  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=x) in H7; try omega; trivial.

  rewrite TPithdel_overflow with (i:=i-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_overflow with (i:=j-1);
  try rewrite TPlength_TPithdel; try omega.
  rewrite TPithdel_overflow with (i:=i) in H7; try omega.
  rewrite TPithdel_overflow with (i:=j) in H7; try omega.
  rewrite TPithdel_lt_comm in H7; try omega.
  rewrite TPithdel_lt_comm with (i:=x) in H7; try omega; trivial.
Qed.

(** Symmetry of aacc_equiv *)

Lemma aacc_equiv_sym : forall C t1 t2, C |- t1 ~aacc t2 -> C |- t2 ~aacc t1 .
Proof.
 intros. induction H; auto; try omega; trivial.

 apply equiv_Fc; trivial. destruct H.
 left~. right~. destruct H. split~.
 destruct H1. right~. left~.

 assert (Q0 : C |- t' ~aacc ((|[(a', a)]|) @ t)).
  apply aacc_equiv_trans with (t2 := (|[(a, a')]|) @ t).
  apply aacc_equiv_trans with (t2 := (|[(a, a')]|) @ ((|[(a, a')]|) @ t')).
  apply aacc_alpha_equiv_trans. exists t'. split~.
  replace (|[(a, a')]|) with (!(|[(a, a')]|)).
  apply perm_inv_side. apply alpha_equiv_refl. simpl; trivial.
  apply aacc_equivariance; trivial.  apply aacc_equiv_swap_comm.
 assert (Q1 : C |- a # ((|[(a', a)]|) @ t)).
  apply aacc_equiv_fresh with (t1 := t'); trivial.
 apply fresh_lemma_1 in Q1. simpl rev in Q1. rewrite swap_right in Q1.
 apply equiv_Ab_2; trivial; auto.

 apply equiv_Su. intros. apply H. apply ds_sym. trivial.

 apply aacc_equiv_AC with (i:=i) (j:=1); try omega; trivial.
Qed.

Lemma aacc_equiv_sub_context : forall C C' s t,
      sub_context C C' -> C |- s ~aacc t -> C' |- s ~aacc t.
Proof.
  intros. induction H0.
  apply equiv_Ut. apply equiv_At.
  apply equiv_Pr.
   apply IHequiv1; trivial.
   apply IHequiv2; trivial.
  apply aacc_equiv_Fc.
   apply IHequiv; trivial.
  apply equiv_Ab_1.
   apply IHequiv; trivial.
  apply equiv_Ab_2; trivial.
   apply IHequiv; trivial.
  apply fresh_lemma_3 with (C:=C); trivial.
  apply equiv_Su; intros.
   unfold sub_context in H.
   apply H. apply H0; trivial.
  apply equiv_A; trivial.
   apply IHequiv1; trivial.
   apply IHequiv2; trivial.
  apply equiv_AC with (i:=i); trivial.
   apply IHequiv1; trivial.
   apply IHequiv2; trivial.
  apply equiv_C1; trivial.
   apply IHequiv1; trivial.
   apply IHequiv2; trivial.
  apply equiv_C2; trivial.
   apply IHequiv1; trivial.
   apply IHequiv2; trivial.
Qed.

(** Soundness of aacc_equiv *)

Theorem aacc_equivalence : forall C, Equivalence (equiv (0::1::|[2]|) C).
Proof.
  split~.
  unfold Symmetric; intros. apply aacc_equiv_sym; trivial.
  unfold Transitive; intros. apply aacc_equiv_trans with (t2:=y); trivial.
Qed.

(** Soundness of a_equiv *)

Corollary a_equivalence : forall C, Equivalence (equiv (|[0]|) C).
Proof.
  intros. apply subset_equivalence with (S2:=0::1::|[2]|).
  unfold subset. simpl; intros. omega.
  unfold proper_equiv_Fc; intros. apply aacc_equiv_Fc; trivial.
  apply aacc_equivalence.
Qed.

(** Soundness of ac_equiv *)

Corollary ac_equivalence : forall C, Equivalence (equiv (|[1]|) C).
Proof.
  intros. apply subset_equivalence with (S2:=0::1::|[2]|).
  unfold subset. simpl; intros. omega.
  unfold proper_equiv_Fc; intros. apply aacc_equiv_Fc; trivial.
  apply aacc_equivalence.
Qed.

(** Soundness of c_equiv *)

Corollary c_equivalence : forall C, Equivalence (equiv (|[2]|) C).
Proof.
  intros. apply subset_equivalence with (S2:=0::1::|[2]|).
  unfold subset. simpl; intros. omega.
  unfold proper_equiv_Fc; intros. apply aacc_equiv_Fc; trivial.
  apply aacc_equivalence.
Qed.

(** Soundness of acc_equiv *)

Corollary acc_equivalence : forall C, Equivalence (equiv (1::|[2]|) C).
Proof.
  intros. apply subset_equivalence with (S2:=0::1::|[2]|).
  unfold subset. simpl; intros. omega.
  unfold proper_equiv_Fc; intros. apply aacc_equiv_Fc; trivial.
  apply aacc_equivalence.
Qed.

Corollary aacc_perm_inv_side : forall C pi s t, C |- (!pi) @ s ~aacc t -> C |- s ~aacc (pi @ t).
Proof.
  intros.
  apply aacc_equivariance with (pi:=pi) in H.
  apply aacc_equiv_trans with (t2:= pi @ ((!pi) @ s)); trivial.
  apply aacc_alpha_equiv_trans. exists s. split~.
  rewrite perm_comp. gen_eq g : (!pi); intro H0.
  replace pi with (!g). apply alpha_equiv_sym.
  apply alpha_equiv_perm_inv. rewrite H0.
  rewrite rev_involutive. trivial.
Qed.

Corollary aacc_perm_inv_side' : forall C pi s t, C |- s ~aacc (pi @ t) <-> C |- (!pi) @ s ~aacc t.
Proof.
  intros. split~; intro.
  apply aacc_equiv_sym.
  apply aacc_perm_inv_side.
  rewrite rev_involutive.
  apply aacc_equiv_sym. trivial.
  apply aacc_perm_inv_side; trivial.
Qed.

(** Some results about collections of arguments of a term *)

Lemma aacc_Args_col_TPith_TPithdel : forall L0 L1 C s t E n,

    C |- (Args_col L0 ([]) s E n) ~aacc (Args_col L1 ([]) t E n) ->

    forall i,

      C |- TPith i (Args_col L0 ([]) s E n) E n ~aacc
           TPith i (Args_col L1 ([]) t E n) E n
      /\

      C |- TPithdel i (Args_col L0 ([]) s E n) E n ~aacc
           TPithdel i (Args_col L1 ([]) t E n) E n
.

Proof.
  intros.

  unfold Args_col in H|-*.
  rewrite Args_assoc_nil in H|-*.

  replace (Args_assoc 0 ([]) (Args_col_list L1 t E n))
          with (Args_right_assoc (Args_col_list L1 t E n)) in *|-*.

  gen_eq l : (length L0); intro H0.
  gen H0 H. gen i L0 L1 s t.

  induction l using peano_induction; intros.

  destruct L0.
  simpl Args_col_list in H1|-*.
  simpl in *|-*. inverts H1. simpl. auto.
  destruct L1. simpl Args_col_list in H1|-*.

  gen_eq L2 : (TPith n0 s E n :: Args_col_list L0 s E n).
  intro H2. simpl. inverts H1. simpl. auto.

  assert (Q : length L0 = length L1).
   apply aacc_equiv_TPlength with (E:=E) (n:=n) in H1.
   rewrite 2 Args_right_assoc_TPlength in H1; simpl; try omega; trivial.
   simpl in H1. omega.
  simpl in H0.

  simpl Args_col_list in *|-*.

  case (nil_eqdec _ term_eqdec (Args_col_list L0 s E n)); intro H2.
  rewrite H2 in *|-*. apply length_zero_iff_nil in H2.
  rewrite Args_col_list_length in H2.
  rewrite Q in H2. apply length_zero_iff_nil in H2.
  rewrite H2 in H1|-*. simpl in H1|-*.
  rewrite 2 TPith_TPith. split~.
  rewrite 2 TPithdel_TPlength_1; auto.
  rewrite TPlength_TPith; trivial.
  rewrite TPlength_TPith; trivial.

  assert (H4: Args_col_list L1 t E n <> []).
   intro H3. apply H2.
   apply length_zero_iff_nil in H3.
   apply length_zero_iff_nil.
   rewrite Args_col_list_length.
   rewrite Args_col_list_length in H3. omega.

  assert (H5 : length (Args_col_list L0 s E n) <> 0).
   intro H5. apply length_zero_iff_nil in H5. contradiction.
  assert (H6 : length (Args_col_list L1 t E n) <> 0).
   intro H6. apply length_zero_iff_nil in H6. contradiction.

  rewrite 2 Args_right_assoc_cons in *|-*; trivial.
  inverts H1.

  case (le_dec i 1); intro H7.
  rewrite 2 TPith_Pr_le;
    try rewrite TPlength_TPith; trivial.
  rewrite 2 TPithdel_t1_Pr;
    try rewrite TPlength_TPith; trivial.
  split~. rewrite 2 TPith_TPith; trivial.

  rewrite 2 TPith_Pr_gt;
    try rewrite TPlength_TPith; try omega.

  rewrite 1 TPlength_TPith.
  split~.
  apply H with (m:= length L0); try omega. trivial.

  case (nat_eqdec (length L0) 1); intro H13.

  rewrite 2 TPithdel_t2_Pr;
    try rewrite TPlength_TPith; try omega; trivial.
  rewrite Args_right_assoc_TPlength; try omega.
  rewrite Args_right_assoc_TPlength; try omega.

  rewrite Args_col_list_length in H5.
  rewrite Args_col_list_length in H6.

  rewrite 2 TPithdel_Pr_gt;
    try rewrite TPlength_TPith; try omega.
  apply equiv_Pr; trivial.
  rewrite TPlength_TPith.
  apply H with (m:= length L0); try omega. trivial.
  rewrite Args_right_assoc_TPlength; try omega.
  rewrite Args_right_assoc_TPlength; try omega.

  symmetry. apply Args_assoc_nil.
Qed.

Lemma aacc_equiv_Args_col_AC : forall L0 L1 C n s t,

      valid_col L0 s 1 n -> valid_col L1 t 1 n ->

      length L0 = TPlength s 1 n ->
      length L1 = TPlength t 1 n ->

      C |- (Args_col L0 ([]) s 1 n) ~aacc
           (Args_col L1 ([]) t 1 n) ->

           C |- Fc 1 n s ~aacc Fc 1 n t .

Proof.

  intros. gen_eq l : (length L0). intro H4.
  gen H4 H H0 H1 H2 H3. gen L0 L1 s t.
  induction l using peano_induction; intros.

  assert (Q : TPlength s 1 n = TPlength t 1 n).
   apply aacc_equiv_TPlength with (E:=1) (n:=n) in H5.
   rewrite 2 Args_col_TPlength in H5; simpl; trivial; try omega.
   assert (TPlength t 1 n >= 1). auto. omega.
   apply NoDup_nil. intros. contradiction.
   assert (TPlength s 1 n >= 1). auto. omega.
   apply NoDup_nil. intros. contradiction.

  apply aacc_Args_col_TPith_TPithdel with (i:=1) in H5.
  destruct H5.

  case  Args_col_TPith_TPithdel
    with (L:=L0) (s:=s) (E:=1) (n:=n); trivial.
  assert (Q' : TPlength s 1 n >= 1). auto. omega.
  intros i H7. destruct H7.
  case H8; clear H8; intros L0' H8. destruct H8.
  destruct H9. destruct H10.
  rewrite H7 in H5. rewrite H8 in H6.

  case Args_col_TPith_TPithdel
    with (L:=L1) (s:=t) (E:=1) (n:=n); trivial.
  assert (Q' : TPlength t 1 n >= 1). auto. omega.
  intros j H12. destruct H12.
  case H13; clear H13; intros L1' H13. destruct H13.
  destruct H14. destruct H15.
  rewrite H12 in H5. rewrite H13 in H6.

  apply aacc_equiv_AC with (i:=i) (j:=j).
  autorewrite with tuples; trivial.

  case (nat_eqdec (TPlength s 1 n) 1); intro H17.
  rewrite 2 TPithdel_TPlength_1;
    autorewrite with tuples; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try omega.

  apply H with (m:=length L0') (L0 := L0') (L1 := L1');
    try omega; trivial.

  assert (Q' : TPlength s 1 n >= 1). auto. omega.
  rewrite TPlength_TPithdel; omega.
  rewrite TPlength_TPithdel; omega.

Qed.

Lemma aacc_equiv_Args_assoc : forall C L0 L1 L' i,

     length L0 = length L1 ->

      C |- Args_assoc i L' L0 ~aacc Args_assoc i L' L1  ->
      C |- Args_right_assoc L0 ~aacc Args_right_assoc L1 .

Proof.

  intros.  gen_eq l : (length L'). intro H1.
  gen H1 H H0. gen i L0 L1 L'.
  induction l using peano_induction; intros.

  destruct L'; simpl in *|-; trivial.
  inverts H2. apply H with (m := length L') in H9; try omega.
  gen_eq k : (n - i); intro H10.

  Focus 2.
(*  2:{ *)
  case (le_dec (n - i) (length L0)); intro H10.
   rewrite 2 tail_list_length; omega.
  rewrite 2 tail_list_overflow; try omega. (* } *)

  clear L' n i l H H1 H10.

  gen_eq l : (length L0); intro H10.
  gen H10 H0 H7 H9. gen L0 L1 k.
  induction l using peano_induction; intros.

  destruct L0. simpl in H10.
  assert (Q : L1 = []).
   rewrite H10 in H0. symmetry in H0.
   apply length_zero_iff_nil; trivial.
  rewrite Q in *|-*.
  destruct k; simpl in *|-*; trivial.
  simpl in H10. destruct L1; simpl in H0; try omega.

  case (nil_eqdec _ term_eqdec L0); intro H11.
  rewrite H11 in *|-*. simpl in H10.
  assert (Q : L1 = []).
   assert (length L1 = 0). omega.
   apply length_zero_iff_nil; trivial.
  rewrite Q in *|-*.
  destruct k; simpl in *|-*; trivial.
  destruct k; simpl in *|-; trivial.

  assert (Q0 : length L0 <> 0).
   intro H12;
    apply length_zero_iff_nil in H12; contradiction.

  assert (Q1 : length L1 <> 0).
   intro H12;
    apply length_zero_iff_nil in H12.
   rewrite H12 in H0. simpl in H0. omega.

  rewrite 2 Args_right_assoc_cons; trivial.

  case (nat_eqdec k 0); intro H12.
  rewrite H12 in *|-.
  simpl tail_list in *|-.
  rewrite 2 Args_right_assoc_cons in H9; trivial.

  case (nat_eqdec (k - 1) 0); intro H13.

  rewrite 2 head_list_cons in *|-; trivial.
  rewrite 2 tail_list_cons in *|-; trivial.

  rewrite H13 in *|-. simpl in *|-.

  apply equiv_Pr; trivial.

  case (le_dec k (length L0)); intro H14.

  rewrite 2 head_list_cons in *|-; trivial.
  rewrite 2 tail_list_cons in *|-; trivial.

  rewrite 2 Args_right_assoc_cons in *|-.

  inverts H7. apply equiv_Pr; trivial.
  apply H with (m := length L0) (k:=k-1); try omega; trivial.
  rewrite head_list_length; omega.
  rewrite head_list_length; omega.

  rewrite 2 head_list_overflow in *|-; simpl; try omega.
  rewrite 2 Args_right_assoc_cons in *|-; trivial.

Qed.