(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Error of the rounded-to-nearest addition is representable. *)

Require Import Psatz.
Require Import Raux Defs Float_prop Generic_fmt.
Require Import FIX FLX FLT Ulp Operations.
Require Import Relative.

Section Fprop_plus_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Section round_repr_same_exp.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_repr_same_exp :
  forall m e,
  exists m',
  round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e).
Proof with auto with typeclass_instances.
intros m e.
set (e' := cexp beta fexp (F2R (Float beta m e))).
unfold round, scaled_mantissa. fold e'.
destruct (Zle_or_lt e' e) as [He|He].
exists m.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- IZR_Zpower by lia.
rewrite <- mult_IZR, Zrnd_IZR...
unfold F2R. simpl.
rewrite mult_IZR.
rewrite Rmult_assoc.
rewrite IZR_Zpower by lia.
rewrite <- bpow_plus.
apply (f_equal (fun v => IZR m * bpow v)%R).
ring.
exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
unfold F2R. simpl.
rewrite mult_IZR.
rewrite IZR_Zpower by lia.
rewrite 2!Rmult_assoc.
rewrite <- 2!bpow_plus.
apply (f_equal (fun v => _ * bpow v)%R).
ring.
Qed.

End round_repr_same_exp.

Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Variable choice : Z -> bool.

Lemma plus_error_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y.
set (ex := cexp beta fexp x).
set (ey := cexp beta fexp y).
intros He Hx Hy.
destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0].
rewrite H0.
apply generic_format_0.
set (mx := Ztrunc (scaled_mantissa beta fexp x)).
set (my := Ztrunc (scaled_mantissa beta fexp y)).
(* *)
assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)).
rewrite Hx, Hy.
fold mx my ex ey.
rewrite <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := He).
(* *)
rewrite Hxy.
destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy').
rewrite Hxy'.
assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R =
  F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)).
now rewrite <- F2R_minus, Fminus_same_exp.
rewrite H.
apply generic_format_F2R.
intros _.
apply monotone_exp.
rewrite <- H, <- Hxy', <- Hxy.
apply mag_le_abs.
exact H0.
pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring.
rewrite Rabs_Ropp.
now apply (round_N_pt beta _ choice (x + y)).
Qed.

(** Error of the addition *)
Theorem plus_error :
  forall x y,
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y Hx Hy.
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)).
now apply plus_error_aux.
rewrite Rplus_comm.
apply plus_error_aux ; try easy.
now apply Zlt_le_weak.
Qed.

End Fprop_plus_error.

Section Fprop_plus_zero.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { exp_not_FTZ : Exp_not_FTZ fexp }.
Notation format := (generic_format beta fexp).

Section round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_plus_neq_0_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  (0 < x + y)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y He Hx Hy Hxy.
destruct (mag beta (x + y)) as (exy, Hexy).
simpl.
specialize (Hexy (Rgt_not_eq _ _ Hxy)).
destruct (Zle_or_lt exy (fexp exy)) as [He'|He'].
(* . *)
assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
  Ztrunc (y * bpow (- fexp exy))) (fexp exy))).
rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1.
rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1.
now rewrite <- F2R_plus, Fplus_same_exp.
rewrite H.
rewrite round_generic...
rewrite <- H.
now apply Rgt_not_eq.
apply generic_format_F2R.
intros _.
rewrite <- H.
unfold cexp.
rewrite mag_unique with (1 := Hexy).
apply Z.le_refl.
(* . *)
intros H.
elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)).
rewrite H.
rewrite round_generic...
apply bpow_gt_0.
apply generic_format_bpow.
apply Zlt_succ_le.
now rewrite (Zsucc_pred exy) in He'.
Qed.

End round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *)
Theorem round_plus_neq_0 :
  forall x y,
  format x -> format y ->
  (x + y <> 0)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hxy.
destruct (Rle_or_lt 0 (x + y)) as [H1|H1].
(* . *)
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2].
apply round_plus_neq_0_aux...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux ; try easy.
now apply Zlt_le_weak.
lra.
(* . *)
rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr.
rewrite round_opp.
apply Ropp_neq_0_compat.
destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2].
apply round_plus_neq_0_aux; try apply generic_format_opp...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux; try apply generic_format_opp...
now apply Zlt_le_weak.
lra.
Qed.

Theorem round_plus_eq_0 :
  forall x y,
  format x -> format y ->
  round beta fexp rnd (x + y) = 0%R ->
  (x + y = 0)%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
destruct (Req_dec (x + y) 0) as [H'|H'].
exact H'.
contradict H.
now apply round_plus_neq_0.
Qed.

End Fprop_plus_zero.

Section Fprop_plus_FLT.
Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem FLT_format_plus_small: forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
   (Rabs (x+y) <= bpow (prec+emin))%R ->
    generic_format beta (FLT_exp emin prec) (x+y).
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
apply generic_format_FLT_FIX...
rewrite Zplus_comm; assumption.
apply generic_format_FIX_FLT, FIX_format_generic in Fx.
apply generic_format_FIX_FLT, FIX_format_generic in Fy.
destruct Fx as [nx H1x H2x].
destruct Fy as [ny H1y H2y].
apply generic_format_FIX.
exists (Float beta (Fnum nx+Fnum ny)%Z emin).
rewrite H1x,H1y; unfold F2R; simpl.
rewrite H2x, H2y.
rewrite plus_IZR; ring.
easy.
Qed.

Variable choice : Z -> bool.

Lemma FLT_plus_error_N_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\
  round beta (FLT_exp emin prec) (Znearest choice) (x + y)
  = ((x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
assert (Pb := u_rod1pu_ro_pos beta prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M].
{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y))
    as (d, (Bd, Hd)).
  now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. }
exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r.
apply round_generic; [apply valid_rnd_N|].
apply FLT_format_plus_small; [exact Fx|exact Fy|].
apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia.
Qed.

Lemma FLT_plus_error_N_round_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec)%R /\
  (x + y
   = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex.
Qed.

End Fprop_plus_FLT.

Section Fprop_plus_mult_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Notation format := (generic_format beta fexp).
Notation cexp := (cexp beta fexp).

Lemma ex_shift :
  forall x e, format x -> (e <= cexp x)%Z ->
  exists m, (x = IZR m * bpow e)%R.
Proof with auto with typeclass_instances.
intros x e Fx He.
exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z.
rewrite Fx at 1; unfold F2R; simpl.
rewrite mult_IZR, Rmult_assoc.
f_equal.
rewrite IZR_Zpower by lia.
rewrite <- bpow_plus; f_equal; ring.
Qed.

Lemma mag_minus1 :
  forall z, z <> 0%R ->
  (mag beta z - 1)%Z = mag beta (z / IZR beta).
Proof.
intros z Hz.
unfold Zminus.
rewrite <- mag_mult_bpow by easy.
now rewrite bpow_opp, bpow_1.
Qed.

Theorem round_plus_F2R :
  forall x y, format x -> format y -> (x <> 0)%R ->
  exists m,
  round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))).
Proof with auto with typeclass_instances.
intros x y Fx Fy Zx.
case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1.
pose (e:=cexp (x / IZR beta)).
destruct (ex_shift x e) as (nx, Hnx); try exact Fx.
apply monotone_exp.
rewrite <- (mag_minus1 x Zx); lia.
destruct (ex_shift y e) as (ny, Hny); try assumption.
apply monotone_exp...
destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn).
exists n.
fold e.
rewrite <- Hn; f_equal.
rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring.
unfold F2R; simpl.
(* *)
destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn).
apply generic_format_round...
apply Z.le_trans with (cexp (x+y)).
apply monotone_exp.
rewrite <- mag_minus1 by easy.
rewrite <- (mag_abs beta (x+y)).
(* . *)
assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
assert (V: forall x y, (Rabs y <= Rabs x)%R ->
   (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
clear; intros x y.
case (Rle_or_lt 0 y); intros Hy.
case Hy; intros Hy'.
case (Rle_or_lt 0 x); intros Hx.
intros _; rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_pos_eq x) by easy.
left; apply Rabs_pos_eq.
now apply Rplus_le_le_0_compat.
rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_left x) by easy.
intros H; right; split.
now apply Rgt_not_eq.
rewrite Rabs_left1.
ring.
apply Rplus_le_reg_l with (-x)%R; ring_simplify; assumption.
intros _; left.
now rewrite <- Hy', Rabs_R0, 2!Rplus_0_r.
case (Rle_or_lt 0 x); intros Hx.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_pos_eq x) by easy.
intros H; right; split.
now apply Rlt_not_eq.
rewrite Rabs_pos_eq.
ring.
apply Rplus_le_reg_l with (-y)%R; ring_simplify; assumption.
intros _; left.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_left x) by easy.
rewrite Rabs_left1.
ring.
lra.
apply V; left.
apply lt_mag with beta.
now apply Rabs_pos_lt.
rewrite <- mag_minus1 in H1; try assumption.
rewrite 2!mag_abs; lia.
(* . *)
destruct U as [U|U].
rewrite U; apply Z.le_trans with (mag beta x).
lia.
rewrite <- mag_abs.
apply mag_le.
now apply Rabs_pos_lt.
apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify.
apply Rabs_pos.
destruct U as (U',U); rewrite U.
rewrite <- mag_abs.
apply mag_minus_lb.
now apply Rabs_pos_lt.
now apply Rabs_pos_lt.
rewrite 2!mag_abs.
assert (mag beta y < mag beta x - 1)%Z.
now rewrite (mag_minus1 x Zx).
lia.
apply cexp_round_ge...
apply round_plus_neq_0...
contradict H1; apply Zle_not_lt.
rewrite <- (mag_minus1 x Zx).
replace y with (-x)%R.
rewrite mag_opp; lia.
lra.
now exists n.
Qed.

Context {exp_not_FTZ : Exp_not_FTZ fexp}.

Theorem round_plus_ge_ulp :
  forall x y, format x -> format y ->
  round beta fexp rnd (x+y) <> 0%R ->
  (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy KK.
case (Req_dec x 0); intros Zx.
(* *)
rewrite Zx, Rplus_0_l.
rewrite round_generic...
unfold Rdiv; rewrite Rmult_0_l.
rewrite Fy.
unfold F2R; simpl; rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm.
contradict KK.
rewrite Zx, Fy, Hm; unfold F2R; simpl.
rewrite Rplus_0_l, Rmult_0_l.
apply round_0...
apply Rle_trans with (1*bpow (cexp y))%R.
rewrite Rmult_1_l.
rewrite <- ulp_neq_0.
apply ulp_ge_ulp_0...
intros K; apply Hm.
rewrite K, scaled_mantissa_0.
apply Ztrunc_IZR.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- abs_IZR.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
(* *)
destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm).
case (Z.eq_dec m 0); intros Zm.
contradict KK.
rewrite Hm, Zm.
apply F2R_0.
rewrite Hm, <- F2R_Zabs.
rewrite ulp_neq_0.
rewrite <- (Rmult_1_l (bpow _)).
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
apply Rmult_integral_contrapositive_currified with (1 := Zx).
apply Rinv_neq_0_compat.
apply Rgt_not_eq, radix_pos.
Qed.

End Fprop_plus_mult_ulp.

Section Fprop_plus_ge_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem round_FLT_plus_ge :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (bpow (e + prec) <= Rabs x)%R ->
  round beta (FLT_exp emin prec) rnd (x + y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1; try assumption.
unfold FLT_exp; apply bpow_le.
apply Z.le_trans with (2:=Z.le_max_l _ _).
destruct (mag beta x) as (n,Hn); simpl.
assert (e + prec < n)%Z; try lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

Lemma round_FLT_plus_ge' :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) ->
  (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) ->
  round beta (FLT_exp emin prec) rnd (x+y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy H1 H2 H3.
case (Req_dec x 0); intros H4.
case (Req_dec y 0); intros H5.
contradict H3.
rewrite H4, H5, Rplus_0_l; apply round_0...
rewrite H4, Rplus_0_l.
rewrite round_generic...
apply round_FLT_plus_ge; try easy.
now apply H1.
Qed.

Theorem round_FLX_plus_ge :
  forall x y e,
  generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y ->
  (bpow (e+prec) <= Rabs x)%R ->
  (round beta (FLX_exp prec) rnd (x+y) <> 0)%R ->
  (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1 by easy.
unfold FLX_exp; apply bpow_le.
destruct (mag beta x) as (n,Hn); simpl.
assert (e + prec < n)%Z; try lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

End Fprop_plus_ge_ulp.

Section Fprop_plus_le_ops.

Variable beta : radix.
Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Variable choice : Z -> bool.

Lemma plus_error_le_l :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R.
Proof.
intros x y Fx Fy.
apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|].
rewrite Rabs_minus_sym; right; f_equal; ring.
Qed.

Lemma plus_error_le_r :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R.
Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed.

End Fprop_plus_le_ops.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Arith.
Require Export transfinite.

Module Ordinal.
Import Universe.
Export Transfinite.

Definition ID (y:E):= y.

Definition is_ordinal (o:E):=is_leq_gen_scale ID o.

Lemma ordinal_union : forall z:E,
(forall u:E, inc u z -> is_ordinal u) -> is_ordinal (union z).
Proof.
ir. uhg. ap leq_gen_scale_union. ir.
exact (H y H0).
Qed.

Lemma emptyset_ordinal : is_ordinal emptyset.
Proof.
assert (emptyset = union emptyset :> E).
ap extensionality; uhg; ir. elim (B H).
cp (union_exists H). nin H0. ee.
elim (B H1). rw H. ap ordinal_union; ir.
elim (B H0).
Qed.

Lemma ordinal_tack_on : forall o:E, is_ordinal o ->
is_ordinal (tack_on o o).
Proof.
ir. uhg.
apply by_cases with (inc o o); ir.
assert (tack_on o o = o). ap extensionality; uhg; ir.
rwi tack_on_inc H1; nin H1. am. rw H1; am.
rw tack_on_inc. ap or_introl; am. rw H1; am.
change (is_leq_gen_scale ID (tack_on o (ID o))).
ap leq_gen_scale_tack_on. exact H. am.
Qed.

Lemma ordinal_sub_or : forall a o:E,
is_ordinal a -> is_ordinal o ->
(sub a o \/ sub o a).
Proof.
ir. uh H; uh H0. cp (leq_gen_scale_or H H0). am.
Qed.

Lemma ordinal_induction : forall (p:EP),
(forall z:E,(forall u:E, inc u z -> p u)-> p (union z)) ->
(forall u :E, p u -> p (tack_on u u)) ->
(forall o:E, is_ordinal o -> p o).
Proof.
ir. util (lgs_induction (f:=ID) (p:= p)).
am. am. ap H2. am.
Qed.

Definition is_smallest_ordinal_with (p:EP)(o:E):=
(is_ordinal o & p o &
(forall x:E, is_ordinal x -> p x -> sub o x)).

Lemma exists_smallest_ordinal_with : forall (p:EP),
(exists x:E, (is_ordinal x&p x)) ->
exists o:E, is_smallest_ordinal_with p o.
Proof.
ir. util (lgs_smallest_with_property (f:=ID)(p:=p)).
am. am.
Qed.

Lemma ordinal_not_inc : forall x o:E, is_ordinal o ->
inc x o -> ~inc x x.
Proof.
ir. util (ordinal_induction (p:= fun y:E=>(forall u:E,
inc u y -> ~inc u u))).
ir. cp (union_exists H2). nin H3; ee.
cp (H1 x0 H4 u H3). am.
ir. rwi tack_on_inc H2; nin H2. ap H1; am. uhg; ir.
util (H1 u0). wr H2; am. ap H4; am.
cbv beta in H1. apply H1 with o. am. am.
Qed.

Lemma ordinal_inc_ordinal : forall x o:E, is_ordinal o ->
inc x o -> is_ordinal x.
Proof.
ir. util (ordinal_induction (p:= fun y:E=>(is_ordinal y &
forall u:E,
inc u y -> is_ordinal u))); ir.
ee. ap ordinal_union. ir. cp (H1 u H2). ee; am.
ir. nin (union_exists H2). ee. cp (H1 x0 H4).
ee. ap H6; am. ee.
ap ordinal_tack_on; am. ir.
rwi tack_on_inc H3; nin H3.
ap H2; am. rw H3; am.
cbv beta in H1. cp (H1 o H); ee.
ap H3; am.
Qed.

Lemma ordinal_not_inc_itself :forall o:E,
is_ordinal o -> ~inc o o.
Proof.
ir. uhg; ir. apply ordinal_not_inc with o o.
am. am. am.
Qed.

Lemma ordinal_strict_sub_inc : forall a o:E,
is_ordinal a -> is_ordinal o -> strict_sub a o -> inc a o.
Proof.
ir. uh H; uh H0. cp H; cp H0.
uh H; uh H0; nin H; nin H0.
ee. assert (next x0 a= ID a).
ap next_compatible_scale. am.
apply leq_gen_scale_subset with ID. am.
am. rw H0; uh H1; ee; am. rw H0; am.
wr H0. ufi ID H6. wr H6. ap next_inc_U. rw H0; am.
uh H4; ee; am.
Qed.

Lemma ordinal_inc_rw : forall x o:E,
is_ordinal o ->
(inc x o = (is_ordinal x & strict_sub x o)).
Proof.
ir. ap iff_eq; ir. dj. apply ordinal_inc_ordinal with o; am.
uhg; ee. uhg; uhg; ir. apply ordinal_not_inc_itself with o.
am. rwi H2 H0. am.
nin (ordinal_sub_or H H1).
assert (inc x x). ap H2; am. assert False.
apply ordinal_not_inc_itself with x; am. elim H4. am.
ee. ap ordinal_strict_sub_inc; am.
Qed.

Lemma ordinal_inc_sub : forall a o:E,
is_ordinal o -> inc a o -> sub a o.
Proof.
ir. rwi ordinal_inc_rw H0.  ee.
uh H1; ee; am. am.
Qed.

Definition ordinal_leq a o:= (is_ordinal a & is_ordinal o&
sub a o).

Definition ordinal_lt a o:= (ordinal_leq a o & a <> o).

Lemma ordinal_lt_rw : forall a o:E,
ordinal_lt a o = (is_ordinal o&inc a o).
Proof.
ir. uf ordinal_lt.
uf ordinal_leq; ap iff_eq; ir; xd.
rw ordinal_inc_rw. uf strict_sub; xd. am.
rwi ordinal_inc_rw H0; ee; am. rwi ordinal_inc_rw H0; ee.
uh H1; ee; am. am. rwi ordinal_inc_rw H0; ee. uh H1; ee; am. am.
Qed.

Lemma ordinal_leq_leq_or : forall a o:E,
is_ordinal a -> is_ordinal o ->
(ordinal_leq a o \/ ordinal_leq o a).
Proof.
ir. nin (ordinal_sub_or H H0). ap or_introl.
uhg; ee; am. ap or_intror; uhg; ee; am.
Qed.

Lemma ordinal_leq_leq_eq : forall a b,
ordinal_leq a b -> ordinal_leq b a -> a = b.
Proof.
ir. ap extensionality; lu.
Qed.

Lemma ordinal_leq_trans : forall a b,
(exists c, ordinal_leq a c & ordinal_leq c b)->
ordinal_leq a b.
Proof.
ir. nin H. ee. uhg; ee. lu. lu.
apply sub_trans with x; lu.
Qed.

Lemma ordinal_if_leq_or : forall a o:E,
ordinal_leq a o -> (ordinal_lt a o \/ a = o).
Proof.
ir. apply by_cases with (a = o); ir. ap or_intror; am.
ap or_introl. uhg; uh H; xd. uhg; ee; am.
Qed.

Lemma ordinal_lt_lt_eq_or : forall a o:E,
is_ordinal a -> is_ordinal o ->
(ordinal_lt a o \/ ordinal_lt o a \/ a=o).
Proof.
ir. nin (ordinal_leq_leq_or H H0).
nin (ordinal_if_leq_or H1). ap or_introl. am. ap or_intror.
ap or_intror. am.
nin (ordinal_if_leq_or H1). ap or_intror. ap or_introl; am.
ap or_intror; ap or_intror; sy; am.
Qed.

Lemma ordinal_lt_tack_on_leq : forall a o:E,
is_ordinal a -> (ordinal_lt a o = ordinal_leq (tack_on a a) o).
Proof.
ir. ap iff_eq; ir. cp H0. rwi ordinal_lt_rw H1. ee.
uhg; ee. ap ordinal_tack_on; am. am. uhg; ir.
rwi tack_on_inc H3; nin H3. uh H0; ee. uh H0; ee. ap H6; am.
rw H3; am. uhg; ee. uhg; ee; try am. uh H0; ee; am.
uh H0; ee. uhg; ir. ap H2. rw tack_on_inc. ap or_introl; am.
uhg; ir. uh H0; ee. apply ordinal_not_inc_itself with a.
am. rw H1. ap H3. rw tack_on_inc. ap or_intror; sy; am.
Qed.

Lemma exists_smallest_ordinal_without : forall (p:EP),
(exists x : E, (is_ordinal x & ~ p x))->
exists o:E, (is_ordinal o & ~ p o & forall y : E, inc y o -> p y).
Proof.
ir.
util (exists_smallest_ordinal_with (p:= fun x =>
(is_ordinal x &~p x))).
nin H; ee. sh x; ee; am. nin H0.
uh H0. ee.  sh x. ee; try am. ir. ap excluded_middle; uhg; ir.
assert (x = y). ap extensionality. ap H2.
apply ordinal_inc_ordinal with x. am. am.
ee. apply ordinal_inc_ordinal with x; am. am.
ap ordinal_inc_sub. am. am. apply ordinal_not_inc_itself with x.
am. wri H6 H4; am.
Qed.

Definition is_sow (p:EP) o :=
is_ordinal o & (exists x, is_ordinal x & p x) ->
is_smallest_ordinal_with p o.

Definition sow (p:EP) :=
choose (is_sow p).

Lemma sow_exists : forall p, exists o, is_sow p o.
Proof.
ir.
apply by_cases with (exists x, is_ordinal x & p x).
ir.
sh (choose (is_smallest_ordinal_with p)).
cp (exists_smallest_ordinal_with H).
cp (choose_pr H0).
cbv beta in H1. uhg; ee.
uh H1; ee. am. ir.
am. ir. sh emptyset.
uhg; ee. ap emptyset_ordinal. ir.
elim (H H0).
Qed.

Lemma sow_is_sow : forall p, is_sow p (sow p).
Proof.
ir. cp (sow_exists p).
cp (choose_pr H). am.
Qed.

Lemma sow_ordinal : forall p, is_ordinal (sow p).
Proof.
ir. cp (sow_is_sow p). uh H; ee. am.
Qed.

Lemma sow_property : forall p,
(exists x:E, (is_ordinal x & p x)) ->
p (sow p).
Proof.
ir.
cp (sow_is_sow p). uh H0; ee. cp (H1 H). uh H2; ee. am.
Qed.

Lemma sow_smallest : forall (p:EP) o,
is_ordinal o -> p o -> ordinal_leq (sow p) o.
Proof.
ir.
cp (sow_is_sow p). uh H1; ee. util H2.
sh o; ee; am.
uh H3; ee. cp (H5 _ H H0).
uhg; ee. ap sow_ordinal. am. am.
Qed.

Lemma ordinal_leq_gen_refl : forall o:E,
is_ordinal o -> leq_gen ID o o.
Proof.
ir. pose (q:= tack_on o o).
assert (is_ordinal q).
uf q; ap ordinal_tack_on. am. uh H0.
uh H0. nin H0; ee.
assert (inc o (U x)). rw H0; uf q; rw tack_on_inc.
ap or_intror; tv.
rw (leq_gen_leq (f:=ID) (a:= x)).
ap leq_refl. do 3 (uh H1; ee); am.
am. am. am. am.
Qed.

Lemma ordinal_leq_gen_tack_on : forall o:E,
is_ordinal o -> leq_gen ID o (tack_on o o).
Proof.
ir.
pose (u:=tack_on o o).
assert (is_ordinal u). uf u; ap ordinal_tack_on; am.
assert (ordinal_lt o u).
rw ordinal_lt_rw. ee; try am. uf u; rw tack_on_inc;
ap or_intror; tv.

pose (q:= tack_on u u).
assert (is_ordinal q). uf q; ap ordinal_tack_on; am.
assert (ordinal_lt u q).
rw ordinal_lt_rw. ee; try am. uf q; rw tack_on_inc;
ap or_intror; tv.

cp H2; uh H4; uh H4; nin H4; ee.

assert (u = next x u). sy; transitivity (ID u).
apply (next_compatible_scale (f:= ID)).
am.
cp H0. uh H6; uh H6; nin H6; ee. wr H6.
apply next_comp_sub_scale with (f:= ID).
am. am. rw H6; rw H4. uh H3; ee. uh H3; ee; am.
rw H4. rwi ordinal_lt_rw H3; ee. rwi ordinal_inc_rw H6;
ee; am. tv.
rw (leq_gen_leq (f:=ID)(a:=x)).
assert (lt x o u).
rw H6; ap next_compatible_lt.
uh H0; uh H0; nin H0; ee. wr H0;
apply next_comp_sub_scale with (f:= ID).
am. am. rw H0; rw H4.
uh H3; ee. uh H3; ee; am. rwi ordinal_lt_rw H3.
ee. rwi ordinal_inc_rw H7. ee. rw H4; am. am.
rwi ordinal_lt_rw H1; ee; am. uh H7; ee; am. am.
rw H4. uf q; rw tack_on_inc; ap or_introl.
uf u; rw tack_on_inc; ap or_intror; tv. rw H4;
uf q; rw tack_on_inc; ap or_intror; tv.
Qed.

Lemma leq_gen_ordinal : forall o:E, leq_gen ID o o ->
is_ordinal o.
Proof.
ir. uh H. nin H; ee. assert (is_ordinal (U x)).
uhg. uhg. sh x; ee; try tv; try am.
apply ordinal_inc_ordinal with (U x). am.
uh H0; ee; am.
Qed.

Lemma leq_gen_ordinal_leq : forall a o:E,
leq_gen ID a o -> ordinal_leq a o.
Proof.
ir. uhg; dj. ap leq_gen_ordinal. apply leq_gen_def1 with o; am.
ap leq_gen_ordinal; apply leq_gen_def2 with a; am.
nin (leq_gen_is_next H).
rw H2; uhg; ir; am. nin H2.
ee. ap ordinal_inc_sub. am. ufi ID H4.
rw H4; am.
Qed.

Lemma ordinal_leq_leq_gen : forall a o:E,
ordinal_leq a o = leq_gen ID a o.
Proof.
ir. ap iff_eq; ir.
assert (leq_gen ID a a).
ap ordinal_leq_gen_refl. uh H; ee; am.
assert (leq_gen ID o o).
ap ordinal_leq_gen_refl. uh H; ee; am.
cp (leq_gen_or H0 H1). nin H2.
am. assert (ordinal_leq o a).
ap leq_gen_ordinal_leq. am.
assert (a = o). ap extensionality.
uh H; ee; am. uh H3; ee; am. rw H4; am.
ap leq_gen_ordinal_leq; am.
Qed.

Definition obi x := create x sub.

Lemma obi_U : forall x:E, (U (obi x)) = x.
Proof.
ir. uf obi. rw underlying_create; tv.
Qed.

Lemma obi_leq : forall x u v:E,
leq (obi x) u v = (inc u x & inc v x & sub u v).
Proof.
ir. uf obi; rw leq_create_all. tv.
Qed.

Lemma obi_axioms : forall x:E, axioms (obi x).
Proof.
ir. uf obi. ap create_axioms.
uf property; dj. uhg; ir; am. ap extensionality; am.
apply sub_trans with y; am.
Qed.

Lemma ordinal_obi_leq : forall x u v:E,
is_ordinal x ->
leq (obi x) u v = (inc u x & inc v x & ordinal_leq u v).
Proof.
ir. rw obi_leq; uf ordinal_leq; ap iff_eq; ir; xd.
apply ordinal_inc_ordinal with x; am.
apply ordinal_inc_ordinal with x; am.
Qed.

Lemma ordinal_leq_inc_tack_on : forall o x:E,
is_ordinal o ->
ordinal_leq x o = inc x (tack_on o o).
Proof.
ir. ap iff_eq; ir. nin (ordinal_if_leq_or H0).
rw tack_on_inc; ap or_introl. rwi ordinal_lt_rw H1.
ee; am. rw tack_on_inc; ap or_intror. am.
rwi tack_on_inc H0. nin H0.
rwi ordinal_inc_rw H0. ee. uh H1; ee. uhg; ee; am.
am. rw H0; uhg; ee. am. am. uhg; ir; am.
Qed.

Lemma ordinal_container : forall z:E,
(forall u:E, inc u z -> is_ordinal u) ->
exists o:E, (is_ordinal o & sub z o).
Proof.
ir.
pose (q:= (union z)). assert (is_ordinal q).
uf q; ap ordinal_union; am.
sh (tack_on q q). ee.
ap ordinal_tack_on; am. uhg; ir.
assert (ordinal_leq x q). uhg; ee.
ap H; am. am. uhg; ir. uf q; apply union_inc with x.
am. am.
wr ordinal_leq_inc_tack_on. am. am.
Qed.

Lemma ordinal_leq_obi : forall a x y,
next_compatible ID a -> inc x (U a) -> inc y (U a) ->
leq (obi (U a)) x y = leq a x y.
Proof.
ir. assert (is_ordinal (U a)).
uhg; ee. uhg. sh a; ee; try tv; try am.
ap iff_eq; ir.
wr (leq_gen_leq (f:=ID)).
rwi ordinal_obi_leq H3. ee.
wr ordinal_leq_leq_gen. am. am. am.
am. am.
rw ordinal_obi_leq. ee; try am.
wri (leq_gen_leq (f:=ID)) H3.
rw ordinal_leq_leq_gen. am. am. am. am. am.
Qed.

Lemma ordinal_next : forall a x,
next_compatible ID a -> inc x (U a) ->
next a x = x.
Proof.
ir. uh H; ee. cp (H1 _ H0). ufi ID H2.
wr H2.
wr next_punctured_downward. sy; am. am. am.
Qed.

Lemma punctured_downward_for_ord : forall a x,
next_compatible ID a -> inc x (U a) ->
punctured_downward_subset a x = x.
Proof.
ir.
util (ordinal_next (a:=a) (x:=x)). am.
am.
uh H. ee. ufi ID H2. ap H2. am.
Qed.

Lemma ordinal_obi_lt : forall o x y,
is_ordinal o ->
lt (obi o) x y = (inc x y & inc y o).
Proof.
ir.
ap iff_eq; ir. ee. uh H0; ee.
rwi obi_leq H0. ee.
ap ordinal_strict_sub_inc.
apply ordinal_inc_ordinal with o; am.
apply ordinal_inc_ordinal with o; am. uhg; ee; am.
uh H0; ee. uh H0; ee. rwi obi_U H2; am.
ee. uhg; ee. rw obi_leq. ee; try am.
cp ordinal_inc_sub. ufi sub H2. apply H2 with y. am.
am. am. ap ordinal_inc_sub. apply ordinal_inc_ordinal
with o; am. am. uhg; ir.
apply ordinal_not_inc_itself with x. apply ordinal_inc_ordinal
with o. am. rw H2; am. wri H2 H0; am.
Qed.

Lemma ordinal_inc_trans: forall o x,
(exists y, inc x y & inc y o) -> is_ordinal o ->
inc x o.
Proof.
ir. cp ordinal_inc_sub. ufi sub H1.
nin H. ee. apply H1 with x0. am. am. am.
Qed.

Lemma ordinal_punctured_downward : forall o x,
is_ordinal o -> inc x o ->
punctured_downward_subset (obi o) x = x.
Proof.
ir.
uf punctured_downward_subset; ap extensionality;
uhg; ir. Ztac.
rwi ordinal_obi_lt H3. ee; am. am.
ap Z_inc. rw obi_U.
ap ordinal_inc_trans. sh x. ee; am. am.
rw ordinal_obi_lt. ee; am. am.
Qed.

Lemma ordinal_obi_next_compatible : forall o:E,
is_ordinal o -> next_compatible ID (obi o).
Proof.
ir.
cp H; uh H. uh H. nin H. ee.
assert (same_order x (obi o)).
uhg; ee; ap show_is_suborder.
do 5 (uh H1; ee; try am). ap obi_axioms. ir.
wr H. rw ordinal_leq_obi. am. am. uh H2; ee; am.
uh H2; ee; am. ap obi_axioms.
do 5 (uh H1; ee; try am).
ir.
wr ordinal_leq_obi. rw H; am. am.
uh H2; ee. rwi obi_U H2; rw H; am.
uh H2; ee. rwi obi_U H3; rw H; am.
uhg; dj. apply wo_same_order with x. am.
uh H1; ee; am.
rw ordinal_punctured_downward. tv. am. rwi obi_U H4; am.
Qed.

Lemma ordinal_inc : forall o x:E,
is_ordinal o ->
inc x o = (leq_gen ID x o & x <> o).
Proof.
ir. ap iff_eq; ir. ee. wr ordinal_leq_leq_gen.
uhg. ee; try am.
apply ordinal_inc_ordinal with o; am.
ap ordinal_inc_sub; am. uhg; ir. rwi H1 H0.
apply ordinal_not_inc_itself with o; am.
ee.
wri ordinal_leq_leq_gen H0.
uh H0.
ee. ap ordinal_strict_sub_inc. am. am.
uhg; ee; am.
Qed.

Lemma ordinal_chenille : forall o,
is_ordinal o -> chenille ID o = o.
Proof.
ir. ap extensionality; uhg; ir.
rwi chenille_inc H0.
wri ordinal_inc H0. am. am.
rwi chenille_inc H0.
ap ordinal_leq_gen_refl; am. ap ordinal_leq_gen_refl; am.
rw chenille_inc. rwi ordinal_inc H0. am. am.
ap ordinal_leq_gen_refl; am.
Qed.

Lemma ordinal_downward_lgs : forall o:E,
is_ordinal o -> downward_lgs ID o = tack_on o o.
Proof.
ir. wr chenille_tack_on.
rw ordinal_chenille. tv. am.
ap ordinal_leq_gen_refl; am.
Qed.

Export Transfinite_Mapping.

Lemma ordinal_inc_induction : forall (p:EP)(o:E),
(forall u:E, (forall x:E, inc x u -> p x)-> p u) ->
is_ordinal o -> p o.
Proof.
ir.
util (chenille_induction (f:=ID) (p:=p)).
ir.
ap H. ir. ap H2.
rw ordinal_chenille. am.
ap leq_gen_ordinal. am. ap H1.
ap ordinal_leq_gen_refl; am.
Qed.

Lemma ID_expansive : is_expansive ID.
Proof.
uhg. ir.
uf ID. ap ordinal_not_inc_itself. am.
Qed.

Definition wo_avatar a := avatar (next a) ID.

Definition wo_ordinal a := (Image.create (U a) (wo_avatar a)).

Lemma wo_avatar_surjective : forall a,
is_well_ordered a ->
Transformation.surjective (U a) (wo_ordinal a) (wo_avatar a).
Proof.
ir.
uhg; ee. uhg. ir. uf wo_ordinal; rw Image.inc_rw.
sh x; ee; try am. tv.
uhg. ir. ufi wo_ordinal H0; rwi Image.inc_rw H0.
nin H0. ee. sh x0; ee; am.
Qed.

Lemma wo_avatar_injective : forall a,
is_well_ordered a ->
Transformation.injective (U a) (wo_ordinal a) (wo_avatar a).
Proof.
ir.
uhg; ee. uhg. ir. uf wo_ordinal; rw Image.inc_rw.
sh x; ee; try am. tv.
uhg. ir. transitivity (avatar ID (next a) (wo_avatar a x)).
uf wo_avatar. rw avatar_trans. rw avatar_refl. tv.
rw next_leq_gen_leq. ap leq_refl; lu. am. am. am.
ap ID_expansive. rw next_leq_gen_leq.
ap leq_refl; lu. am. am. am. rw H2.
uf wo_avatar. rw avatar_trans. rw avatar_refl. tv.
rw next_leq_gen_leq; try am. ap leq_refl; lu.
ap ID_expansive. rw next_leq_gen_leq; try am.
ap leq_refl; lu.
Qed.

Lemma wo_avatar_bijective : forall a,
is_well_ordered a ->
Transformation.bijective (U a) (wo_ordinal a) (wo_avatar a).
Proof.
ir.
uhg; ee. uhg; ir. uf wo_ordinal; rw Image.inc_rw.
sh x; ee; try am. tv.
ap wo_avatar_surjective; am. ap wo_avatar_injective; am.
Qed.

Lemma wo_avatar_is_ordinal : forall a x,
is_well_ordered a -> inc x (U a) ->
is_ordinal (wo_avatar a x).
Proof.
ir. uf wo_avatar.
ap leq_gen_ordinal. ap avatar_leq_gen_def.
rw next_leq_gen_leq; try am. ap leq_refl; lu.
Qed.

Lemma wo_ordinal_is_ordinal : forall a,
is_well_ordered a -> is_ordinal (wo_ordinal a).
Proof.
ir. uf wo_ordinal.
uhg. uf wo_avatar.
ap lgs_avatar_image.
apply scale_subset_is_leq_gen_scale with a.
ap next_compatible_next. am.
uhg; ee; try am. ap sub_refl. ir. uh H1; ee; am.
Qed.

Lemma wo_avatar_ordinal_leq : forall a x y,
is_well_ordered a -> inc x (U a) -> inc y (U a) ->
leq a x y -> ordinal_leq (wo_avatar a x) (wo_avatar a y).
Proof.
ir.
uf wo_avatar. ap leq_gen_ordinal_leq; try am.
ap avatar_leq_gen; try am.
ap ID_expansive. rw next_leq_gen_leq; try am.

Qed.

Lemma wo_avatar_obi_id : forall o x,
is_ordinal o -> inc x o ->
wo_avatar (obi o) x = x.
Proof.
ir.
cp (ordinal_obi_next_compatible H).
uf wo_avatar.
rewrite<- next_compatible_avatar with (f:=ID).
ap avatar_refl.
ap ordinal_leq_gen_refl.
apply ordinal_inc_ordinal with o; am. am.
rw obi_U. am.
Qed.

Lemma wo_ordinal_obi_rw : forall o,
is_ordinal o ->
wo_ordinal (obi o) = o.
Proof.
ir. uf wo_ordinal.
ap extensionality; uhg; ir.
rwi Image.inc_rw H0. nin H0.
ee. rwi wo_avatar_obi_id H1.
wr H1. rwi obi_U H0. am. am.
rwi obi_U H0; am.
rw Image.inc_rw. sh x. ee. rw obi_U; am.
ap wo_avatar_obi_id. am. am.
Qed.

(*** thought we needed these for cardinal.v but didn't...
*******************************************************
Lemma wo_avatar_same_order : forall a b x,
is_well_ordered a -> same_order a b -> inc x (U b) ->
wo_avatar a x = wo_avatar b x.
Proof.

Qed.

Lemma wo_ordinal_same_order : forall a b,
is_well_ordered a -> same_order a b ->
wo_ordinal a = wo_ordinal b.
Proof.

Qed.

Lemma obi_suborder_same_order : forall o u,
is_ordinal o -> sub u o ->
same_order (obi u) (suborder u (obi o)).
Proof.

Qed.
***********************************************)

Lemma wo_leq_rw : forall a x y,
is_well_ordered a -> inc x (U a) -> inc y (U a) ->
leq a x y = ordinal_leq (wo_avatar a x) (wo_avatar a y).
Proof.
ir. ap iff_eq; ir.
ap wo_avatar_ordinal_leq; try am. cp H.
uh H; ee. uh H; ee.
cp (H5 _ _ H0 H1). nin H6. am.
assert (ordinal_leq (wo_avatar a y) (wo_avatar a x)).
ap wo_avatar_ordinal_leq; try am.
uh H2. uh H7. ee. assert (x = y).
util (wo_avatar_injective (a:=a)). am.
uh H12; ee. uh H13. ap H13. am. am.
ap extensionality; am. rw H12. ap leq_refl; try am; try lu.
Qed.

Lemma wo_lt_rw : forall a x y,
is_well_ordered a -> inc x (U a) -> inc y (U a) ->
lt a x y = ordinal_lt (wo_avatar a x) (wo_avatar a y).
Proof.
ir. ap iff_eq; ir. uhg; ee. wr wo_leq_rw. uh H2; ee; am. am.
am. am. uhg; ir. uh H2; ee. ap H4.
util (wo_avatar_injective (a:= a)). am.
uh H5; ee. ap H6. am. am. am. uhg; ee.
rw wo_leq_rw. uh H2; ee; am. am. am. am.
uhg; ir. uh H2. ee. ap H4. rw H3; tv.
Qed.

Lemma wo_punctured_downward : forall a x,
is_well_ordered a -> inc x (U a) ->
Image.create (punctured_downward_subset a x) (wo_avatar a)
= wo_avatar a x.
Proof.
ir. rewrite<- chenille_punctured_downward with (f:=next a).
uf wo_avatar.
wr avatar_chenille.
ap ordinal_chenille.
change (is_ordinal (wo_avatar a x)).
ap wo_avatar_is_ordinal. am. am.
ap ID_expansive.
rw next_leq_gen_leq. ap leq_refl; lu. am. am. am.
ap next_compatible_next; am. am.
Qed.

Lemma suborder_wo_avatar_decreasing : forall u a x,
is_well_ordered a -> sub u (U a) -> inc x u ->
ordinal_leq (wo_avatar (suborder u a) x) (wo_avatar a x).
Proof.
ir.
set (b:=suborder u a).
assert (lem1: U b = u).
uf b; rw underlying_suborder; tv.
assert (lem2 : is_well_ordered b).
uf b; ap suborder_well_ordered. am. am.

util (wo_induction  lem2
(p:= fun y=>
(ordinal_leq (wo_avatar b y) (wo_avatar a y)))).
ir.
uhg; ee. ap wo_avatar_is_ordinal. am.  am.
ap wo_avatar_is_ordinal. am.
ap H0. wr lem1; am.
uhg; ir.
wri wo_punctured_downward H4.
rwi Image.inc_rw H4. nin H4. ee.
ufi punctured_downward_subset H4. Ztac.
cp (H3 _ H6 H7).
rwi H5 H8.
assert (lt a x2 x0).
uh H7. uhg; ee; try am.
ufi b H7.
rwi leq_suborder_all H7. ee. am. lu. am.
assert (ordinal_lt x1 (wo_avatar a x0)).
uhg; ee.
uhg; ee. uh H8; ee; am. ap wo_avatar_is_ordinal.
am. ap H0. wr lem1; am.
apply sub_trans with (wo_avatar a x2).
uh H8; ee; am.
uh H9; ee. rwi wo_leq_rw H9.
lu. am. ap H0; wr lem1; am. lu. uhg; ir.
rwi wo_lt_rw H9. uh H9; ee. ap H11.
ap extensionality. lu. wr H10. lu.
am. ap H0; wr lem1; am.
ap H0; wr lem1; am.
rwi ordinal_lt_rw H10. ee; am. am. am.
wri lem1 H1. cp (H2 _ H1). am.
Qed.

Lemma ordinal_saturated : forall a b c,
is_ordinal c -> inc b c  -> ordinal_leq a b ->
inc a c.
Proof.
ir. assert (ordinal_lt a c).
uhg; ee. uhg; ee. lu. am.
uh H1. ee. rwi ordinal_inc_rw H0. ee.
uh H4. ee. apply sub_trans with b; am. am.
uhg; ir. uh H1; ee. rwi H2 H4.
apply ordinal_not_inc_itself with b. am. ap H4; am.
rwi ordinal_lt_rw H2. ee; am.
Qed.

Lemma wo_avatar_ordinal_inc : forall a x,
is_well_ordered a -> inc x (U a) ->
inc (wo_avatar a x) (wo_ordinal a).
Proof.
ir.
uf wo_ordinal.
rw Image.inc_rw.
sh x; ee; try am; try tv.
Qed.

Lemma suborder_wo_ordinal_decreasing : forall u a,
is_well_ordered a -> sub u (U a)->
ordinal_leq (wo_ordinal (suborder u a)) (wo_ordinal a).
Proof.
ir.
uhg; ee. ap wo_ordinal_is_ordinal.
ap suborder_well_ordered; am.
ap wo_ordinal_is_ordinal; am.
uhg; ir. ufi wo_ordinal H1.
rwi Image.inc_rw H1. nin H1.
ee. wr H2.
apply ordinal_saturated with (wo_avatar a x0).
ap wo_ordinal_is_ordinal. am.
ap wo_avatar_ordinal_inc. am.
ap H0. rwi underlying_suborder H1. am.
ap suborder_wo_avatar_decreasing. am. am.
rwi underlying_suborder H1. am.
Qed.

End Ordinal.


Require Import
  Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers MathClasses.interfaces.naturals MathClasses.interfaces.rationals
  MathClasses.implementations.field_of_fractions MathClasses.implementations.natpair_integers
  MathClasses.theory.rings MathClasses.theory.integers MathClasses.theory.dec_fields.

Program Instance slow_rat_dec `{Rationals Q} : ∀ x y: Q, Decision (x = y) | 10 := λ x y,
  match decide (rationals_to_frac Q (SRpair nat) x = rationals_to_frac Q (SRpair nat) y) with
  | left E => left _
  | right E => right _
  end.
Next Obligation. now apply (injective (rationals_to_frac Q (SRpair nat))). Qed.

Section another_integers.
  Context `{Rationals Q} `{Integers Z}.
  Add Ring Z : (stdlib_ring_theory Z).

  Notation ZtoQ := (integers_to_ring Z Q).
  Notation QtoFrac := (rationals_to_frac Q Z).

  Lemma rationals_decompose `{!SemiRing_Morphism (f : Z → Q)} (x : Q) :
    ∃ num, ∃ den, den ≠ 0 ∧ x = f num / f den.
  Proof.
    exists (num (QtoFrac x)), (den (QtoFrac x)). split.
     now apply den_ne_0.
    apply (injective QtoFrac).
    rewrite preserves_mult.
    rewrite preserves_dec_recip.
    change (QtoFrac x = (QtoFrac ∘ f) (num (QtoFrac x)) / (QtoFrac ∘ f) (den (QtoFrac x))).
    rewrite 2!(to_ring_unique_alt (QtoFrac ∘ f) Frac_inject).
    assert (Frac_inject (den (QtoFrac x)) ≠ 0) as P.
     apply injective_ne_0. apply den_ne_0.
    apply Frac_dec_mult_num_den.
  Qed.

  Global Instance integers_to_rationals_injective `{!SemiRing_Morphism (f: Z → Q)} : Injective f.
  Proof.
    split; try apply _.
    intros x y E.
    apply (injective (integers_to_ring Z Q)).
    now rewrite <-2!(to_ring_unique f).
  Qed.

  Context `{f : Q → Frac Z} `{!SemiRing_Morphism f}.

  Global Instance to_frac_inverse: Inverse f := λ x, ZtoQ (num x) / ZtoQ (den x).

  Global Instance: Surjective f.
  Proof.
    split; try apply _.
    intros x y E.
    unfold compose, inverse, to_frac_inverse, id.
    rewrite <-E. clear E.
    rewrite commutativity.
    apply (left_cancellation_ne_0 (.*.) (f (ZtoQ (den x)))).
     do 2 apply injective_ne_0. apply den_ne_0.
    rewrite <-preserves_mult, associativity.
    rewrite dec_recip_inverse, left_identity.
     change ((f ∘ ZtoQ) (num x) = (f ∘ ZtoQ) (den x) * x).
     rewrite 2!(to_ring_unique_alt (f ∘ ZtoQ) Frac_inject).
     unfold equiv, Frac_equiv. simpl. ring.
    apply injective_ne_0.
    now apply den_ne_0.
  Qed.

  (* Making this instance global results in loops *)
  Instance to_frac_bijective: Bijective f := {}.
  Global Instance to_frac_inverse_bijective: Bijective (f⁻¹) := _.
  Global Instance: SemiRing_Morphism (f⁻¹) := {}.
End another_integers.

Lemma to_frac_unique `{Rationals Q} `{Integers Z} (f g : Q → Frac Z) `{!SemiRing_Morphism f} `{!SemiRing_Morphism g} :
  ∀ x, f x = g x.
Proof.
  intros x.
  apply (injective (g⁻¹)).
  change (f⁻¹ (f ⁻¹ ⁻¹ x) = g⁻¹ (g⁻¹ ⁻¹ x)).
  now rewrite 2!(jections.surjective_applied _).
Qed.

Definition rationals_to_rationals Q1 Q2 `{Rationals Q1} `{Rationals Q2} : Q1 → Q2
  := (rationals_to_frac Q2 (SRpair nat))⁻¹ ∘ rationals_to_frac Q1 (SRpair nat).
Hint Unfold rationals_to_rationals : typeclass_instances.

Section another_rationals.
  Context `{Rationals Q1} `{Rationals Q2}.

  Local Existing Instance to_frac_bijective.
  Global Instance: SemiRing_Morphism (rationals_to_rationals Q1 Q2) := _.
  Global Instance: Bijective (rationals_to_rationals Q1 Q2) := _.
  Global Instance: Bijective (rationals_to_rationals Q2 Q1) := _.

  Instance: Bijective (rationals_to_frac Q1 (SRpair nat)) := {}.

  Lemma to_rationals_involutive:
    ∀ x, rationals_to_rationals Q2 Q1 (rationals_to_rationals Q1 Q2 x) = x.
  Proof.
    intros x.
    unfold rationals_to_rationals, compose.
    rewrite (jections.surjective_applied _).
    apply (jections.bijective_applied _).
  Qed.

  Lemma to_rationals_unique (f : Q1 → Q2) `{!SemiRing_Morphism f} :
    ∀ x, f x = rationals_to_rationals Q1 Q2 x.
  Proof.
    intros x.
    apply (injective (rationals_to_rationals Q2 Q1)).
    rewrite to_rationals_involutive.
    change ((rationals_to_frac Q1 (SRpair nat)⁻¹) ((rationals_to_frac Q2 (SRpair nat) ∘ f) x) = x).
    rewrite (to_frac_unique (rationals_to_frac Q2 (SRpair nat) ∘ f) (rationals_to_frac Q1 (SRpair nat))).
    apply (jections.bijective_applied _).
  Qed.
End another_rationals.

Lemma to_rationals_unique_alt `{Rationals Q1} `{Rationals Q2} (f g : Q1 → Q2) `{!SemiRing_Morphism f} `{!SemiRing_Morphism g} :
  ∀ x, f x = g x.
Proof.
  intros x.
  now rewrite (to_rationals_unique f), (to_rationals_unique g).
Qed.

Lemma morphisms_involutive `{Rationals Q1} `{Rationals Q2} (f : Q1 → Q2) (g : Q2 → Q1) `{!SemiRing_Morphism f} `{!SemiRing_Morphism g} :
  ∀ x, f (g x) = x.
Proof.
  intros x.
  rewrite (to_rationals_unique f), (to_rationals_unique g).
  apply to_rationals_involutive.
Qed.

Global Instance injective_nats `{Rationals Q} `{Naturals N} `{!SemiRing_Morphism (f : N → Q)} : Injective f.
Proof.
  split; try apply _.
  intros x y E.
  apply (injective (naturals_to_semiring N (SRpair nat))).
  apply rationals_embed_ints.
  now rewrite 2!(naturals.to_semiring_unique_alt f (integers_to_ring (SRpair nat) Q ∘ naturals_to_semiring N (SRpair nat))) in E.
Qed.

Section isomorphic_image_is_rationals.
  Context `{Rationals Q} `{DecField F}.
  Context (f : Q → F) `{!Inverse f} `{!Bijective f} `{!SemiRing_Morphism f}.

  Instance iso_to_frac: RationalsToFrac F := λ Z _ _ _ _ _ _ _ _, rationals_to_frac Q Z ∘ f⁻¹.
  Hint Unfold iso_to_frac: typeclass_instances.

  Instance: Bijective (f⁻¹) := _.
  Instance: SemiRing_Morphism (f⁻¹) := {}.

  Lemma iso_is_rationals: Rationals F.
  Proof.
    repeat (split; unfold rationals_to_frac; try apply _).
    intros x y E.
    apply (injective (f ∘ integers_to_ring Z Q)).
    now rewrite 2!(to_ring_unique (f ∘ integers_to_ring Z Q)).
  Qed.
End isomorphic_image_is_rationals.

Section alt_Build_Rationals.
  Context `{DecField F} `{Integers Z} (F_to_fracZ : F → Frac Z) `{!SemiRing_Morphism F_to_fracZ} `{!Injective F_to_fracZ}.
  Context (Z_to_F : Z → F) `{!SemiRing_Morphism Z_to_F} `{!Injective Z_to_F}.

  Program Instance alt_to_frac: RationalsToFrac F := λ B _ _ _ _ _ _ _ _ x,
    frac (integers_to_ring Z B (num (F_to_fracZ x))) (integers_to_ring Z B (den (F_to_fracZ x))) _.
  Next Obligation.
    apply injective_ne_0.
    apply den_ne_0.
  Qed.

  Instance: ∀ `{Integers B}, Proper ((=) ==> (=)) (rationals_to_frac F B).
  Proof.
    intros. intros ? ? E.
    unfold equiv, Frac_equiv. simpl.
    rewrite <-2!preserves_mult.
    apply sm_proper.
    change (F_to_fracZ x = F_to_fracZ y).
    now apply sm_proper.
  Qed.

  Instance: ∀ `{Integers B}, SemiRing_Morphism (rationals_to_frac F B).
  Proof.
    intros.
    repeat (split; try apply _); unfold equiv, Frac_equiv; simpl.
       intros x y.
       rewrite <-?preserves_mult, <-preserves_plus, <-preserves_mult.
       apply sm_proper.
       change (F_to_fracZ (x + y) = F_to_fracZ x + F_to_fracZ y).
       apply preserves_plus.
      rewrite <-(preserves_0 (f:=integers_to_ring Z B)), <-(preserves_1 (f:=integers_to_ring Z B)),
         <-2!preserves_mult.
      apply sm_proper.
      change (F_to_fracZ 0 = 0).
      apply preserves_0.
     intros x y.
     rewrite <-?preserves_mult.
     apply sm_proper.
     change (F_to_fracZ (x * y) = F_to_fracZ x * F_to_fracZ y).
     apply preserves_mult.
    rewrite <-(preserves_1 (f:=integers_to_ring Z B)), <-2!preserves_mult.
    apply sm_proper.
    change (F_to_fracZ 1 = 1).
    apply preserves_1.
  Qed.

  Instance: ∀ `{Integers B}, Injective (rationals_to_frac F B).
  Proof.
    intros.
    split; try apply _.
    intros x y E. unfold equiv, Frac_equiv in E. simpl in E.
    rewrite <-2!preserves_mult in E.
    apply (injective F_to_fracZ).
    now apply (injective (integers_to_ring Z B)).
  Qed.

  Instance: ∀ `{Integers B}, Injective (integers_to_ring B F).
  Proof.
    intros.
    split; try apply _.
    intros x y E.
    apply (injective (Z_to_F ∘ integers_to_ring B Z)).
    now rewrite 2!(to_ring_unique (Z_to_F ∘ integers_to_ring B Z)).
  Qed.

  Lemma alt_Build_Rationals: Rationals F.
  Proof. split; intros; apply _. Qed.
End alt_Build_Rationals.


(* Author: Harley Eades
 *
 * Coq Version: 8.3pl3
 *
 * This file contains results and tactics related to handing variable
 * naming and contexts. *)
Require Import Arith.
Require Import List.
Require Import F.
Require Import Omega.

(* Converts an inequality into a disjunction. *)
Lemma neq_lt_or_gt : forall n1 n2,
  n1 <> n2 -> n1 < n2 \/ n1 > n2.
Proof.
  intros; omega.
Qed.

(* These tactics I borrowed from Chris Casigno's Coq development
 * of his work on using step indices in normalization proofs.
 *
 * The next two tactics are helper tactics of clarify_compares_natc. *)
Ltac compares_cleanup_natc :=
    match goal with
    | [ H : nat_compare _ _ = Eq |- _ ] => apply nat_compare_eq in H
    | [ H : nat_compare _ _ = Lt |- _ ] => apply nat_compare_lt in H
    | [ H : nat_compare _ _ = Gt |- _ ] => apply nat_compare_gt in H
    end.

Ltac destruct_compares_natc n m :=
  remember (nat_compare n m);
  match goal with | [ H : ?comp = nat_compare n m |- _ ] =>
    apply eq_sym in H;
    destruct comp
  end;
  compares_cleanup_natc.
(* This is a very handy tactic for breaking up a
 * nat comparison into several different subgaols.
 *
 * For example if we have a subterm matching
 *   nat_compare _ _
 * then clarify_compares_natc generates three
 * subgoals replacing the subterm with either an
 * equality, less-than, or greater-than. *)
Ltac clarify_compares_natc :=
  match goal with
  | [ |- context[match nat_compare ?n ?m with
                 | Lt => _ | Eq => _ | Gt => _
                 end]
    ] => destruct_compares_natc n m
  | [ H : ?P (match nat_compare ?n ?m with
              | Lt => _ | Eq => _ | Gt => _
              end) _ |- _
    ] => destruct_compares_natc n m
  | [ H : ?P _ (match nat_compare ?n ?m with
                | Lt => _ | Eq => _ | Gt => _
                end) |- _
    ] => destruct_compares_natc n m
  end.

(* This tactic case-splits on whether two names are equal,
 * less than, or greater than.  This can be used to case split
 * on whether or not two names are equal. *)
Ltac case_split_names x y :=
  remember (nat_compare x y) as xneq; destruct xneq;
    match goal with
      | [H : Eq = nat_compare x y |- _] =>
        apply eq_sym in H; apply nat_compare_eq in H; subst
      | [H : Gt = nat_compare x y |- _] =>
        apply eq_sym in H; apply nat_compare_gt in H
      | [H : Lt = nat_compare x y |- _] =>
        apply eq_sym in H; apply nat_compare_lt in H
    end.

Lemma nat_compare_eq_eq : forall x,
  nat_compare x x = Eq.
Proof.
  induction x; auto.
Qed.

Lemma nat_compare_gt_gt : forall x n,
  n < x -> nat_compare x n = Gt.
Proof.
  induction x; destruct n; intros; simpl; auto; try (contradict H; omega).

  invert_typing H;  apply IHx; omega.
Qed.

Lemma nat_compare_lt_lt : forall x n,
  n > x -> nat_compare x n = Lt.
Proof.
  induction x; destruct n; intros; simpl; auto; try (contradict H; omega).

  invert_typing H;  apply IHx; omega.
Qed.

Lemma nil_not_nil : forall {T} A B (x:T),
  ~ (nil = A ++ x::B).
Proof.
  unfold not. intros T A B x H.

  destruct A; simpl in H;
    contradict H; auto using nil_cons.
Qed.

Lemma nil_not_nil_nat : forall A B (x:nat),
  ~ (nil = A ++ x::B).
Proof.
  apply nil_not_nil.
Qed.

Lemma nil_not_nil_ctx : forall A B (x:nat*typ),
  ~ (nil = A ++ x::B).
Proof.
  apply nil_not_nil.
Qed.
Hint Resolve nil_not_nil_nat nil_not_nil_ctx.

Lemma in_app_nat_list : forall (a:nat) A B,
  In a A \/ In a B -> In a (A++B).
Proof.
  auto using in_or_app.

Qed.

Lemma in_app_ctx_list : forall (a:context) A B,
  In a A \/ In a B -> In a (A++B).
Proof.
  auto using in_or_app.
Qed.
Hint Resolve in_app_nat_list in_app_ctx_list.

Lemma dom_app : forall A B,
  dom_t (A++B) = (dom_t A)++(dom_t B).
Proof.
  induction A; intros; simpl; auto.

  repeat rewrite -> app_nil_r; auto.

  rewrite -> IHA.  destruct a as (x, _ ); auto.
Qed.

Lemma in_dom : forall G x A, In (x,A) G -> In x (dom_t G).
Proof.
  intros G x A H1.  apply in_split in H1. destruct H1. destruct H. subst.

  rewrite -> dom_app.  apply in_app_nat_list.
  apply or_intror. simpl. auto.
Qed.

Lemma in_app_mid : forall {T} A B (x:T), In x (A ++ x::B).
Proof.
  intros. apply in_or_app. apply or_intror. apply in_eq.
Qed.

Lemma in_app_mid_nat : forall A B (x:nat), In x (A ++ x::B).
Proof.
  apply in_app_mid.
Qed.

Lemma in_app_mid_ctx : forall A B (x:context), In x (A ++ x::B).
Proof.
  apply in_app_mid.
Qed.
Hint Resolve in_app_mid_nat in_app_mid_ctx.

Lemma ok_app_dom : forall G G' x T,
  Ok (G ++ (x, T) :: G') ->
  ~ In x (dom_t G) /\ ~ In x (dom_t G').
Proof.
  induction G; intros G' x T H1; split; auto.

  simpl in H1. invert_typing H1; auto.

  simpl in *. destruct a as (x0, A).
  unfold not; intros H2. apply in_inv in H2. destruct H2 as [H2 | H2].
  subst. invert_typing H1. rewrite -> dom_app in H4. simpl in H4.
  apply H4. auto. invert_typing H1.  apply IHG in H3. destruct H3. contradiction.

  invert_typing H1. apply IHG in H2. destruct H2. auto.
Qed.

Lemma in_types_eq : forall x A B (G G':context),
  Ok (G ++ (x, B) :: G') ->
  In (x, A) (G ++ (x, B) :: G') -> A = B.
Proof.
  intros x A B G G' H1 H2.
  apply in_app_or in H2.  destruct H2 as [H2' | H2'].

  apply ok_app_dom in H1.
  destruct H1.

  apply in_dom in H2'. contradiction.
  apply in_inv in H2'. destruct H2'.
  invert_typing H; auto.

  apply in_dom in H. apply ok_app_dom in H1. destruct H1.
  contradiction.
Qed.

Lemma ele_nin_3 : forall L0 L1 L2 (y:nat),
  ~ In y (L0 ++ L1 ++ L2) -> ~ In y L2.
Proof.
  intros L0 L1 L2 y H1.

  unfold not; intro H2.
  apply or_intror with (A:=In y L1) in H2.

  apply in_app_nat_list in H2.
  apply or_intror with (A:=In y L0) in H2.
  apply in_app_nat_list in H2.
  auto.
Qed.
Hint Resolve ele_nin_3.

Lemma eq_list_ex : forall {A} (a:A) (G1 G2:list A),
   G1 = G2 -> a :: G1 = a :: G2.
Proof.
  intros. destruct G1. destruct G2.

  reflexivity.

  inversion H.

  rewrite <- H. reflexivity.
Qed.

Lemma x_nin_el_rm : forall (x y:nat) L,
  ~ In x (y::L) -> ~ In x L.
Proof.
  unfold not; intros x y L H1 H2.

  apply in_cons with (a:=y) in H2. auto.
Qed.
Hint Resolve x_nin_el_rm.

Lemma eq_ex_list_eq_el : forall {A} (G1 G2:list A) a b,
   a :: G1 = b :: G2 -> a = b.
Proof.
  intros. inversion H. auto.
Qed.

Lemma eq_ex_list_eq : forall {A} (G1 G2:list A) a b,
   a :: G1 = b :: G2 -> G1 = G2.
Proof.
  intros. destruct G1. destruct G2.

  reflexivity.

  inversion H. inversion H. reflexivity.
Qed.

Lemma eq_ex_list_eq_conj : forall {A} (G1 G2:list A) a b,
   a :: G1 = b :: G2 -> a = b /\ G1 = G2.
Proof.
  intros. remember (eq_ex_list_eq_el  G1 G2 a b H). remember (eq_ex_list_eq G1 G2 a b H).
  apply conj. auto. auto.
Qed.

Lemma eq_len_list_ex : forall {A} (a:A) (G1 G2:list A),
  length (a :: G1) = length (a :: G2) -> length G1 = length G2.
Proof.
  intros A a G1 G2 Hlen.
  destruct G1. destruct G2.

  eauto.

  inversion Hlen.
  auto.
Qed.

Lemma eq_list_eq_len : forall {A} (G1 G2:list A),
  G1 = G2 -> length G1 = length G2.
Proof.
  intros A G1 G2 Heq.
  destruct G1. destruct G2.

  eauto.

  inversion Heq.

  rewrite -> Heq. auto.
Qed.

Lemma el_nin_weakening : forall L A (y:nat),
  ~ In y (L ++ A) -> ~ In y (L ++ A ++ A).
Proof.
  intros L a y H1.  unfold not; intro H2.

  rewrite -> app_assoc in H2.
  apply in_app_or in H2. destruct H1.
  destruct H2; auto.
Qed.
Hint Resolve el_nin_weakening.

Lemma el_nin_contraction1 : forall (y:nat) L A B C,
  ~ In y (L ++ (A ++ B) ++ C) ->
  ~ In y (L ++ (A ++ B) ++ C ++ B).
Proof.
  unfold not; intros y L A B C H1 H2.

  rewrite <- app_assoc in H2. repeat rewrite -> app_assoc in H2.
  apply in_app_or in H2.  destruct H2.
  repeat rewrite <- app_assoc in H.
  rewrite <- app_assoc in H1; auto.

  apply or_intror with (A:=In y A) in H.
  apply in_or_app in H.
  apply or_introl with (B:=In y C) in H.
  apply in_or_app in H.
  apply or_intror with (A:=In y L) in H.
  apply in_or_app in H.
  auto.
Qed.
Hint Resolve el_nin_contraction1.

Lemma el_nin_conj_2 : forall L1 L2 (x:nat),
  ~ In x L1 /\ ~ In x L2 -> ~ In x (L1 ++ L2).
Proof.
  intros L1 L2 x H1.

  destruct H1 as [H1  H2]. unfold not; intro H3.
  apply in_app_or in H3. destruct H3 as [H3 | H4]; auto.
Qed.
Hint Resolve el_nin_conj_2.

Lemma el_nin_conj_3' : forall L1 L2 L (x:nat),
  ~ In x (L ++ L1 ++ L2) ->
  ~ In x L /\ ~ In x L1 /\ ~ In x L2.
Proof.
  intros L1 L2 L x H1; split; auto.

  split. rewrite -> app_assoc in H1. unfold not; intro.
  apply H1. auto.

  unfold not; intro. apply H1. auto.
Qed.
Hint Resolve el_nin_conj_3'.

Lemma el_nin_conj_3 : forall L1 L2 L (x:nat),
  ~ In x L /\ ~ In x L1 /\ ~ In x L2 -> ~ In x (L ++ L1 ++ L2).
Proof.
  intros L1 L2 L x H1. unfold not; intros H2.
  destruct H1 as [H1 H1'].
  destruct H1' as [H1' H1''].

  apply in_app_or in H2. destruct H2 as [H2 | H2]; auto.
  apply in_app_or in H2. destruct H2; auto.
Qed.
Hint Resolve el_nin_conj_3.

Lemma el_nin_trans1 : forall (y:nat) A B C L,
  ~ In y (L ++ A ++ B) ->
  ~ In y (L ++ A ++ C) ->
  ~ In y (L ++ A ++ B ++ C).
Proof.
  intros y A B C L H1 H2.

  apply el_nin_conj_3' in H2. apply el_nin_conj_3' in H1.
  destruct H2. destruct H0.

  apply conj with (A:=~ In y L /\ ~ In y A /\ ~ In y B) in H2; auto.
  repeat rewrite -> and_assoc in H2.

  apply el_nin_conj_3. split; auto. split; auto.
  apply el_nin_conj_2. split.
  destruct H2. destruct H3. destruct H4; auto.
  destruct H2. destruct H3. destruct H4; auto.
Qed.
Hint Resolve el_nin_trans1.

Lemma el_nin_contraction2 : forall (y:nat) L A B C,
  ~ In y (L ++ A ++ B ++ C) ->
  ~ In y (L ++ A ++ B ++ A ++ C).
Proof.
  unfold not; intros y L A B C H1 H2.

  repeat rewrite -> app_assoc in H2. apply in_app_or in H2.
  destruct H2 as [H2 | H2]. apply in_app_or in H2. destruct H2 as [H2 | H2].

  repeat rewrite <- app_assoc in H2.
  apply or_introl with (B:=In y C) in H2.
  apply in_or_app in H2.
  repeat rewrite <- app_assoc in H2; auto.

  apply or_introl with (B:=In y B) in H2.
  apply in_or_app in H2.
  apply or_introl with (B:=In y C) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y L) in H2.
  apply in_or_app in H2.
  repeat rewrite <- app_assoc in H2; auto.

  apply or_intror with (A:=In y B) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y A) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y L) in H2.
  apply in_or_app in H2.
  auto.
Qed.
Hint Resolve el_nin_contraction2.

Lemma el_nin_trans2 : forall (y:nat) A B C L,
  ~ In y (L ++ A ++ B) ->
  ~ In y (L ++ B ++ C) ->
  ~ In y (L ++ A ++ B ++ C).
Proof.
  intros. apply el_nin_trans1; eauto.

  apply el_nin_conj_3.
  split; auto.
  split.
  apply el_nin_conj_3' in H. destruct H. destruct H1; auto.
  apply el_nin_conj_3' in H0. destruct H0. destruct H1; auto.
Qed.
Hint Resolve el_nin_trans2.

Lemma el_nin_permute1 : forall A B C D (y:nat),
  ~ In y (A ++ B ++ C ++ D) -> ~ In y (A ++ B ++ D ++ C).
Proof.
  unfold not; intros A B C D y H1 H2.

  repeat rewrite -> app_assoc in H2.
  apply in_app_or in H2. destruct H2 as [H2 | H2].
  apply in_app_or in H2. destruct H2 as [H2 | H2].

  apply or_introl with (B:=In y C) in H2.
  apply in_or_app in H2.
  apply or_introl with (B:=In y D) in H2.
  apply in_or_app in H2.
  repeat rewrite <- app_assoc in H2. auto.

  apply or_intror with (A:=In y C) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y B) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y A) in H2.
  apply in_or_app in H2.
  auto.

  apply or_introl with (B:=In y D) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y B) in H2.
  apply in_or_app in H2.
  apply or_intror with (A:=In y A) in H2.
  apply in_or_app in H2.
  auto.
Qed.
Hint Resolve el_nin_permute1.

Theorem app_eq_lengths_eq : forall {A} (G1 G2 G3 G4 : list A),
     G1 ++ G2 = G3 ++ G4
  -> length G1 = length G3
  -> G1 = G3 /\ G2 = G4.
Proof.
  (* Kick off induction and introduce our
   * our assumptions. *)
  induction  G1. intros G2 G3 G4 Heq Hlen.

  (* We case split on G3. *)
  destruct G3.

  (* Base case. *)
  auto. inversion Hlen.

  (* Step Case.
   * Introduce our assumptions. *)
  intros G2 G3 G4 Heq Hlen.
  (* Case split on G3. *)
  destruct G3.
  (* G3 = nil case. *)
  inversion Hlen. inversion Hlen. inversion Heq.
  (* Context extend case.
   * Use our induction hypothesis. *)
  destruct IHG1 with G2 G3 G4.
  (* At this point we need G1 = G3 and G2 = G4. *)
  auto. rewrite -> H1 in Hlen. apply eq_len_list_ex with a0. auto.
  (* Now that we have the equalites all we need to do
   * is use conjunction and eq_list_ex and
   * finish off with auto. *)
  apply conj. apply eq_list_ex. auto. auto.
Qed.

Lemma ex_app_list_eq : forall {A} (G1 G2 G3 G4 : list A) a b,
  (a :: G1) ++ G2 = (b :: G3) ++ G4 -> G1 ++ G2 = G3 ++ G4.
Proof.
  intros A G1 G2 G3 G4 a b Heq.
  destruct G1. destruct G3.

  (* Nil,Nil case. *)
  simpl in *. apply eq_ex_list_eq in Heq. auto.
  (* Ni, cons case. *)
  simpl in *. inversion Heq. auto.
  (* Cons, cons case. *)
  inversion Heq. rewrite <- app_comm_cons. auto.
Qed.

Lemma len_ex_list_eq : forall {A} (G1 G2 : list A) a b,
  length (a :: G1) < length (b :: G2) -> length G1 < length G2.
Proof.
  intros A G1 G2 a b Hlen.
  destruct G1. destruct G2.

  (* Nil, nul case. *)
  simpl in *. inversion Hlen. inversion H0.
  (* Nil, cons case. *)
  simpl in *. inversion Hlen. eauto. rewrite <- H in Hlen. rewrite <- H. inversion Hlen. auto.
  rewrite <- H in H0. omega.
  (* Cons, cons case. *)
  simpl in *. inversion Hlen. omega. omega.
Qed.

Lemma eq_list_cons_eq : forall {A} (G1 G2 G3 : list A) a,
  G1 = G2 ++ G3 -> a :: G1 = (a :: G2) ++ G3.
Proof.
  intros. destruct G1. destruct G2.
  simpl in *. rewrite <- H. auto.
  simpl in *. rewrite <- H. auto.
  simpl in *. rewrite <- H. auto.
Qed.

Theorem app_eq_lengths_lt2 : forall {A} (G1 G2 G3 G4 : list A) a,
     G1 ++ a :: G2 = G3 ++ G4
  -> length G1 < length G3
  -> exists G5, G3 = G1 ++ a :: G5 /\ G2 = G5 ++ G4.
Proof.
  (* We will kick off with induction and case split on G3. *)
  induction G1. intros G2 G3 G4 a Heq Hlen. destruct G3.

  (* Base case. *)
  simpl in *. inversion Hlen.  simpl in *. inversion Heq.
  exists G3. auto.

  (* Step case. *)
  intros G2 G3 G4 b Heq Hlen. destruct G3.
  simpl in *. inversion Hlen.
  simpl in *. inversion Heq. destruct IHG1 with G2 G3 G4 b.
  auto. omega.

  destruct H. exists x. apply eq_list_cons_eq with G3 G1 (b :: x) a0 in H.
  apply conj. auto. auto.
Qed.

Theorem app_eq_lengths_lt : forall {A} (G1 G2 G3 G4 : list A),
  G1 ++ G2 = G3 ++ G4
  -> length G1 < length G3
  -> exists G5, G3 = G1 ++ G5 /\ G2 = G5 ++ G4.
Proof.
  (* We will kick off with induction and case split on G3. *)
  induction G1. intros G2 G3 G4 Heq Hlen. destruct G3.

  (* Base case.
   * Nil case. *)
  simpl in *. inversion Hlen.
  (* List app case. *)
  simpl in *. rewrite -> Heq. eauto.

  (* Step case.
   * Introduce our assumptions and case split on G3. *)
  intros G2 G3 G4 Heq Hlen. destruct G3.
  (* Nil case. *)
  simpl in *. inversion Hlen.
  (* List app case.
   * Apply the induction hypothesis, which will generate three subgoals. *)
  destruct IHG1 with G2 G3 G4.
  (* First subgoal.
   * We know that (a::G1) ++ G2 = (a0 :: G3) ++ G4, and this implies that
   * G1 ++ G2 = G3 ++ G4, which we can obtain by applying ex_app_list_eq.
   * This also finishes off the current subgoal. *)
  apply ex_app_list_eq in Heq. auto.
  (* Second subgoal.
   * We have to show that the length G1 > length G3 which is easly obtained by
   * applying len_ex_list_eq.*)
  apply len_ex_list_eq in Hlen. auto.
  (* Third subgoal.
   * We now need to show the final part of the induction hypothesis.
   * Grab all the equalites from Heq and simplify. *)
  inversion Heq. subst.
  (* Declare our witness and grab some more equalites. *)
  exists x. inversion H.
  (* Now we need to show the conjunction we already know the second part and
   * the first part is a result of applying eq_list_cons_eq. *)
  apply eq_list_cons_eq with G3 G1 x a0 in H0.
  apply conj. auto. auto.
Qed.

Lemma list_sum_len_eq : forall {A} (G1 G2 : list A) n m,
  n = length G1 -> m = length G2 -> n + m = length (G1 ++ G2).
Proof.
  intros A G1 G2 n m H1len H2len.

  induction n. destruct m.

  (* Base case.*)
  rewrite -> app_length. auto.
  rewrite -> app_length. auto.

  (* Step case. *)
  rewrite -> H1len.
  rewrite -> H2len.
  rewrite <- app_length. auto.
Qed.

Lemma list_app_list_eq_nil_r : forall {A} (G1 : list A),
    G1 = G1 ++ nil.
Proof.
  induction G1. intros.

  (* Base case.*)
  auto.
  (* Step case. *)
  simpl in *. rewrite -> app_comm_cons. rewrite -> app_nil_r. auto.
Qed.

Lemma list_app_list_eq_nil_l : forall {A} (G1 : list A),
    G1 = nil ++ G1.
Proof.
  auto.
Qed.

Lemma gt_comm_lt : forall n m,
  n > m -> m < n.
Proof.
  auto with arith.
Qed.

Lemma nat_lteq_succ_lteq : forall n m,
  n <= m -> (S n) <= (S m).
Proof.
  intros. auto with arith.
Qed.

Lemma nat_succ_plus : forall n m,
  (S n) + m = S (n + m).
Proof.
  auto with arith.
Qed.

Lemma plus_to_succ : forall n,
  n + 1 = S n.
Proof.
  intros. omega.
Qed.

Lemma length_succ_cons : forall {A} (G:list A) n T,
  n = length G -> n + 1 = length (T :: G).
Proof.
  destruct G; intros; simpl in *; rewrite ->  H; auto with arith.
  rewrite -> plus_to_succ; auto.
Qed.

Lemma eq_list_eq_cons : forall {A} (G G1 G2 : list A) a,
  G = G1 ++ G2 -> a :: G = (a :: G1) ++ G2.
Proof.
  intros. rewrite -> H. rewrite -> app_comm_cons. auto.
Qed.

(* Lemmas related to well-formed contexts. *)
Lemma ok_rest : forall G x,
  Ok (x::G) -> Ok G.
Proof.
  intros. inversion H. auto.
Qed.

Lemma ok_app_conj : forall G1 G2, Ok (G1++G2) -> Ok G1 /\ Ok G2.
Proof.
  induction G1; destruct G2; intros H1; auto.

  rewrite -> app_nil_r in H1. auto.

  split.
  destruct a; apply Ok_ex.
  copy_hyp H1 H1'.
  simpl in H1. apply ok_rest in H1.
  copy_hyp H1' H1''.
  apply IHG1 in H1. destruct H1. auto.

  invert_typing H1. rewrite -> dom_app in H4.
  eauto.

  simpl in H1. apply ok_rest in H1. apply IHG1. auto.
Qed.
Hint Resolve ok_app_conj.

Lemma ok_app_de_app : forall G1 G2 G3,
  Ok (G1++G2++G3) -> Ok(G1++G2).
Proof.
  intros G1 G2 G3 H1.

  rewrite -> app_assoc in H1.
  apply ok_app_conj in H1. destruct H1; auto.
Qed.
Hint Resolve ok_app_de_app.

Lemma ok_app : forall G' G,
  Ok (G++G') -> Ok G.
Proof.
  intros. remember (ok_app_de_app G nil G'). simpl in *.
  clear Heqo. rewrite -> app_nil_r in o. auto.
Qed.

Lemma ok_app_de_cons : forall G1 G2 a,
  Ok (G1++a::G2) -> Ok(G1++G2).
Proof.
  induction G1; intros.  simpl in *. invert_typing H; auto.

  simpl in *. destruct a. invert_typing H.
  apply Ok_ex. apply IHG1 with (a:=a0); auto.

  rewrite -> dom_app. rewrite -> dom_app in H4.
  apply el_nin_conj_2. split; eauto.

  apply el_nin_conj_3' with (L:=nil) in H4.
  destruct H4. destruct H1. simpl in H3. destruct a0 in H3.
  eauto.
Qed.
Hint Resolve ok_app_de_cons.

Lemma in_weakening : forall G1 G2 G3 (a:nat*typ),
  In a (G1 ++ G3) -> In a (G1 ++ G2 ++ G3).
Proof.
  intros G1 G2 G3 a H1. apply in_app_or in H1.
  apply or_introl with (B:=In a G2) in H1.
  rewrite -> or_assoc in H1.
  rewrite -> or_comm with (A:=In a G3) (B:=In a G2) in H1.
  rewrite <- or_assoc in H1.
  destruct H1 as [ H1 | ]; eauto using in_or_app.
  destruct H1; eauto using in_or_app.
Qed.
Hint Resolve in_weakening.

Lemma not_in_app_l : forall (x:nat) L L',
  ~ In x (L ++ L') -> ~ In x L.
Proof.
  eauto.
Qed.
Hint Resolve not_in_app_l.

Lemma el_nin_app_rm_2_4 : forall L1 L2 L3 L (x:nat),
  ~ In x (L ++ L1 ++ L2 ++ L3) ->
  ~ In x (L ++ L2).
Proof.
  intros L1 L2 L3 L x H1. apply el_nin_conj_3' in H1.
  destruct H1 as [H1  H2]. destruct H2 as [H2  H3].
  eauto.
Qed.
Hint Resolve el_nin_app_rm_2_4.

Lemma el_nin_conj : forall L1 L2 (x:nat),
  ~ In x (L1 ++ L2) -> ~ In x L1 /\ ~ In x L2.
Proof.
  eauto.
Qed.
Hint Resolve el_nin_conj.

Lemma trm_fvar_close : forall x y n,
  x <> y ->
  trm_fvar x = (close_t n y (trm_fvar x)).
Proof.
  intros. simpl. clarify_compares_natc; auto.
  subst. contradict H; auto.
Qed.

Lemma list_cons_eq_app : forall {A} L (x:A), x :: L = (x::nil)++L.
Proof.
  eauto.
Qed.

Lemma cons_to_app : forall (x:nat) L,
  (x :: L) = (x :: nil)++L.
Proof.
  simpl; auto.
Qed.

(* This tactic finds all conjuncts in the context
 * and destructs them.  *)
Ltac destruct_conj :=
  match goal with
    | [H : _ /\ _ |- _ ] =>
      destruct H; try destruct_conj
  end.
(* Much like destruct_conj this tactic first finds all
 * elements of the context whose type is of the form ~ In x _
 * and converts them into conjuncts, and then destructs those
 * conjunctions.  This is a very handy tactic when reasoning about
 * names. *)
Ltac destruct_nin :=
  match goal with
    | [H : ~ In _ (_ ++ _) |- _] =>
      apply el_nin_conj in H; destruct_conj; try destruct_nin
    | [H : ~ In _ (_ :: _ ++ _) |- _] =>
      rewrite -> list_cons_eq_app in H; apply el_nin_conj in H;
        destruct_conj; try destruct_nin
    | [H : ~ In _ (_ :: _ :: _) |- _] =>
      rewrite -> list_cons_eq_app in H; apply el_nin_conj in H;
        destruct_conj; try destruct_nin
  end.
Tactic Notation "destruct_nin" "*" := destruct_nin; intuition eauto.

Lemma not_in_app_r : forall (x:nat) L L',
  ~ In x (L ++ L') -> ~ In x L'.
Proof.
  eauto.
Qed.
Hint Resolve not_in_app_r.

Lemma el_nin_app_rm_1 : forall L1 L2 L3 L (x:nat),
  ~ In x (L ++ L1 ++ L2 ++ L3) ->
  ~ In x (L1 ++ L2 ++ L3).
Proof.
  eauto.
Qed.
Hint Resolve el_nin_app_rm_1.

Lemma not_in_not_eq_head : forall {A} (x0 x:A) L,
  ~ In x0 (x :: L) -> x0 <> x.
Proof.
  unfold not; intros A x0 x L H1 H2.
  subst. auto using in_eq.
Qed.

Lemma ok_ex_head : forall x x0 T T1 G1 G2,
  Ok (G1 ++ (x, T) :: G2) ->
  x0 <> x ->
  ~ In x0 (dom_t G1) ->
  ~ In x0 (dom_t G2) ->
  Ok ((x0, T1) :: G1 ++ (x, T) :: G2).
Proof.
  intros. apply Ok_ex; auto. unfold not; intros.
  rewrite -> dom_app in H3. simpl in H3.
  apply in_app_or in H3. destruct H3; auto.

  simpl in H3. destruct H3; auto.
Qed.
Hint Resolve ok_ex_head.

Lemma ok_in_unique : forall G G' x T T',
  Ok (G++(x,T)::G') -> In (x,T') (G++(x,T)::G') -> T = T'.
Proof.
  induction G; intros. simpl in *.
  destruct H0. invert_typing H0; auto.

  invert_typing H. apply in_dom in H0. contradiction.

  simpl in *. destruct H0. subst. contradict H. unfold not; intros.
  invert_typing H. apply H4. rewrite -> dom_app. apply in_or_app.
  apply or_intror. simpl. auto.

  apply IHG with (G':=G') (x:=x); auto; invert_typing H; auto.
Qed.
Hint Resolve ok_in_unique.

Lemma in_squash : forall (x x' : nat) (T T':typ) G G',
  In (x,T) (G++(x',T')::G') -> x <> x' -> In (x,T) (G++G').
Proof.
  intros.  apply in_app_or in H.
  destruct H.
  apply or_introl with (B:=In (x,T) G') in H.
  apply in_or_app in H. auto.

  simpl in H. destruct H. invert_typing H. contradict H0; auto.
  apply or_intror with (A:=In (x,T) G) in H.
  apply in_or_app in H. auto.
Qed.
Hint Resolve in_squash.

Lemma ok_in_squash : forall x x0 T T0 G1 G2,
  x <> x0 ->
  Ok (G1 ++ (x, T) :: G2) ->
  In (x0, T0) (G1 ++ (x, T) :: G2) ->
  In (x0, T0) (G1 ++ G2).
Proof.
  eauto.
Qed.
Hint Resolve ok_in_squash.

Lemma lt_not_eq : forall n m,
  n < m -> n <> m.
Proof.
  intros; omega.
Qed.
Hint Resolve lt_not_eq.

Lemma gt_not_eq : forall n m,
  n > m -> n <> m.
Proof.
  intros; omega.
Qed.
Hint Resolve gt_not_eq.

Lemma not_free_in_var : forall x x0 L,
  ~ In x0 (x :: L) -> ~ free_in_t x (trm_fvar x0).
Proof.
  intros. unfold free_in_t. simpl. unfold not; intros.
  destruct H0; auto. subst. apply H. apply in_eq.
Qed.
Hint Resolve not_free_in_var.

Lemma in_app : forall G' (a:nat*typ) G,
  In a G -> In a (G++G').
Proof.
  intros. induction G; destruct G'. auto. contradict H. simpl.
  simpl in *. rewrite -> app_nil_r. auto.
  simpl. simpl in H. destruct H. auto. auto.
Qed.
Hint Resolve in_app.

Lemma unique_elem_G : forall x x0 T T0 G,
  Ok G -> In (x,T) G -> In (x0,T0) G -> x = x0 -> T = T0.
Proof.
  induction G; intros. subst.

  simpl in *. contradiction.

  subst; simpl in *.
  destruct H1; destruct H0. subst. invert_typing H0; auto.
  invert_typing H. invert_typing H2. apply in_dom in H0.
  contradiction.
  invert_typing H. invert_typing H2. apply in_dom in H1.
  contradiction.
  apply IHG; invert_typing H; auto.
Qed.
Hint Resolve unique_elem_G.

(* Results for picking fresh variables. *)
Lemma pick_fresh_app : forall L1 L2,
  pick_fresh (L1 ++ L2) = pick_fresh L1 + pick_fresh L2.
Proof.
  intros. induction L1. simpl; auto.

  simpl. rewrite -> IHL1. omega.
Qed.

Lemma pick_fresh_gt : forall L,
  (forall y, In y L -> pick_fresh L > y).
Proof.
  induction L; intros.

  simpl in H. contradiction.

  simpl in *. inversion H. subst. omega. apply IHL in H0. omega.
Qed.
Hint Resolve pick_fresh_gt.

Lemma gt_not_in : forall L (y:nat),
  (forall z, In z L -> y > z) -> ~ (In y L).
Proof.
  induction L; intros.

  auto.

  simpl in *. unfold not; intros. inversion H0. subst. inversion H0.
  remember (H y). clear Heqg. apply g in H0. omega.

  contradict H1; apply IHL. intros. apply H. auto.

  contradict H1; apply IHL. intros. apply H. auto.
Qed.
Hint Resolve gt_not_in.

Lemma nat_refl : forall (n:nat), n = n.
Proof.
  auto with arith.
Qed.
Hint Resolve nat_refl.

(* Results regarding context. *)
Lemma ctx_refl : forall (G:context), G = G.
Proof.
  intros; auto.
Qed.
Hint Resolve ctx_refl.

Lemma ctx_refl_nil : forall (G:context), G = nil ++ G.
Proof.
  intros; auto.
Qed.
Hint Resolve ctx_refl_nil.

Lemma el_nin_app_head : forall (x:nat) L1 L2, ~ In x (L1++L2) -> ~ In x L1.
Proof.
  eauto.
Qed.
Hint Resolve el_nin_app_head.

Lemma el_nin_app_tail : forall (x:nat) L1 L2, ~ In x (L1++L2) -> ~ In x L2.
Proof.
  eauto.
Qed.
Hint Resolve el_nin_app_tail.

Lemma el_nin_rm_2 : forall (x:nat) L1 L2 L3, ~ In x (L1++L2++L3) -> ~ In x (L1++L3).
Proof.
  eauto.
Qed.
Hint Resolve el_nin_rm_2.

Lemma el_nin_app_decomp : forall (x:nat) A B, ~ In x A -> ~ In x B -> ~ In x (A++B).
Proof.
  unfold not; intros. apply in_app_or in H1.
  destruct H1; auto.
Qed.
Hint Resolve el_nin_app_decomp.

Lemma pick_fresh_nin' : forall L1 n,
  n = pick_fresh L1 -> ~ In n L1.
Proof.
  intros. apply gt_not_in. intros. subst. apply pick_fresh_gt. auto.
Qed.
Hint Resolve pick_fresh_nin'.

Lemma pick_fresh_nin : forall L1,
  ~ In (pick_fresh L1) L1.
Proof.
  intros. apply pick_fresh_nin'. auto.
Qed.
Hint Resolve pick_fresh_nin.

Lemma pick_fresh_app_nin' : forall L1 L2 n,
  n = pick_fresh (L1 ++ L2) ->
  ~ In n L1 /\ ~ In n L2.
Proof.
  intros. remember (pick_fresh_nin (L1++L2)). clear Heqn0.
  unfold not in *.
  split; intros; apply n0; apply in_or_app;
    [apply or_introl | apply or_intror]; subst; auto.
Qed.
Hint Resolve pick_fresh_app_nin'.

Lemma pick_fresh_app_tail : forall L1 L2, ~ In (pick_fresh (L1++L2)) L2.
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_app_tail.

Lemma pick_fresh_app_head : forall L1 L2, ~ In (pick_fresh (L1++L2)) L1.
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_app_head.

Lemma pick_fresh_app_nin : forall L1 L2,
  ~ In (pick_fresh (L1 ++ L2)) L1 /\ ~ In (pick_fresh (L1 ++ L2)) L2.
Proof.
  intros. apply pick_fresh_app_nin'; auto.
Qed.
Hint Resolve pick_fresh_app_nin.

Lemma pick_fresh_nin_1 : forall L0 L1 L2,
  ~ In (pick_fresh (L0 ++ L1 ++ L2)) L0.
Proof.
  intros.
  (remember (pick_fresh_app_nin' L0 (L1 ++ L2) (pick_fresh (L0++L1++L2)) (nat_refl _))). destruct a.
  auto.
Qed.
Hint Resolve pick_fresh_nin_1.

Lemma pick_fresh_nin_3 : forall L0 L1 L2,
  ~ In (pick_fresh (L0 ++ L1 ++ L2)) L2.
Proof.
  intros.
  remember (pick_fresh_app_nin (L0 ++ L1) L2). clear Heqa. rewrite <- app_assoc in a.
  destruct a; auto.
Qed.
Hint Resolve pick_fresh_nin_3.

Lemma pick_fresh_eq : forall L1 L2 L3,
  pick_fresh (L1++L2++L3) = pick_fresh (L2++L1++L3).
Proof.
  intros; repeat rewrite -> pick_fresh_app; omega.
Qed.
Hint Resolve pick_fresh_eq.

Lemma pick_fresh_eq' : forall L1 L2 L3,
  pick_fresh (L1++L2++L3) = pick_fresh (L1++L3++L2).
Proof.
  intros; repeat rewrite -> pick_fresh_app; omega.
Qed.
Hint Resolve pick_fresh_eq'.

Lemma pick_fresh_nin_2 : forall L0 L1 L2,
  ~ In (pick_fresh (L0 ++ L1 ++ L2)) L1.
Proof.
  intros.
  remember (pick_fresh_app_nin L1 (L0++L2)). destruct a.
  clear Heqa.
  rewrite <- pick_fresh_eq in n. auto.
Qed.
Hint Resolve pick_fresh_nin_2.

Lemma pick_fresh_nin_4_3 : forall L0 L1 L2 L3,
  ~ In (pick_fresh (L0 ++ L1 ++ L2++L3)) L2.
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_4_3.

Lemma pick_fresh_nin_5_4 : forall L0 L1 L2 L3 L4,
  ~ In (pick_fresh (L0 ++ L1 ++ L2 ++ L3 ++ L4)) L3.
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_5_4.

Lemma pick_fresh_nin_rm_2 : forall L1 L2 L3,
    ~ In (pick_fresh (L1 ++ L2 ++ L3)) (L1 ++ L3).
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_rm_2.

Lemma pick_fresh_nin_rm_2_3 : forall L1 L2 L3 L4,
  ~ In (pick_fresh (L1 ++ L2 ++ L3 ++ L4)) (L1 ++ L4).
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_rm_2_3.

Lemma pick_fresh_nin_rm_1_3 : forall L1 L2 L3 L4,
    ~ In (pick_fresh (L1 ++ L2 ++ L3 ++ L4)) (L2 ++ L4).
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_rm_1_3.

Lemma pick_fresh_nin_5_5 : forall L0 L1 L2 L3 L4,
  ~ In (pick_fresh (L0 ++ L1 ++ L2 ++ L3++L4)) L4.
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_nin_5_5.

Lemma pick_fresh_rm_el_C : forall A B C x,
  ~ In (pick_fresh (A++B++x::C)) (A++B++C).
Proof.
  eauto.
Qed.
Hint Resolve pick_fresh_rm_el_C.

Lemma in_pick_fresh_neq : forall x L,
  In x L -> trm_fvar x <> trm_fvar (pick_fresh L).
Proof.
  unfold not; intros. invert_typing H0; clear H0.
  contradict H. eauto.
Qed.
Hint Resolve in_pick_fresh_neq.

Lemma pick_fresh_premute1 : forall A B C D,
  pick_fresh (A ++ B ++ C ++ D) = pick_fresh (A ++ B ++ D ++ C).
Proof.
  intros. repeat rewrite -> pick_fresh_app. omega.
Qed.
Hint Resolve pick_fresh_premute1.

Lemma el_nin_fv_open : forall t t' x n,
~ In x (FV_t t ++ FV_t t') ->
~ In x (FV_t (open_t n t t')).
Proof.
  induction t'; intros. simpl.

  clarify_compares_natc; eauto.

  eauto.

  simpl in *. apply IHt'; eauto.
  simpl in *. apply IHt'; auto.

  simpl. apply el_nin_conj_2. split. apply IHt'1; simpl in H.
  rewrite -> app_assoc in H. apply el_nin_conj in H.
  eauto.

  apply IHt'2; simpl in H; eauto.

  simpl in *. apply IHt'. auto.

  simpl in *; auto.
Qed.
Hint Resolve el_nin_fv_open : naming_fv.

Lemma trm_lam_eq : forall t t' T T',
  trm_lam T t = trm_lam T' t' <-> T = T' /\ t = t'.
Proof.
  split; intros; inversion H; auto.

  destruct H; subst; auto.
Qed.

Lemma trm_Lam_eq : forall t t',
  trm_Lam t = trm_Lam t' <-> t = t'.
Proof.
  split; intros H; inversion H; auto.
Qed.

Lemma trm_lam_eq_bodies : forall t t' T,
  trm_lam T t = trm_lam T t' -> t = t'.
Proof.
  intros; inversion H; auto.
Qed.

Lemma open_comm : forall t n m y z,
  n <> m ->
  z <> y ->
  open_t n (trm_fvar y) (open_t m (trm_fvar z) t) =
  open_t m (trm_fvar z) (open_t n (trm_fvar y) t).
Proof.
  induction t as [x | x | A t IH | t IH | t1 IH1 t2 IH2 | t IH T | ];
    intros n m y z H1 H2; simpl; auto.

  clarify_compares_natc; simpl; auto; clarify_compares_natc;
    auto; simpl; subst; auto; try clarify_compares_natc; subst; auto;
      try (contradict Heqc; omega).

  contradict H1; auto.

  rewrite -> IH; auto.
  rewrite -> IH; auto.

  rewrite -> IH1; auto. rewrite -> IH2; auto.

  rewrite -> IH; auto.
Qed.

Lemma close_id : forall t x n,
  ~ In x (FV_t t) -> close_t n x t = t.
Proof.
  induction t; intros; simpl; eauto.

  clarify_compares_natc; auto. subst. contradict H. apply in_eq.

  rewrite -> IHt; eauto.
  rewrite -> IHt; eauto.

  rewrite -> IHt1; eauto. rewrite -> IHt2; eauto.
  rewrite -> IHt; auto.
Qed.

Lemma close_open_comm : forall t1 t2 m n x,
  m <> n ->
  ~ In x (FV_t t2) ->
  close_t m x (open_t n t2 t1) = open_t n (close_t m x t2) (close_t m x t1).
Proof.
  induction t1; intros; rewrite -> close_id with (t:=t2); eauto; simpl.

  clarify_compares_natc; subst; eauto. rewrite -> close_id with (t:=t2); eauto.
  clarify_compares_natc; subst; eauto.
  simpl. clarify_compares_natc; subst; eauto. contradict H. auto.

  rewrite -> IHt1; eauto. rewrite -> close_id with (t:=t2); eauto.
  rewrite -> IHt1; eauto. rewrite -> close_id with (t:=t2); eauto.

  rewrite -> IHt1_1; eauto. rewrite -> IHt1_2; eauto.
  rewrite -> close_id with (t:=t2); eauto.

  rewrite -> IHt1; auto. rewrite -> close_id with (t:=t2); auto.
Qed.

Lemma trm_fvar_eq1 : forall n m,
  n = m -> trm_fvar n = trm_fvar m.
Proof.
  intros. inversion H. auto.
Qed.

Lemma trm_fvar_eq2 : forall n m,
    trm_fvar n = trm_fvar m -> n = m.
Proof.
  intros. inversion H. auto.
Qed.

Definition Is_bvar (t:trm) :=
  match t with
    | trm_bvar n => True
    | _ => False
  end.

Definition Is_fvar (t:trm) :=
    match t with
      | trm_fvar n => True
      | _ => False
    end.

Definition Is_lam (t:trm) :=
  match t with
    | trm_lam A t1 => True
    | _ => False
  end.

Definition Is_Lam (t:trm) :=
  match t with
    | trm_Lam t1 => True
    | _ => False
  end.

Definition Is_app (t:trm) :=
  match t with
    | trm_app t1 t2 => True
    | _ => False
  end.

Definition Is_tapp (t:trm) :=
  match t with
    | trm_tapp _ _ => True
    | _ => False
  end.

Definition Is_arrow (T:typ) :=
  match T with
    | typ_arrow T1 T2 => True
    | _ => False
  end.

Definition Is_base (T:typ) :=
  match T with
    | typ_base => True
    | _ => False
  end.

Definition Is_trm_c (t:trm) :=
  match t with
    | trm_c => True
    | _ => False
  end.

Definition Is_some (t:option typ) :=
  match t with
    | Some _ => True
    | _ => False
  end.

Definition Is_none (t:option typ) :=
  match t with
    | None => True
    | _ => False
  end.

Lemma opt_refl : forall {A} (a:A),
  Some a = Some a.
Proof.
  auto.
Qed.

Lemma neq_sym : forall {A} (a b : A),
  a <> b -> b <> a.
Proof.
  auto.
Qed.

Lemma none_neq_some : forall (a:typ),
  None <> Some a.
Proof.
  intros.
  red. intros. change (Is_none (Some a)). rewrite <- H. simpl. trivial.
Qed.

Ltac smash_help H t1 t2 is_f RD :=
  contradict H; unfold not; intros;
    match goal with
      | [H' : t1 = t2 |- _ ] =>
        change is_f;
          match RD with
            | True => rewrite -> H'
            | False => rewrite <- H'
          end; simpl; auto
    end.

Ltac match_contra_form :=
  match goal with
    | [ H : ?A = ?B |- _ ] =>
      match A with
        | trm_c =>
          match B with
            | trm_c => constr:True
            | _ => constr:(H, A, B, (Is_trm_c B))
          end
        | trm_bvar _ =>
          match B with
            | trm_bvar _ => constr:True
            | _ => constr:(H, A, B, (Is_bvar B))
          end
        | trm_fvar _ =>
          match B with
            | trm_fvar _ => constr:True
            | _ => constr:(H, A, B, (Is_fvar B))
          end
        | trm_lam _ _ =>
          match B with
            | trm_lam _ _ => constr:True
            | _ => constr:(H, A, B, (Is_lam B))
          end
        | trm_Lam _ =>
          match B with
            | trm_Lam _ => constr:True
            | _ => constr:(H, A, B, (Is_Lam B))
          end
        | trm_app _ _ =>
          match B with
            | trm_app _ _ => constr:True
            | _ => constr:(H, A, B, (Is_app B))
          end
        | trm_tapp _ _ =>
          match B with
            | trm_tapp _ _ => constr:True
            | _ => constr:(H, A, B, (Is_tapp B))
          end
        | None =>
          match B with
            | None => constr:True
            | _ => constr:(H, A, B, (Is_none B))
          end
        | Some _ =>
          match B with
            | Some _ => constr:True
            | _ => constr: (H, A, B, (Is_some B))
          end
        | typ_arrow _ _ =>
          match B with
            | typ_arrow _ _ => constr:True
            | _ => constr:(H, A, B, (Is_arrow B))
          end
        | typ_base =>
          match B with
            | typ_base => constr:True
            | _ => constr:(H, A, B, (Is_base B))
          end
      end
  end.

(* This tactic tries to solve any goal who results from a contradiction
 * formed by a contradictory equality between terms, types, or option constructors. *)
Ltac smash_trm_typ_contra :=
  let A := match_contra_form in
    match A with
      | True => idtac
      | (?H, ?t, ?t', ?is_f) =>
        contradict H; unfold not; intros; change is_f;
          match goal with
            [ H' : t = t' |- _] => rewrite <- H'
          end; simpl; auto
    end.
(* This tactic tries to solve a goal which has a hypothesis of an
 * inequality between nats and a hypothesis of an equality between
 * trm_fvar's whose names are said nats. *)
Ltac smash_var_contra :=
  match goal with
    | [ H' : ?x <> ?x' |- _ ] =>
      match goal with
        | [ H : trm_fvar x' = trm_fvar x |- _] =>
          contradict H; unfold not; intros; apply (trm_fvar_eq2 x' x) in H; auto
        | [ H : trm_fvar x = trm_fvar x' |- _] =>
          contradict H; unfold not; intros; apply (trm_fvar_eq2 x x') in H; auto
        | [ H : x = x' |- _ ] =>
          contradict H'; auto
      end
  end.
(* Clears all trivial equalities. *)
Ltac clear_trivial_eqs :=
  match goal with
    | [_ : ?A = _ |- _] =>
      match goal with
        | [H : A = A |- _] =>
          clear H; clear_trivial_eqs
        | _ => idtac
      end
  end.
  (* Nat. contras. *)
Ltac nat_contra :=
  match goal with
    | [ _ : ?x < ?y |- _] =>
      match goal with
        | [ H : x < x |- _ ] =>
          contradict H; omega
        | [ H : y < x |- _] =>
          contradict H; omega
      end
    | [ _ : ?x > ?y |- _] =>
      match goal with
        | [ H : x > x |- _ ] =>
          contradict H; omega
      end
    | [ H : _ < 0 |- _ ] =>
      contradict H; omega
    | [ _ : ?x <> _ |- _] =>
      match goal with
        | [  H : x <> x |- _ ] =>
          contradict H; auto
      end
  end.

Ltac names_contra :=
  match goal with
    | [H : ~ In ?y (FV_t (trm_fvar ?x)) |- _] =>
      match goal with
        | [H : ~ In y (FV_t (trm_fvar y)) |- _] =>
          simpl in H; contradict H; auto
      end
    | [H : ~ (?y = ?x \/ False) |- _] =>
      match goal with
        | [H : ~ (?y = ?x \/ False) |- _] =>
          contradict H; auto
      end
    | [ _ : ~ In ?n (_ :: _) |- _] =>
      match goal with
        | [ H : ~ In n (n :: _) |- _] =>
          contradict H; auto using in_eq
        | [ H : ~ In n (_ :: n :: _) |- _] =>
          destruct_nin; names_contra
      end
  end.

(* Tries to apply one of the previous four tactics. *)
Ltac smash_contra' := smash_trm_typ_contra || smash_var_contra || nat_contra || names_contra.
Ltac smash_contra := (try clear_trivial_eqs); try repeat smash_contra'.

Ltac apply_ccn :=
  match goal with
    | [ |- context [nat_compare ?n ?n'] ] =>
      clarify_compares_natc; simpl; try apply_ccn
  end; auto; try ((subst; smash_contra) || smash_contra).

Lemma open_eq_fvar : forall t n x,
  open_t n (trm_fvar x) t = trm_fvar x ->
  t = trm_bvar n \/ t = trm_fvar x.
Proof.
  induction t; intros; simpl; auto; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; subst; auto; smash_trm_typ_contra.
Qed.

Lemma open_eq_bvar : forall t n n' x,
  open_t n (trm_fvar x) t = trm_bvar n' -> t = trm_bvar n'.
Proof.
  induction t; intros; simpl; auto; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; subst; auto; smash_trm_typ_contra.
Qed.
Hint Resolve eq_sym open_eq_fvar open_eq_bvar : naming_open.

Lemma open_eq_helper : forall t t' x L A n,
    ~ In x (L ++ FV_t t ++ FV_t t') ->
    (forall x n, ~ In x (L ++ FV_t t ++ FV_t t') -> open_t n (trm_fvar x) t = open_t n (trm_fvar x) t' -> t = t') ->
    open_t n (trm_fvar x) (trm_lam A t) = open_t n (trm_fvar x) (trm_lam A t') ->
    (trm_lam A t) = (trm_lam A t').
Proof.
  intros; simpl. apply trm_lam_eq; split; auto.
  apply H0 with (x:=x) (n:=S n); eauto.
  simpl in H1. apply trm_lam_eq in H1. destruct H1. auto.
Qed.

Lemma open_eq : forall t t' x L n,
  ~ In x (L ++ FV_t t ++ FV_t t') ->
  open_t n (trm_fvar x) t = open_t n (trm_fvar x) t' ->
  t = t'.
Proof.
  induction t; intros. simpl in H0. clarify_compares_natc; subst.

  apply eq_sym in H0; apply open_eq_fvar in H0. destruct H0; eauto. subst.
  simpl in H. contradict H. eauto.

  eauto with naming_open.
  eauto with naming_open.

  simpl in H0.
  destruct t'; simpl in *; auto; try smash_trm_typ_contra.
  clarify_compares_natc; try smash_trm_typ_contra.
  invert_typing H0. contradict H; eauto.

  destruct t'; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; smash_trm_typ_contra.
  apply trm_lam_eq in H0. destruct H0; subst.
  apply open_eq_helper with (x:=x) (L:=L) (n:=n); eauto.
  simpl. apply trm_lam_eq; auto.

  destruct t'; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; smash_trm_typ_contra.
  rewrite -> trm_Lam_eq in H0.
  apply trm_Lam_eq. apply IHt with (x:=x) (L:=L) (n:=n); auto.

  simpl in H0.

  assert(t' = trm_app t1 t2).
  (* Proof of assert. *)
  destruct t'; intros; simpl in *; try smash_trm_typ_contra.

  clarify_compares_natc; smash_trm_typ_contra.

  invert_typing H0.
  rewrite -> IHt1 with (t':=t'1) (x:=x) (L:=L) (n:=n); auto.
  rewrite -> IHt2 with (t':=t'2) (x:=x) (L:=L) (n:=n); auto.
  apply el_nin_conj in H. destruct H.
  apply el_nin_conj in H1. destruct H1.
  apply el_nin_conj in H1. destruct H1.
  apply el_nin_conj in H4. destruct H4. eauto.
  apply el_nin_conj in H. destruct H.
  apply el_nin_conj in H1. destruct H1.
  apply el_nin_conj in H1. destruct H1.
  apply el_nin_conj in H4. destruct H4. eauto.
  (* End proof of assert. *)
  subst. auto.

  destruct t'; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; smash_trm_typ_contra.
  invert_typing H0. clear H0.
  rewrite -> IHt with (x:=x) (n:=n) (L:=L) (t':=t'); auto.

  simpl in H0. destruct t'; simpl in *; auto; try smash_trm_typ_contra.
  clarify_compares_natc; smash_trm_typ_contra.
Qed.

Lemma trm_lam_eq_lc : forall t t' A L,
  (forall y, ~ In y L -> open_t 0 (trm_fvar y) t = open_t 0 (trm_fvar y) t') ->
  trm_lam A t = trm_lam A t'.
Proof.
  intros. apply trm_lam_eq; split; auto.
  apply open_eq with (x:=pick_fresh (L++FV_t t++FV_t t')) (L:=L) (n:=0); eauto.
Qed.

Lemma el_nin_neq : forall L1 L2 (y x:nat),
  ~ In y (L1 ++ x::L2) -> y <> x.
Proof.
  intros. unfold not; intros; subst. contradict H; eauto.
Qed.
Hint Resolve el_nin_neq : naming_el.

Ltac auto_simp := simpl ; auto.
Lemma close_open_id : forall t n x,
  lc t ->
  open_t n (trm_fvar x) (close_t n x t) = t.
Proof.
  intros t0 n0 x0 H.
  generalize n0 x0. clear - H.
  induction H; intros; auto_simp.

  clarify_compares_natc; auto_simp.
  rewrite -> nat_compare_eq_eq; auto.

  apply trm_lam_eq_lc with (L:=L++(x0::nil)).
  intros. apply_hyp (H1 y (el_nin_app_head _ _ _ H2) (S n0) x0) H0a.
  rewrite -> close_open_comm in H0a; auto with arith.
  rewrite -> close_id in H0a.
  rewrite -> open_comm in H0a. auto. auto with arith.

  eauto with naming_el.
  simpl. unfold not; intros.  destruct H3; subst; eauto.
  simpl. unfold not; intros.  destruct H3; subst; eauto.

  apply trm_Lam_eq. auto.

  rewrite -> IHlc1. rewrite -> IHlc2. auto.
  rewrite -> IHlc. auto.
Qed.

Lemma el_nin_fv_close : forall t x y n,
  ~ In y (x::FV_t t) ->
  ~ In y (FV_t (close_t n x t)).
Proof.
  induction t; intros; simpl; auto.

  clarify_compares_natc; eauto.

  apply el_nin_conj_2. split.
  apply IHt1; simpl FV_t in H. destruct_nin.
  rewrite -> list_cons_eq_app. apply el_nin_conj_2. split; auto.
  apply IHt2; simpl FV_t in H. destruct_nin.
  rewrite -> list_cons_eq_app. apply el_nin_conj_2. split; auto.
Qed.

Lemma open_app : forall t' t1 t2 z n,
  open_t n (trm_fvar z) (trm_app t1 t2) = t' ->
  t' = trm_app (open_t n (trm_fvar z) t1) (open_t n (trm_fvar z) t2).
Proof.
  eauto.
Qed.

Lemma open_neq_fvar : forall t n x y,
  x <> y ->
  open_t n (trm_fvar x) t = trm_fvar y ->
  t = trm_fvar y.
Proof.
  induction t; intros; simpl; auto; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; subst; auto; smash_trm_typ_contra.
  inversion H0. contradict H2; auto.
Qed.

Lemma open_eq_fvar' : forall t n x y,
  open_t n (trm_fvar x) t = trm_fvar y ->
  t = trm_bvar n \/ t = trm_fvar y.
Proof.
  induction t; intros; simpl; auto; simpl in *; try smash_trm_typ_contra.
  clarify_compares_natc; subst; auto; smash_trm_typ_contra.
Qed.

Lemma lc_open_id : forall t,
  lc t ->
  forall n x, lc (open_t n (trm_fvar x) t).
Proof.
  induction 1; intros; simpl; auto.

  apply lc_lam with (L:=x::L++(FV_t t)); auto; intros.
  rewrite -> open_comm; try auto with arith. apply H1; auto.
  destruct_nin; auto.
  destruct_nin. unfold not; intros; subst. contradict H1; auto using in_eq.
Qed.

Lemma el_nin_fv_open_fvar : forall t' z y,
  ~ In y (z :: nil) ->
  ~ In y (FV_t t')  ->
  ~ In y (FV_t (open_t 0 (trm_fvar z) t')).
Proof.
  intros t'; generalize t' 0. clear t'.
  induction t'; intros; simpl.

  clarify_compares_natc; subst; auto.
  intuition auto.
  subst. apply H0. simpl. auto.
  simpl in H0. intuition eauto.
  simpl in H0. intuition eauto.

  simpl in H0. destruct_nin. eauto.
  simpl in H0. eauto.
  auto.
Qed.
Hint Resolve el_nin_fv_open_fvar.

Lemma trm_fvar_eq : forall x y,
  x = y -> trm_fvar x = trm_fvar y.
Proof.
  auto.
Qed.
Hint Resolve trm_fvar_eq.

Lemma trm_fvar_eq' : forall x y,
  trm_fvar x = trm_fvar y -> x = y.
Proof.
  intros; invert_typing H; auto.
Qed.
Hint Resolve trm_fvar_eq.

Lemma trm_fvar_neq : forall x y,
  x <> y -> trm_fvar x <> trm_fvar y.
Proof.
  unfold not; intros.

  apply trm_fvar_eq' in H0. auto.
Qed.
Hint Resolve trm_fvar_neq.

Lemma name_pick_fresh : forall x L L', x <> pick_fresh (L++x::L').
Proof.
  destruct L; intros; simpl.
  omega.
  rewrite -> pick_fresh_app; simpl; omega.
Qed.
Hint Resolve name_pick_fresh.

Lemma open_close_id : forall (t : trm) (n x : nat),
  ~ In x (FV_t t) ->
  close_t n x (open_t n (trm_fvar x) t) = t.
Proof.
  induction t; intros; simpl in *; auto.

  clarify_compares_natc; auto. subst.
  simpl. rewrite -> nat_compare_eq_eq; auto.
  clarify_compares_natc; subst; auto. contradict H; auto.

  rewrite -> IHt; auto.
  rewrite -> IHt; auto.

  destruct_nin.
  rewrite -> IHt1; auto.
  rewrite -> IHt2; auto.

  rewrite -> IHt; auto.
Qed.

Lemma open_eq_lam : forall t t' n x T,
  open_t n (trm_fvar x) t = trm_lam T t' ->
  exists t'', t = trm_lam T t''.
Proof.
  induction t; intros; simpl in *; try smash_trm_typ_contra.

  clarify_compares_natc; simpl in *; try smash_trm_typ_contra.

  invert_typing H. exists t; auto.
Qed.

Lemma open_eq_lam_fv : forall t t' n x T,
  ~ In x (FV_t t) ->
  open_t n (trm_fvar x) t = trm_lam T t' ->
  exists t'', t = trm_lam T t'' /\ t'' = close_t (S n) x t'.
Proof.
  induction t; intros; simpl in *; try smash_trm_typ_contra.

  clarify_compares_natc; simpl in *; try smash_trm_typ_contra.

  copy_hyp H0 H0'. inversion H0. rewrite <- H2 in *. clear H2.

  rewrite -> open_close_id. exists t; split; auto. exact H.
Qed.

Lemma open_eq_app : forall t t1 t2 n x,
  open_t n (trm_fvar x) t = trm_app t1 t2 ->
  exists t1', exists t2', t = trm_app t1' t2'.
Proof.
  induction t; intros; simpl in *; try smash_trm_typ_contra.

  clarify_compares_natc; simpl in *; try smash_trm_typ_contra.

  exists t1. exists t2; auto.
Qed.

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  open_t j v t = open_t i u (open_t j v t) ->
  open_t i u t = t.
Proof.
  induction t; intros; simpl in *; auto.

  repeat clarify_compares_natc; auto.
  rewrite -> Heqc0 in *. contradict H; auto. subst.
  simpl in H0. rewrite -> nat_compare_eq_eq in H0; auto.
  subst. simpl in H0. rewrite -> nat_compare_eq_eq in H0; auto.

  rewrite -> IHt with (j:=S j) (v:=v); auto.
  apply trm_lam_eq in H0. destruct H0. auto.

  apply trm_Lam_eq. apply IHt with (j:=j) (v := v); auto.
  apply trm_Lam_eq; auto.

  invert_typing H0.
  rewrite -> IHt1 with (j:=j) (v:=v); auto.
  rewrite -> IHt2 with (j:=j) (v:=v); auto.

  invert_typing H0.
  rewrite -> IHt with (j:=j) (v:=v); auto.
Qed.
Hint Resolve open_rec_term_core.

Lemma open_id : forall t t',
  lc t -> (forall n, open_t n t' t = t).
Proof.
  induction 1; intros; simpl; auto.

  apply f_equal.
  eapply (open_rec_term_core t 0 (trm_fvar (pick_fresh L))); eauto.
  apply eq_sym. apply H1; eauto.

  apply f_equal. auto.
  rewrite -> IHlc1. rewrite -> IHlc2. auto.

  rewrite -> IHlc; auto.
Qed.
Hint Resolve open_id : naming_open.

Lemma open_comm' : forall t t' x n m,
  lc t' ->
  n <> m ->
  ~ In x (FV_t t') ->
  open_t n (trm_fvar x) (open_t m t' t) =
  open_t m t' (open_t n (trm_fvar x) t).
Proof.
  induction t; intros.

  simpl. case_split_names n m. apply neq_lt_or_gt in H0. destruct H0.
  rewrite -> nat_compare_gt_gt; auto. simpl. rewrite -> nat_compare_eq_eq.
  apply open_id; auto.
  rewrite -> nat_compare_lt_lt; auto. simpl. rewrite -> nat_compare_eq_eq.
  apply open_id; auto.

  case_split_names n n0. simpl. rewrite -> nat_compare_eq_eq; auto.
  simpl. repeat rewrite -> nat_compare_lt_lt; auto.
  simpl. rewrite -> nat_compare_gt_gt with (n:=n0); auto.
  rewrite -> nat_compare_lt_lt; auto.

  case_split_names n n0. simpl. rewrite -> nat_compare_eq_eq; auto.
  simpl. rewrite -> nat_compare_lt_lt with (n:=n0); auto.
  rewrite -> nat_compare_gt_gt; auto.
  simpl. repeat rewrite -> nat_compare_gt_gt; auto.

  simpl; auto.

  simpl in *. rewrite -> IHt; auto.
  simpl in *. rewrite -> IHt; auto.

  simpl.
  rewrite -> IHt1; auto.
  rewrite -> IHt2; auto.

  simpl. rewrite -> IHt; auto.
  simpl; auto.
Qed.

Lemma open_eq_trmc : forall t n x,
  open_t n (trm_fvar x) t = trm_c
  -> t = trm_c.
Proof.
  destruct t; intros; simpl in *; try clarify_compares_natc;
    try smash_trm_typ_contra; auto.
Qed.

Lemma close_comm : forall t,
  forall x y n m,
    x <> y ->
    n <> m ->
    close_t n x (close_t m y t) = close_t m y (close_t n x t).
Proof.
  induction t; intros; simpl in *; auto.

  case_split_names n y. apply neq_lt_or_gt in H. destruct H.
  rewrite -> nat_compare_gt_gt; auto. simpl. rewrite -> nat_compare_eq_eq; auto.
  rewrite -> nat_compare_lt_lt; auto. simpl. rewrite -> nat_compare_eq_eq; auto.

  simpl. case_split_names n x. simpl; auto.
  simpl. rewrite -> nat_compare_lt_lt; auto.
  simpl. rewrite -> nat_compare_lt_lt; auto.

  simpl. case_split_names n x. simpl; auto.
  simpl. rewrite -> nat_compare_gt_gt; auto.
  simpl. rewrite -> nat_compare_gt_gt; auto.

  rewrite -> IHt; auto.
  rewrite -> IHt; auto.

  rewrite -> IHt1; auto.
  rewrite -> IHt2; auto.

  rewrite -> IHt; auto.
Qed.
Hint Rewrite close_comm : base0.