Require Import List Logic Nat Omega FunctionalExtensionality ExtensionalityFacts ChoiceFacts Wellfounded Classical.
Require Import Compare_dec EqNat Decidable ListDec FinFun.
Require Fin.
Import ListNotations.
From Block
Require Import finite lib definitions ramsey.

(* ********************* *)
(* **** Finite-hood **** *)
(* ********************* *)

(* Words up to length n are finite *)
Lemma wordlength_finite : forall (n : nat),
    is_finite (fun (w : word) => length w <= n).
Proof.
  unfold is_finite.
  induction n as [|n IHn].
  + (* When length is zero, finite because no words exist *)
    exists [[]; []]. intro w; split.
    (* Left direction *)
    ++ intro H_absurd; inversion H_absurd.
       rewrite <- H; reflexivity.
       inversion H.
       rewrite <- H0; reflexivity. inversion H0.
    (* Right direction *)
    ++ intro H_length; inversion H_length.
       rewrite length_zero_iff_nil in H0.
       rewrite H0. constructor. reflexivity.
  + (* When the length is n, finite because adding an extra symbol
       onto all words in a finite list of words keeps the list finite *)
    destruct IHn as [L IHn].
    exists (map (fun w => aa :: w) L ++
           map (fun w => bb :: w) L ++
           map (fun w => cc :: w) L ++ L).
    intro w; split; intros H.
    (* Left direction *)
    ++ repeat rewrite in_app_iff in H;
         repeat rewrite in_map_iff in H.
       destruct H as [[h [H_h H_mem]] |
                      [[h [H_h H_mem]] |
                       [[h [H_h H_mem]] | ?]]].
       (* When the word is in appended original list *)
       +++ spec IHn h.
           rewrite <- H_h.
           apply IHn in H_mem.
           rewrite unfold_length_S.
           apply (le_n_S (length h) n); exact H_mem.
       +++ spec IHn h.
           rewrite <- H_h.
           apply IHn in H_mem.
           rewrite unfold_length_S.
           apply (le_n_S (length h) n); exact H_mem.
       +++ spec IHn h.
           rewrite <- H_h.
           apply IHn in H_mem.
           rewrite unfold_length_S.
           apply (le_n_S (length h) n); exact H_mem.
       (* When the word is in the original list *)
       +++ constructor.
           spec IHn w.
           apply IHn in H.
           exact H.
    (* Right direction *)
    ++ repeat rewrite in_app_iff; repeat rewrite in_map_iff.
       apply le_lt_or_eq in H.
       destruct H as [H_lt | H_eq].
       +++ spec IHn w.
           apply lt_n_Sm_le in H_lt.
           apply IHn in H_lt.
           right; right; right; exact H_lt.
       +++ destruct w.
           inversion H_eq.
           spec IHn w.
           rewrite unfold_length_S in H_eq.
           apply Nat.succ_inj in H_eq.
           rewrite H_eq in IHn.
           assert (n <= n) by omega.
           apply IHn in H.
           destruct t.
           left; exists w.
           split; try reflexivity; assumption.
           right; left; exists w; split; try reflexivity; assumption.
           right; right; left; exists w; split; try reflexivity; assumption.
Qed.

Definition grow_lang (L : language) (new : word) : language :=
  fun w => L w \/ w = new.

(* Languages containing words in some finite set of words are finite *)
Lemma shortlang_finite : forall (LW : list word),
    is_finite (fun L : word -> Prop => forall w : word, L w -> In w LW).
Proof.
  intros LW.
  induction LW as [|hd tl IHl].
  (* When the list of words is empty, the language is empty *)
  + exists ((fun w : word => False) :: nil).
    intro L; split.
    ++ intros H w H_mem.
       inversion H.
       rewrite <- H0 in H_mem.
       contradiction.
       inversion H0.
    ++ intro H.
       unfold In.
       left. apply functional_extensionality.
       intro abword.
       apply prop_ext. split.
       intro false; inversion false.
       intro Habsurd; spec H abword; apply H in Habsurd.
       inversion Habsurd.
  (* When the list of words is non-empty, *)
  + destruct IHl as [LS IHl].
    (* LS is a list of languages containing only words in tl *)
    (* Now I need to construct a list of languages containing words in hd :: tl *)
    unfold is_finite.
    exists (LS ++ (map (fun L => grow_lang L hd) LS)).

    intros lang; split; intros.
    simpl.
    apply in_app_or in H.
    destruct H.
    right.
    (* *)
    spec IHl lang. destruct IHl. spec H1 H. apply H1. exact H0.
    case_eq (word_eq hd w); intro.
    left. rewrite word_eq_refl in H1. assumption. right.
    rewrite in_map_iff in H.
    destruct H as [lang' [? ?]].
    spec IHl lang'.
    rewrite IHl in H2. apply H2. unfold grow_lang in H.
    subst lang. destruct H0. assumption.
    rewrite word_eq_refl' in H1. symmetry in H; contradiction.
    apply in_or_app.
    destruct (classic (lang hd)).
    right.
    rewrite in_map_iff.
    set (lang' := fun w => lang w /\ w <> hd).
    exists lang'.
    split.
    unfold grow_lang, lang'.
    apply functional_extensionality. intro w. apply prop_ext; split; intro.
    destruct H1. tauto. rewrite H1. apply H0.
    case_eq (word_eq w hd); intro.
    right. rewrite word_eq_refl in H2. assumption.
    rewrite word_eq_refl' in H2. tauto.
    rewrite IHl.
    intros.
    spec H w.
    unfold lang' in H1. destruct H1.
    spec H H1. destruct H; auto.
    symmetry in H. contradiction.
    left.
    apply IHl.
    intros.
    spec H w H1. destruct H. 2 : auto. subst hd. contradiction.
Qed.

(* ******************* *)
(* **** Factories **** *)
(* ******************* *)

(* A function which takes a language and returns a language
   which only accepts the short strings from that language *)
(* Wrong version had an extra universal quantifier *)
Definition filter_shortlang (n : nat) : language -> language :=
  fun L : language => (fun w : word => L w /\ length w <= n).

(* Sanity check for filter_shortlang *)
Lemma filter_shortlang_sane :
  forall n1 n2,
    n1 < n2 ->
    forall (L : language) (w : word),
      filter_shortlang n1 L w -> filter_shortlang n2 L w.
Proof.
  intros n1 n2 H_lt L w H_in_longer.
  unfold filter_shortlang in *.
  destruct H_in_longer; split; try assumption.
  omega.
Qed.

(* ************************* *)
(* **** Proving two-ish **** *)
(* ************************* *)

Definition is_cancellable (L : language) (w : word) :=
  fun i j => L (firstn i w ++ skipn j w).

Lemma twoish_two : forall k : block_pumping_constant,
    exists rk : block_pumping_constant,
      forall L1 L2 : language,
        block_cancellable_matching_with k L1 ->
        block_cancellable_matching_with k L2 ->
        (forall w, length w <= rk ->
              L1 w <-> L2 w) ->
        forall w, L1 w <-> L2 w.
Proof.
  intros k.
  assert (H_ramsey := Theorem_of_Ramsey_duo_prop k).
  destruct H_ramsey as [rk [H_lt H_ramsey]].
  exists rk.
  intros L1 L2 H_L H_L' H_length w.
  (** Setting the strong induction on word length **)
  remember (length w) as n.
  assert (H_move := Nat.eq_refl (length w)).
  rewrite <- Heqn in H_move at 2. clear Heqn.
  generalize dependent w.
  induction n as [|n IHn] using strong_induction; intros w H_w_length.
  - (* In the trivial base case *)
    spec H_length w.
    assert (0 <= rk) by omega.
    rewrite H_w_length in H_length; spec H_length H; assumption.
  - (* In the inductive case, with all shorter words satisfying P *)
    assert (n < rk \/ n >= rk) by omega.
    destruct H as [H_short | H_long].
    + (* In the case that the words are shorter than rk, trivial *)
      assert (length w <= rk) by omega.
      spec H_length w H; assumption.
    + (* In the case that the words are longer than rk, but all shorter words satisfy *)
      (** Constructing a (breakpoint_set rk w d) which enumerates all the slots *)
      remember (iota 1 rk) as bp_list.
      assert (bp_list_pred : breakpoint_set_predicate bp_list w rk).
      rewrite Heqbp_list.
      { unfold breakpoint_set_predicate; split.
        rewrite length_iota; reflexivity.
        split.
        apply (iota_increasing 1 rk definitions.d).
        assert (H_useful := last_indep (iota 1 rk)).
        destruct H_useful as [H_absurd | H_useful].
        destruct H_absurd as [H_absurd _].
        subst bp_list.
        assert (rk >= 1).
        { destruct k as [k about_k]; unfold p_predicate in about_k.
          simpl in H_lt; omega. }
        assert (length (iota 1 rk) = rk) by apply length_iota.
        rewrite H_absurd in H0.
        unfold length in H0; omega.
        destruct H_useful as [H_non_nil H_useful].
        spec H_useful definitions.d 0.
        rewrite H_useful.
        rewrite iota_last. omega. }
      (* Explicitly tell Coq the sigma-type here - must remember! *)
      spec H_ramsey w (exist _ bp_list bp_list_pred : breakpoint_set rk w).
      (** Trying Ramsey's Theorem with two colors **)
      spec H_ramsey (is_cancellable L1 w).
      (* Setting up the context variables for the case analysis *)
      destruct H_ramsey as [bps' H_ramsey].
      simpl in * (* Bookkeeping to refold the sigma-types *).
      assert (IHn' := IHn).
      spec H_L w bps'; spec H_L' w bps';
      destruct H_L as [bp1 [bp2 [H_bp_lt H_L]]];
      assert (H_bc1 : length (firstn bp1 w ++ skipn bp2 w) < length w).
      apply about_pump_length; assumption.
      spec IHn (length (firstn bp1 w ++ skipn bp2 w));
      rewrite <- H_w_length in IHn; spec IHn H_bc1;
      spec IHn (firstn bp1 w ++ skipn bp2 w)
           (eq_refl (length (firstn bp1 w ++ skipn bp2 w))).
      destruct H_L' as [bp1' [bp2' [H_bp'_lt H_L']]];
      assert (H_bc2 : length (firstn bp1' w ++ skipn bp2' w) < length w).
      apply about_pump_length; assumption.
      spec IHn' (length (firstn bp1' w ++ skipn bp2' w));
      rewrite <- H_w_length in IHn'; spec IHn' H_bc2;
      spec IHn' (firstn bp1' w ++ skipn bp2' w)
           (eq_refl (length (firstn bp1' w ++ skipn bp2' w))).
      clear -H_ramsey H_bp_lt H_bp'_lt H_L H_L' IHn IHn' H_bp_lt.
      (* Case analysis on additional information about breakpoints *)
      destruct H_ramsey as [H_sublist [case1 | case0]].
      ++ (* Ramsey cancels word into L1 *)
        (* L2's breakpoints also work for L1 *)
        split; intro H.
        spec case1 bp1' bp2' H_bp'_lt;
          unfold is_cancellable in case1; tauto.
        spec case1 bp1 bp2 H_bp_lt;
          unfold is_cancellable in case1; tauto.
      ++ (* Ramsey cancels word into L2 *)
        (* L1's breakpoints work for itself *)
        split; intro H.
         spec case0 bp1 bp2 H_bp_lt;
          unfold is_cancellable in case0; tauto.
        spec case0 bp1' bp2' H_bp'_lt;
          unfold is_cancellable in case0; tauto.
Qed.

(* ***************** *)
(* **** Lemma 2 **** *)
(* ***************** *)

(* inj_finite
     : forall (P : X -> Prop) (Q : Y -> Prop)
         (f : {x : X | P x} -> {y : Y | Q y}),
       inhabited {x : X | P x} ->
       injective P Q f ->
       is_finite_dep Q ->
       is_finite_dep P *)

(* We require the following building blocks for our grand finale:
   X : {l | BC(k,l)}
   Y : {l | short_lang l}
   P : BC(k)
   Q : short
   f : dependent length shearing function
   injective f
   is_finite Q
   inhabited X
 *)

(*****)
(* P *)
(*****)

(* This line causes Coq universe inconsistency!
Coercion bc_language_proj1 : bc_language >-> language. *)

(***************)
(* inhabited X *)
(***************)
Lemma inhabited_bc : forall k : block_pumping_constant, inhabited (bc_language k).
Proof.
  intros k.
  (* Constructing an absurd language that can still have breakpoints *)
  remember ((fun w => False) : language) as absurd.
  assert (bc_sigma k absurd).
  { unfold bc_sigma. intros w bps.
    exists (get_bp1_from_bps bps).
    exists (get_bp2_from_bps bps).
    split.
    unfold get_bp1_from_bps, get_bp2_from_bps.
    simpl.
    destruct bps as [x about_bps].
    (* Destruction/inversion until I reveal two elements *)
    destruct x as [_ | x].
    { unfold breakpoint_set_predicate in about_bps.
      destruct k as [k about_k]; unfold p_predicate in about_k.
      destruct about_bps as [H_length H_incr H_last].
      simpl in H_length. omega. }
    destruct x0 as [_ | x0].
    { unfold breakpoint_set_predicate in about_bps.
      destruct k as [k about_k]; unfold p_predicate in about_k.
      destruct about_bps as [H_length H_incr H_last].
      simpl in H_length. omega. }
    simpl.
    unfold breakpoint_set_predicate in about_bps.
    destruct about_bps as [H_length [H_incr H_last]].
    unfold increasing in H_incr.
    spec H_incr 0 1.
    assert (0 < 1 < length (x::x0::x1)). simpl; omega.
    spec H_incr H.
    unfold nth in H_incr. assumption.
    split; intro H_absurd_mem;
      subst absurd; contradiction. }
  (* Finally we have our witness *)
  constructor. exists absurd. assumption.
Qed.

(*****) (*****)
(* Y *) (* Q *)
(*****) (*****)
Definition is_short_lang (n : nat) (L: language) : Prop :=
  forall w : word, L w -> length w <= n.

Definition short_lang (n : nat) : Type :=
  { l | is_short_lang n l}.

Definition short_lang_proj1 {n : nat} (sl : short_lang n) :=
  match sl with
  | exist _ b _ => b
  end.

(*****)
(* f *)
(*****)
Program Definition filter_shortbclang (k : block_pumping_constant) (rk : block_pumping_constant) :=
  fun bcl : {l | bc_sigma k l} => exist (is_short_lang rk)
                                     (filter_shortlang rk (bc_language_proj1 bcl))
                                     _.
Next Obligation.
  unfold is_short_lang, filter_shortlang;
    intros; unfold bc_language_proj1;
      destruct H0; assumption.
Defined.
(* filter_shortbclang
     : forall k rk : nat,
       {l : language | bc_sigma k l} -> {x : language | short_lang rk x} *)

(***************)
(* injective f *)
(***************)
(** This is the real statement of injectivity we want! **)
(** Significantly, the precise way rk is dependent is super important **)
Lemma twoish_sigma : forall k : block_pumping_constant,
    exists rk : block_pumping_constant,
      forall BCL1 BCL2 : bc_language k,
        block_cancellable_matching_with k (proj1_sig BCL1) ->
        block_cancellable_matching_with k (proj1_sig BCL2) ->
        (forall w, length w <= rk ->
              (proj1_sig BCL1 w <-> proj1_sig BCL2 w)) ->
        forall w, proj1_sig BCL1 w <-> proj1_sig BCL2 w.
Proof.
  intro k.
  assert (H_useful := twoish_two k).
  destruct H_useful as [rk H_useful].
  exists rk.
  intros BCL1 BCL2.
  destruct BCL1 as [L1 about_L1];
    destruct BCL2 as [L2 about_L2].
  spec H_useful L1 L2.
  spec H_useful about_L1 about_L2.
  simpl in *.
  intros _ _ H w.
  spec H_useful H.
  exact (H_useful w).
Qed.

Theorem real_injectivity :
  forall (k : block_pumping_constant),
  exists rk : block_pumping_constant,
    injective (block_cancellable_matching_with k)
              (is_short_lang rk)
              (filter_shortbclang k rk).
Proof.
  intros k.
  assert (H_twoish := twoish_sigma k).
  (* Using the sigma version doesn't prevent us from being destructive *)
  destruct H_twoish as [rk H_twoish].
  exists rk.
  unfold injective, Injective.
  intros bcx bcy H_length.
  spec H_twoish bcx bcy.
  (* However, in order to use our equality lemma we must destruct *)
  destruct bcx as [l1 about_l1];
    destruct bcy as [l2 about_l2].
  spec H_twoish about_l1 about_l2.
  (* Two dependent languages are equal iff the languages are equal *)
  apply language_equality_sigma.
  simpl in *.
  (* Two languages are equal iff forall words, they agree *)
  apply language_equality.
  (* Now we have the exact conclusion of H_twoish *)
  assert (H_next : forall w : word, length w <= rk -> l1 w <-> l2 w).
  { (* This needs to be proven using H_length *)
    (* What does it mean for languages to be equal? *)
    intros w w_length.
    apply language_equality_sigma in H_length.
    unfold bc_language_proj1 in H_length.
    rewrite (language_equality (filter_shortlang rk l1)
                               (filter_shortlang rk l2)) in H_length.
    unfold filter_shortlang in H_length.
    spec H_length w.
    destruct H_length.
    split; intros.
    assert (H_away : l1 w /\ length w <= rk). split; assumption.
    spec H H_away; destruct H; assumption.
    assert (H_away : l2 w /\ length w <= rk). split; assumption.
    spec H0 H_away; destruct H0; assumption. }
  apply (H_twoish H_next).
Qed.

(************)
(* finite Q *)
(************)
Lemma is_finite_sheared : forall n : nat,
    is_finite (is_short_lang n).
Proof.
  intro n.
  destruct (wordlength_finite n) as [ws about_ws].
  destruct (shortlang_finite ws) as [ls about_ls].
  exists ls.
  intro l; split.
  intros H_l_mem w H_mem.
  apply (about_ws w).
  spec about_ls l.
  destruct about_ls.
  apply (H H_l_mem w); assumption.
  intro H.
  spec about_ls l. destruct about_ls.
  apply H1. intros w H_l_mem.
  spec H w. spec H H_l_mem.
  spec about_ws w. destruct about_ws.
  apply H3; assumption.
Qed.

(* Enter magical finite library! *)
Lemma is_finite_sheared_dep : forall n : nat,
    is_finite_dep (is_short_lang n).
Proof.
  intro n.
  assert (H_useful := is_finite_sheared n).
  apply list_to_dep_list in H_useful.
  assumption.
Qed.

(*****************)
(* Grand finale! *)
(*****************)
Theorem bc_k_is_finite_dep :
  forall k : block_pumping_constant, is_finite_dep (bc_sigma k).
Proof.
  intro k.
  assert (H_real := real_injectivity k).
  destruct H_real as [rk H_real].
  generalize (is_finite_sheared_dep rk).
  eapply (inj_finite
            (bc_sigma k) (is_short_lang rk) (filter_shortbclang k rk)).
  apply inhabited_bc.
  exact H_real.
Qed.

Theorem bc_k_is_finite :
  forall k : block_pumping_constant, is_finite (bc_sigma k).
Proof.
  intro k.
  apply (is_finite_equiv (bc_sigma k)).
  exact (bc_k_is_finite_dep k).
Qed.

Print Assumptions bc_k_is_finite.


Require Import Bool.
Require Import EqNat.
Require Import Setoid.
Require Import Le Lt Plus Minus Compare_dec.

(*****************************************************************)
(*Compare nat returning boolean*)
(*****************************************************************)

(*****************************************************************)
(*beq_nat*)
Lemma beq_nat_sym : forall m n, beq_nat m n = beq_nat n m.
intros m n.
case_eq (beq_nat m n); intros.
 rewrite beq_nat_true_iff in H; subst m;
   rewrite (beq_nat_refl n); trivial.

 rewrite beq_nat_false_iff in H.
 case_eq (beq_nat n m); intros; trivial.
  rewrite beq_nat_true_iff in H0.
  elim H; subst n; trivial.
Qed.

(****************************************************************)
(*ltb*)
Definition ltb n m := leb (S n) m.

Lemma ltb_iff : forall m n,
  ltb m n = true <-> m < n.
unfold ltb; intros; rewrite leb_iff; split; trivial.
Qed.

Lemma ltb_eq_nat_dec : forall m n,
  {ltb m n = true} + {beq_nat m n = true} + {ltb n m = true}.
intros m n.
generalize (lt_eq_lt_dec m n); intros H.
destruct H as [[H|H]|H]; [left; left; rewrite ltb_iff|
  left; right; rewrite beq_nat_true_iff|
    right; rewrite ltb_iff]; trivial.
Qed.

Lemma ltb_leb_iff : forall m n b,
  ltb m n = b <-> leb n m = negb b.
intros m n b.
destruct b; simpl; [|unfold ltb]; rewrite leb_iff_conv;
  [rewrite ltb_iff; reflexivity|rewrite leb_iff].
 split; intros; [apply lt_n_Sm_le|
   apply le_lt_n_Sm]; trivial.
Qed.

Lemma ltb_antirefl : forall m, ltb m m = false.
unfold ltb; intro m.
rewrite leb_iff_conv.
apply lt_n_Sn.
Qed.

Lemma leb_ltb_beq_conv : forall m n,
  leb m n = ltb m n || beq_nat m n.
intros m n.
case_eq (leb m n); intro H.
 rewrite leb_iff in H.
 rewrite le_lt_or_eq_iff in H.
 destruct H as [H|H].
  rewrite <- ltb_iff in H; rewrite H; simpl; trivial.

  subst m; rewrite <- beq_nat_refl.
  rewrite orb_true_r; trivial.

 rewrite leb_iff_conv in H.
 case_eq (ltb m n); intros H'; [|clear H']; simpl.
  rewrite ltb_iff in H'; apply lt_asym in H; contradiction.

  case_eq (beq_nat m n); intros H'; trivial.
   rewrite beq_nat_true_iff in H'.
   subst m; apply lt_irrefl in H; contradiction.
Qed.

(*****************************************************************)
(*Cantor Normal Form Ordinals*)
(*****************************************************************)
Inductive Ord : Set :=
| fin : nat -> Ord
| inf : nat -> Ord -> Ord -> Ord.

Fixpoint degree (o : Ord) : Ord :=
  match o with
    | fin _ => fin 0
    | inf n p Q => p
  end.

Fixpoint scan (o : Ord) : bool :=
  match o with
    | fin 0 => false
    | fin (S _) => true
    | inf _ _ o' => scan o'
  end.

Definition ZeroO (o : Ord) : bool :=
  match o with
    | fin 0 => true
    | _ => false
  end.

Lemma ZeroO_fin0 : forall o, ZeroO o = true -> o = fin 0.
destruct o as [n|n p q]; simpl; intros; [
  destruct n; [trivial|discriminate]|discriminate].
Qed.

Definition SuccOFin (o : Ord) : bool :=
  match o with
    | fin (S _) => true
    | _ => false
  end.

Definition SuccOInf (o : Ord) :=
  match o with
    | inf _ _ _  => scan o
    | _ => false
  end.

Definition InfO (o : Ord) :=
  match o with
    | inf _ _ _ => negb (scan o)
    | _ => false
  end.

Definition SuccO (o : Ord) := SuccOInf o || SuccOFin o.

Lemma ord_classification : forall (o : Ord),
  {ZeroO o = true} + {SuccO o = true} + {InfO o = true}.
induction o as [n|n p _ q Hq]; simpl.
 destruct n; left; [left|right]; trivial.

 destruct Hq as [[HO|HS]|HI].
  apply ZeroO_fin0 in HO; subst q; right; simpl; trivial.

  left; right; unfold SuccO in HS |- *; simpl.
  destruct q; simpl in *; trivial.
   rewrite orb_false_r; trivial.

  destruct q as [m|m u v].
   destruct m; simpl in HI; discriminate.

   simpl in *; right; trivial.
Qed.

(*Equality of ordinals*)
Fixpoint beq_ord (o o' : Ord) : bool :=
  match o, o' with
    | fin m, fin n => beq_nat m n
    | inf n p Q, inf n' p' Q' =>
      (beq_nat n n') && (beq_ord p p') && (beq_ord Q Q')
    | _, _ => false
  end.

Lemma beq_ord_refl : forall o, beq_ord o o = true.
induction o; simpl; [|repeat rewrite andb_true_iff;
  split; [split|]]; trivial; rewrite beq_nat_true_iff; trivial.
Qed.

Lemma beq_ord_eq : forall o o',
  beq_ord o o' = true <-> o = o'.
split; [revert o'|].
 induction o as [|n p Hp Q HQ]; destruct o' as [|n' p' Q'];
   simpl; intros; [apply beq_nat_true in H; subst n; trivial|
     discriminate|discriminate|].
  repeat rewrite andb_true_iff in H.
  destruct H as ((Hnn', Hpp'), Hqq').
  apply Hp in Hpp'.
  apply HQ in Hqq'.
  apply beq_nat_true in Hnn'.
  subst n p Q; trivial.

 intros; subst o'.
 induction o; simpl; [rewrite beq_nat_true_iff; trivial|].
  repeat rewrite andb_true_iff.
  split; [split|]; trivial; rewrite beq_nat_true_iff; trivial.
Qed.

(*Order between ordinals*)
Fixpoint btb_ord (o o' : Ord) : bool :=
  match o, o' with
    | fin m, fin n => (ltb n m)
    | fin _, inf _ _ _  => false
    | inf _ _ _, fin _ => true
    | inf n p Q, inf n' p' Q' =>
      (btb_ord p p') || (beq_ord p p') && (ltb n' n) ||
        (beq_ord p p') && (beq_nat n n') && (btb_ord Q Q')
  end.

Definition beb_ord (o o' : Ord) := btb_ord o o' || beq_ord o o'.

Lemma btb_0 : forall o o',
  btb_ord o o' = true -> btb_ord o (fin 0) = true.
induction o as [|n p Hp Q HQ]; destruct o' as [|n' p' Q'];
  simpl; intros; [|discriminate| |]; trivial.
 rewrite ltb_iff in *.
 apply le_lt_trans with (1:=(le_0_n n0)) (2:=(H)).
Qed.

Lemma not_0_bt_0 : forall (o : Ord),
  ZeroO o = false ->
  btb_ord o (fin 0) = true.
destruct o as [n|n p q]; simpl; trivial.
 destruct n; [discriminate|intros _].
  rewrite ltb_iff.
  apply lt_0_Sn.
Qed.

Lemma btb_antirefl : forall o, btb_ord o o = false.
induction o; simpl.
 apply ltb_antirefl.

 rewrite IHo1; rewrite IHo2.
 rewrite ltb_antirefl.
 repeat rewrite andb_false_r; simpl; trivial.
Qed.

Lemma btb_ord_trans : forall o1 o2 o3,
  btb_ord o1 o2 = true ->
  btb_ord o2 o3 = true ->
  btb_ord o1 o3 = true.
induction o1 as [n1|n1 p1 Hp1 q1 Hq1];
  destruct o2 as [n2|n2 p2 q2]; destruct o3 as [n3|n3 p3 q3];
    simpl; intros H12 H23; try discriminate; trivial.
 rewrite ltb_iff in H12, H23 |- *.
 apply lt_trans with (1:=H23) (2:=H12).

 repeat rewrite orb_true_iff in H12, H23 |- *.
 destruct H12 as [[H12|H12]|H12].
  left; left; destruct H23 as [[H23|H23]|H23].
   apply Hp1 with (1:=H12) (2:=H23).

   rewrite andb_true_iff in H23; destruct H23 as (H23, _).
   rewrite beq_ord_eq in H23; subst p3; trivial.

   repeat rewrite andb_true_iff in H23.
   destruct H23 as ((H23, _), _).
   rewrite beq_ord_eq in H23; subst p3; trivial.

  rewrite andb_true_iff in H12; destruct H12 as (H12, H12').
  rewrite beq_ord_eq in H12; subst p2.
  destruct H23 as [[H23|H23]|H23];
    [left;left|left;right|left;right]; trivial;
      rewrite andb_true_iff in H23 |- *;
        [|rewrite andb_true_iff in H23; destruct H23 as (H23, _)];
        destruct H23 as (H23, H23');
          rewrite beq_ord_eq in H23; subst p3;
            rewrite beq_ord_eq; rewrite ltb_iff in H12' |- *.
   rewrite ltb_iff in H23'.
   split; [|apply lt_trans with (m:=n2)]; trivial.

   rewrite beq_nat_true_iff in H23'; subst n3.
   split; trivial.

  repeat rewrite andb_true_iff in H12.
  destruct H12 as ((H12_, H12'), H12).
  rewrite beq_ord_eq in H12_; subst p2.
  rewrite beq_nat_true_iff in H12'; subst n2.
  destruct H23 as [[H23|H23]|H23];
    [left;left|left;right|right]; trivial.
   repeat rewrite andb_true_iff in H23 |- *.
   destruct H23 as ((H23', H23_), H23).
   split; [split|apply Hq1 with (1:=H12)]; trivial.
Qed.

Lemma beb_btb_trans : forall o1 o2 o3,
  beb_ord o1 o2 = true ->
  btb_ord o2 o3 = true ->
  btb_ord o1 o3 = true.
intros o1 o2 o3 Ho12 Ho23.
unfold beb_ord in Ho12.
rewrite orb_true_iff in Ho12.
destruct Ho12 as [Hlt|Heq];
  [apply btb_ord_trans with (1:=Hlt) (2:=Ho23) |
  rewrite beq_ord_eq in Heq; subst o2; trivial].
Qed.

Lemma btb_beb_trans : forall o1 o2 o3,
  btb_ord o1 o2 = true ->
  beb_ord o2 o3 = true ->
  btb_ord o1 o3 = true.
intros o1 o2 o3 Ho12 Ho23.
unfold beb_ord in Ho23.
rewrite orb_true_iff in Ho23.
destruct Ho23 as [Hlt|Heq];
  [apply btb_ord_trans with (2:=Hlt) (1:=Ho12) |
  rewrite beq_ord_eq in Heq; subst o2; trivial].
Qed.

Lemma beb_trans : forall o1 o2 o3,
  beb_ord o1 o2 = true ->
  beb_ord o2 o3 = true ->
  beb_ord o1 o3 = true.
intros o1 o2 o3 Ho12 Ho23.
unfold beb_ord in Ho12.
rewrite orb_true_iff in Ho12.
destruct Ho12 as [Hlt1|Heq1]; [unfold beb_ord;
  apply btb_beb_trans with (1:=Hlt1) in Ho23; rewrite Ho23 |
    rewrite beq_ord_eq in Heq1; subst o2]; trivial.
Qed.

Lemma btb_eq_dec : forall o o',
  {btb_ord o o'=true} + {beq_ord o o'=true} + {btb_ord o' o=true}.
induction o as [n|n p Hp q Hq]; destruct o' as [n'|n' p' q'];
  simpl; [|right|left; left|]; trivial.
 generalize (lt_eq_lt_dec n n'); intro H.
 destruct H as [[H|H]|H]; [right; rewrite ltb_iff |
   left; right; rewrite beq_nat_true_iff |
     left; left; rewrite ltb_iff]; trivial.

 specialize Hp with (o':=p').
 specialize Hq with (o':=q').
 destruct Hp as [[Hp|Hp]|Hp]; [
   left; left; repeat rewrite orb_true_iff; left; left| |
     right; repeat rewrite orb_true_iff; left; left]; trivial.
  rewrite beq_ord_eq in Hp; subst p'.
  generalize (lt_eq_lt_dec n n'); intro H.
  destruct H as [[H|H]|H].
   right; repeat rewrite orb_true_iff; left; right.
   rewrite andb_true_iff; rewrite ltb_iff;
     split; [apply beq_ord_refl|]; trivial.

   subst n'; destruct Hq as [[Hq|Hq]|Hq].
    left; left; repeat rewrite orb_true_iff; right.
    repeat rewrite andb_true_iff; split; [split;
      [apply beq_ord_refl|rewrite beq_nat_true_iff]|]; trivial.

    rewrite beq_ord_eq in Hq; subst q'.
    left; right; repeat rewrite andb_true_iff;
      split; [split; [rewrite beq_nat_true_iff|apply beq_ord_refl]|
        apply beq_ord_refl]; trivial.

    right; repeat rewrite orb_true_iff; right.
    repeat rewrite andb_true_iff; split; [split;
      [apply beq_ord_refl|rewrite beq_nat_true_iff]|]; trivial.

   left; left; repeat rewrite orb_true_iff.
   left; right; rewrite andb_true_iff.
   split; [apply beq_ord_refl|rewrite ltb_iff]; trivial.
Qed.

Lemma btb_beb_iff : forall o o' b,
  btb_ord o o' = b <-> beb_ord o' o = negb b.
unfold beb_ord.
induction o as [n|n p Hp q Hq];
  destruct o' as [n'|n' p' q']; simpl in *; intro b.
 rewrite ltb_leb_iff.
 rewrite leb_ltb_beq_conv.
 rewrite beq_nat_sym; reflexivity.

 destruct b; simpl; split; [discriminate|discriminate|trivial|trivial].

 destruct b; simpl; split; [trivial|trivial|discriminate|discriminate].

 case_eq (btb_ord p p'); intro Hbt; simpl.
  rewrite Hp in Hbt; simpl in Hbt.
  rewrite orb_false_iff in Hbt.
  destruct Hbt as (Hbt1, Hbt2).
  rewrite Hbt1, Hbt2; simpl.
  rewrite andb_false_r; simpl.
  split; intro H; [subst b|]; simpl; trivial.
   destruct b; simpl in H |- *; [trivial|discriminate].

  rewrite Hp in Hbt; simpl in Hbt; simpl.
  rewrite orb_true_iff in Hbt.
  destruct Hbt as [Hbt|Hbt]; repeat rewrite Hbt; simpl.
   case_eq (beq_ord p p'); intro H; [rewrite beq_ord_eq in H;
     subst p'; rewrite btb_antirefl in Hbt; discriminate|clear H; simpl].
    split; intro H; [subst b|]; simpl; trivial.
     destruct b; simpl in H |- *; [discriminate|trivial].

   rewrite beq_ord_eq in Hbt; subst p'.
   rewrite beq_ord_refl; rewrite btb_antirefl; simpl.
   rewrite andb_true_r.
   case_eq (ltb n' n); intro Hltn; simpl.
    rewrite ltb_leb_iff in Hltn.
    rewrite leb_ltb_beq_conv in Hltn; simpl in Hltn.
    rewrite orb_false_iff in Hltn.
    destruct Hltn as (Hltn, Heqn).
    rewrite beq_nat_sym in Heqn.
    rewrite Hltn; repeat rewrite Heqn; simpl.
    split; intro H; [subst b|]; simpl; trivial.
     destruct b; simpl in H |- *; [trivial|discriminate].

    rewrite ltb_leb_iff in Hltn.
    rewrite leb_ltb_beq_conv in Hltn; simpl in Hltn.
    rewrite orb_true_iff in Hltn.
    destruct Hltn as [Hltn|Heqn].
     rewrite Hltn; apply ltb_leb_iff in Hltn.
     rewrite leb_ltb_beq_conv in Hltn; simpl in Hltn.
     rewrite orb_false_iff in Hltn.
     destruct Hltn as (Hltn, Heqn).
     repeat rewrite Heqn; simpl.
     rewrite beq_nat_sym in Heqn; rewrite Heqn; simpl.
     split; intro H; [subst b|]; simpl; trivial.
      destruct b; simpl in H |- *; [discriminate|trivial].

     rewrite beq_nat_true_iff in Heqn; subst n'.
     rewrite <- (beq_nat_refl n).
     rewrite ltb_antirefl; simpl; apply Hq.
Qed.

(*****************************************************************)
(*Max of two ordinals*)
Definition max_ord o o' := if (btb_ord o o') then o else o'.

Lemma btb_max_ord : forall p q r,
  btb_ord r p = true ->
  btb_ord r q = true ->
  btb_ord r (max_ord p q) = true.
intros p q r; unfold max_ord; case (btb_ord p q); trivial.
Qed.

(*****************************************************************)
(*Cantor Normal Form (CNF) and some properties.*)
Fixpoint CNF (o : Ord) : bool :=
  match o with
    | fin _ => true
    | inf n p Q => ((ltb 0 n)) && (CNF p) &&
      (CNF Q) && (btb_ord p (degree Q))
  end.

Lemma btb_ord_subterm : forall n p q,
  CNF (inf n p q) = true ->
  btb_ord (inf n p q) q = true.
destruct q; intros; simpl in *; trivial.
 repeat rewrite orb_true_iff; left; left.
 rewrite andb_true_iff in H; destruct H as (_, H); trivial.
Qed.

(*Plus and minus operations act as expected only when the *)
(*operands are in CNF*)

Fixpoint ord_plus (o o' : Ord) :=
  match o with
    | fin m  =>
      match o' with
        | fin n => fin (m+n)
        | inf _ _ _ => o'
      end
    | inf n p Q =>
      match o' with
        | fin _ => inf n p (ord_plus Q o')
        | inf n' p' Q' =>
          if (btb_ord p p') then (inf n p (ord_plus Q o')) else
            if (beq_ord p p') then (inf (n+n') p' Q') else o'
      end
  end.

Lemma degree_plus : forall o o',
  degree (ord_plus o o') = max_ord (degree o) (degree o').
unfold max_ord; destruct o as [|n p Q];
  destruct o' as [|n' p' Q']; [simpl|destruct p'; simpl|
    simpl ord_plus; simpl degree; destruct p as [n'|n' p' Q'];
      [destruct n'|]; simpl|simpl ord_plus]; trivial.
 case_eq (btb_ord p p'); intros Hbt; simpl;
   rewrite Hbt; trivial.
  case_eq (beq_ord p p'); intro Heq; simpl; trivial.
Qed.

Lemma beb_degree_cases : forall (o : Ord),
  match o with
    | fin 0 => beq_ord o (degree o) = true
    | _  => btb_ord o (degree o) = true
  end.
induction o as [n|n p Hp q _].
 destruct n as [|n]; simpl; trivial.

 destruct p as [pn|pn pp pq]; [simpl|]; trivial.
  simpl in Hp |- *; repeat rewrite orb_true_iff;
    left; left; trivial.
Qed.

Lemma beb_degree : forall (o : Ord),
  beb_ord o (degree o) = true.
intro o; unfold beb_ord; rewrite orb_true_iff.
generalize (beb_degree_cases o); intro H.
destruct o; [destruct n|]; [right|left|left]; trivial.
Qed.

Lemma CNF_ord_plus : forall o o',
  CNF o = true ->
  CNF o' = true ->
  CNF (ord_plus o o') = true.
induction o as [n|n p _ q Hq]; destruct o' as [n'|n' p' q'];
  intros Ho Ho'; simpl in *; trivial;
    repeat rewrite andb_true_iff in Ho;
      destruct Ho as (((Hlt, HCp), HCq), Hdg).
 rewrite degree_plus.
 rewrite Hlt, HCp; simpl.
 rewrite andb_true_iff; split; [apply Hq|]; trivial.
  apply btb_max_ord; simpl; [|apply btb_0 in Hdg]; trivial.

 case_eq (btb_ord p p'); intro Hbtp; simpl.
  rewrite Hlt, HCp; simpl.
  rewrite andb_true_iff; split; [apply Hq; simpl|]; trivial.
   rewrite degree_plus; rewrite btb_max_ord; simpl; trivial.

  case_eq (beq_ord p p'); intro Heqp; simpl; trivial.
   repeat rewrite andb_true_iff in Ho'.
   destruct Ho' as (((Hlt', HCp'), HCq'), Hdg').
   rewrite HCq', HCp', Hdg'; repeat rewrite andb_true_r.
   rewrite ltb_iff in Hlt' |- *.
   apply lt_le_trans with (1:=Hlt') (2:=le_plus_r n n').
Qed.

Lemma ord_plus_0_l : forall (o o' : Ord),
  ZeroO o = true ->
  ord_plus o o' = o'.
destruct o as [n|n p q]; simpl; intros; [|discriminate].
 destruct n as [|n]; intros; [simpl|discriminate].
  destruct o'; trivial.
Qed.

Lemma ord_plus_0_r : forall (o o' : Ord),
  ZeroO o = true ->
  ord_plus o' o = o'.
intro o; destruct o as [n|n p q]; simpl; intros o' H; [|discriminate].
 destruct n; [clear H|discriminate].
  induction o' as [n|n p _ q Hq]; simpl; [
    rewrite plus_0_r |  rewrite Hq]; trivial.
Qed.

Lemma plus_m_r : forall o o' oo,
  CNF oo = true ->
  btb_ord o o' = true ->
  btb_ord (ord_plus o oo) o' = true.
induction o as [n|n p _ q Hq]; destruct o' as [n'|n' p' q'];
  destruct oo as [nn|nn pp qq]; simpl; intros HCNF H;
    try discriminate; trivial.
 rewrite ltb_iff in H |- *.
 apply lt_plus_trans; trivial.

 case (beq_ord p pp); case (btb_ord p pp); simpl; trivial.

 repeat rewrite orb_true_iff in H |- *.
 destruct H as [[H|H]|H]; [left;left|left;right|right]; trivial.
  repeat rewrite andb_true_iff in H |- *.
  destruct H as ((Heqp, Heqn), Hbtq).
  split; [split|apply Hq]; trivial.

 case_eq (btb_ord p pp); intros Hbtppp; simpl.
  repeat rewrite orb_true_iff in H |- *.
  destruct H as [[H|H]|H]; [left;left|left;right|right];trivial.
   repeat rewrite andb_true_iff in H |- *.
   destruct H as ((Heqp, Heqn), Hbtq).
   split; [split|apply Hq]; trivial.

  rewrite btb_beb_iff in Hbtppp; simpl.
  unfold beb_ord in Hbtppp; rewrite orb_true_iff in Hbtppp;
    destruct Hbtppp as [Hbtp|Heqp].
   case_eq (beq_ord p pp); intro Heqp; [rewrite beq_ord_eq in Heqp;
     subst pp; rewrite btb_antirefl in Hbtp; discriminate|clear Heqp].
    simpl; repeat rewrite orb_true_iff in H |- *; left; left.
    destruct H as [[H|H]|H].
     apply btb_ord_trans with (1:=Hbtp) (2:=H).

     rewrite andb_true_iff in H; destruct H as (H, _).
     rewrite beq_ord_eq in H; subst p'; trivial.

     repeat rewrite andb_true_iff in H; destruct H as ((H, _), _).
     rewrite beq_ord_eq in H; subst p'; trivial.

   rewrite beq_ord_eq in Heqp; subst pp.
   rewrite beq_ord_refl; simpl.
   repeat rewrite andb_true_iff in HCNF;
     destruct HCNF as (((H0n, _), _), _).
   case_eq (btb_ord p p'); intros Hbtp;
    rewrite Hbtp in H; simpl in H |- *; trivial.
    case_eq (beq_ord p p'); intro Heqp;
      rewrite Heqp in H; simpl in H |- *; [|discriminate].
     rewrite orb_true_iff in H |- *.
     destruct H as [H|H]; left; rewrite ltb_iff in H0n |- *.
      rewrite ltb_iff in H; apply lt_plus_trans; trivial.

      rewrite andb_true_iff in H; destruct H as (H, _);
        rewrite beq_nat_true_iff in H; subst n'.
      apply plus_lt_compat_l with (p:=n) in H0n;
        rewrite plus_0_r in H0n; trivial.
Qed.

(*******************************************************************)
(*Pred and Minus*)
Fixpoint ord_pred (o : Ord) : Ord :=
  match o with
    | fin 0 => o
    | fin (S n) => fin n
    | inf n p o' => inf n p (ord_pred o')
  end.

Lemma degree_pred : forall o, degree o = degree (ord_pred o).
destruct o as [n|n p q]; [destruct n|]; simpl; trivial.
Qed.

Lemma CNF_ord_pred : forall o,
  CNF o = true ->
  CNF (ord_pred o) = true.
induction o as [n|n p _ q Hq]; intros Ho; simpl in *; trivial.
 destruct n; simpl; trivial.

 rewrite <- degree_pred.
 repeat rewrite andb_true_iff in Ho.
 destruct Ho as (((Hlt, HCp), HCq), Hdg).
 rewrite Hlt, HCp, Hdg; simpl.
 rewrite andb_true_r.
 apply Hq; trivial.
Qed.

Lemma btb_pred_S : forall o,
  SuccO o = true ->
  btb_ord o (ord_pred o) = true.
unfold SuccO.
induction o as [n|n p _ q Hq]; intros; simpl in *.
 destruct n; simpl in *; [discriminate|
   rewrite ltb_iff; apply lt_n_Sn].

 rewrite orb_false_r in H.
 rewrite orb_true_iff; right.
 repeat rewrite andb_true_iff.
 split; [split; [rewrite beq_ord_eq|rewrite beq_nat_true_iff]|
   apply Hq; clear n p Hq]; trivial.
  rewrite orb_true_iff.
  destruct q; simpl in *; [right|left]; trivial.
Qed.

Lemma eq_pred_notS : forall o,
  SuccO o = false -> ord_pred o = o.
intro o; unfold SuccO; rewrite orb_false_iff.
induction o as [n|n p _ q Hq]; intro HNS;
  destruct HNS as (HNS1, HNS2).
 destruct n; simpl in *; [trivial|discriminate].

 simpl in *; rewrite Hq; trivial.
 destruct q as [n'|n' p' q']; [destruct n'|];
   simpl in *; [split; trivial|discriminate|split; trivial].
Qed.

Fixpoint ord_minus (o o' : Ord) :=
  match o, o' with
    | fin n, fin m => fin (n - m)
    | fin n, inf _ _ _ => o
    | inf n p q, fin _ => inf n p (ord_minus q o')
    | inf n p q, inf n' p' q' =>
      if (btb_ord p p') then inf n p (ord_minus q o') else
        if (beq_ord p p') then
          (if (ltb n' n) then inf (n-n') p (ord_minus q q') else
            ord_minus q q')
          else o
  end.

Lemma ord_minus_degree : forall o o',
  CNF o = true ->
  beb_ord (degree o) (degree (ord_minus o o')) = true.
induction o as [n|n p _ q Hq]; destruct o' as [n'|n' p' q'];
  intro Ho; simpl; trivial.
 unfold beb_ord; rewrite beq_ord_refl;
   rewrite orb_true_r; trivial.

 case_eq (btb_ord p p'); intro Hbtp; simpl;
   [unfold beb_ord; rewrite beq_ord_refl;
     rewrite orb_true_r; trivial|].
  case_eq (beq_ord p p'); intro Heqp; simpl;
    [|unfold beb_ord; rewrite beq_ord_refl;
      rewrite orb_true_r; trivial].
   case_eq (ltb n' n); intro Hltn; simpl;
     [unfold beb_ord; rewrite beq_ord_refl;
       rewrite orb_true_r; trivial|].
    simpl in Ho; repeat rewrite andb_true_iff in Ho;
      destruct Ho as (((_, _), HCq), Hdg).
    specialize Hq with (o':=q') (1:=HCq).
    apply beb_trans with (2:=Hq).
    unfold beb_ord; rewrite Hdg; simpl; trivial.
Qed.

Lemma CNF_ord_minus : forall o o',
  CNF o = true ->
  CNF o' = true ->
  CNF (ord_minus o o') = true.
induction o as [n|n p _ q Hq]; destruct o' as [n'|n' p' q'];
  intros Ho Ho'; simpl in *; trivial;
    repeat rewrite andb_true_iff in Ho;
      destruct Ho as (((Hlt, HCp), HCq), Hdg).
 rewrite Hlt, HCp; simpl.
 rewrite andb_true_iff; split; [apply Hq|]; trivial.
  apply btb_beb_trans with (1:=Hdg).
  apply ord_minus_degree; trivial.

 case_eq (btb_ord p p'); intro Hbtp; simpl.
  rewrite Hlt, HCp; simpl.
  rewrite andb_true_iff; split; [apply Hq; simpl|]; trivial.
   apply btb_beb_trans with (1:=Hdg).
   apply ord_minus_degree; trivial.

  case_eq (beq_ord p p'); intro Heqp; simpl;
    [|repeat rewrite andb_true_iff; repeat split; trivial].
   repeat rewrite andb_true_iff in Ho'.
   destruct Ho' as (((Hlt', HCp'), HCq'), Hdg').
   case_eq (ltb n' n); intro Hltn; simpl; [|apply Hq; trivial].
    rewrite HCp; rewrite andb_true_r.
    repeat rewrite andb_true_iff;
      repeat split; [|apply Hq; trivial|].
     rewrite ltb_iff in Hltn |- *.
     unfold lt in Hltn |- *.
     apply minus_le_compat_r with (p:=n') in Hltn.
     rewrite <- minus_Sn_m in Hltn; trivial.
     rewrite minus_diag in Hltn; trivial.

     apply btb_beb_trans with (1:=Hdg).
     apply ord_minus_degree; trivial.
Qed.

Lemma btb_minus : forall o' o oo,
  CNF o' = true ->
  CNF o  = true ->
  CNF oo = true ->
  btb_ord o o' = true ->
  btb_ord o (ord_minus o' oo) = true.
induction o' as [n'|n' p' _ q' Hq'].
 destruct o as [n|n p q]; [|destruct oo; simpl; trivial].
  destruct oo as [nn|nn pp qq]; simpl; trivial.
   do 2 rewrite ltb_iff; intros _ _ _ H.
   apply le_lt_trans with (1:=le_minus n' nn) (2:=H).

 destruct o as [n|n p q]; [simpl; discriminate|intros oo Ho' Ho Hoo H].
  destruct oo as [nn|nn pp qq]; [
    simpl; repeat rewrite orb_true_iff|simpl ord_minus].
   simpl in H; repeat rewrite orb_true_iff in H.
   destruct H as [[H|H]|H]; [left;left|left;right|right]; trivial.
    repeat rewrite andb_true_iff in H |- *.
    destruct H as ((Hpp, Hnn), Hqq).
    simpl in Ho, Ho'; repeat rewrite andb_true_iff in Ho, Ho'.
    destruct Ho as (((_, _), Ho), _).
    destruct Ho' as (((_, _), Ho'), _).
    split; [split|apply Hq'; simpl]; trivial.

   case_eq (btb_ord p' pp); intros _ ; [simpl|].
    repeat rewrite orb_true_iff.
    simpl in H; repeat rewrite orb_true_iff in H.
    destruct H as [[H|H]|H]; [left;left|left;right|right]; trivial.
     repeat rewrite andb_true_iff in H |- *.
     destruct H as ((Hpp, Hnn), Hqq).
      simpl in Ho, Ho'; repeat rewrite andb_true_iff in Ho, Ho'.
      destruct Ho as (((_, _), Ho), _).
      destruct Ho' as (((_, _), Ho'), _).
      split; [split|apply Hq'; simpl]; trivial.

    case_eq (beq_ord p' pp); intro Hppp; [
      rewrite beq_ord_eq in Hppp; subst pp|trivial].
     case_eq (ltb nn n'); intros Hnn ; [simpl|].
      repeat rewrite orb_true_iff.
      simpl in Hoo; repeat rewrite andb_true_iff in Hoo;
        destruct Hoo as (((Hoo, _), _), _).
      simpl in H; repeat rewrite orb_true_iff in H.
      destruct H as [[H|H]|H]; [left;left| |]; trivial; left; right;
        repeat rewrite andb_true_iff in H |- *.
       destruct H as (Heqp, Hn).
       split; [trivial|].
        rewrite ltb_iff in Hn, Hnn, Hoo |- *.
        apply lt_trans with (2:=Hn).
        apply lt_minus; [apply lt_le_weak|]; trivial.

       rewrite andb_true_iff in H.
       destruct H as ((Heqp, Hn), _).
       split; [trivial|].
        rewrite beq_nat_true_iff in Hn; subst n'.
        rewrite ltb_iff in Hnn, Hoo |- *.
        apply lt_minus; [apply lt_le_weak|]; trivial.

      apply btb_ord_trans with (o2:=(inf n' p' q')); trivial.
       generalize Ho'; intro H'.
       simpl in Ho, Ho', Hoo.
       repeat rewrite andb_true_iff in Ho, Ho', Hoo.
       destruct Ho as (((_, _), Ho), _).
       destruct Ho' as (((_, _), Ho'), _).
       destruct Hoo as (((_, _), Hoo), _).
        apply Hq'; [| | |apply btb_ord_subterm]; trivial.
Qed.

Lemma plus_bt_minus : forall o o' oo,
  CNF o  = true ->
  CNF o' = true ->
  CNF oo = true ->
  btb_ord o oo = false ->
  btb_ord (ord_plus o o') oo = true ->
  btb_ord o' (ord_minus oo o) = true.
induction o as [n|n p _ q Hq]; destruct oo as [nn|nn pp qq];
  destruct o' as [n'|n' p' q']; intros Ho Ho' Hoo H H';
    try discriminate; trivial.
 simpl in H, H' |- *.
 rewrite ltb_leb_iff in H; simpl in H; rewrite leb_iff in H.
 rewrite ltb_iff in H' |- *; unfold lt in H' |- *.
 apply minus_le_compat_r with (p:=n) in H'.
 rewrite minus_plus in H'.
 rewrite <- minus_Sn_m in H'; trivial.

 simpl ord_plus in H'.
 apply btb_minus; trivial.

 simpl in Ho, Hoo.
 repeat rewrite andb_true_iff in Ho, Hoo.
 destruct Ho as (((_, _), Ho), _).
 destruct Hoo as (((_, _), Hoo), _).
 simpl in H', H; simpl ord_minus.
 repeat rewrite orb_false_iff in H.
 destruct H as ((Hbt1, Hbt2), Hbt3).
 rewrite Hbt1, Hbt2 in H'; simpl in H'.
 rewrite btb_beb_iff in Hbt1;
   unfold beb_ord in Hbt1; simpl in Hbt1.
 rewrite orb_true_iff in Hbt1; destruct Hbt1 as [Hbt|Heq].
  rewrite Hbt; rewrite btb_beb_iff in Hbt; simpl in Hbt.
  unfold beb_ord in Hbt; rewrite orb_false_iff in Hbt.
  destruct Hbt as (Hbt, Heq).
  rewrite Heq in H'; simpl in H'; discriminate.

  rewrite beq_ord_eq in Heq; subst pp; rewrite btb_antirefl.
  rewrite beq_ord_refl in Hbt2, Hbt3, H' |- *;
    simpl in Hbt2, Hbt3, H'.
  rewrite ltb_leb_iff in Hbt2.
  rewrite leb_ltb_beq_conv in Hbt2; simpl in Hbt2.
  rewrite orb_true_iff in Hbt2; destruct Hbt2 as [Hlt|Heq].
   rewrite Hlt; rewrite ltb_leb_iff in Hlt.
   rewrite leb_ltb_beq_conv in Hlt; simpl in Hlt.
   rewrite orb_false_iff in Hlt; destruct Hlt as (_, Heq).
   rewrite beq_nat_sym in Heq; rewrite Heq in H';
     simpl in H'; discriminate.

   rewrite Heq in Hbt3, H'; simpl in Hbt3, H'.
   rewrite beq_nat_true_iff in Heq; subst nn.
   rewrite ltb_antirefl; apply Hq; trivial.

 simpl ord_plus in H'.
 case_eq (btb_ord p p'); intros Hbtp; rewrite Hbtp in H'.
  simpl in H, H'; simpl ord_minus.
  case_eq (btb_ord p pp); intros Hbtppp;
    rewrite Hbtppp in H; simpl in H; [discriminate|].
   rewrite btb_beb_iff in Hbtppp; simpl in Hbtppp.
   unfold beb_ord in Hbtppp; rewrite orb_true_iff in Hbtppp.
   destruct Hbtppp as [Hppp|Hppp].
    rewrite btb_beb_iff in Hppp; simpl in Hppp.
    unfold beb_ord in Hppp; rewrite orb_false_iff in Hppp.
    destruct Hppp as (Hbtpp, Heqp); rewrite Hbtpp, Heqp in H';
      simpl in H'; discriminate.

    rewrite beq_ord_eq in Hppp; subst pp.
    rewrite btb_antirefl in H' |- *.
    repeat rewrite beq_ord_refl in H, H'; simpl in H, H'.
    case_eq (ltb nn n); intro Hnnn;
      rewrite Hnnn in H, H'; simpl in H, H'; [discriminate|].
     rewrite ltb_leb_iff in Hnnn; simpl in Hnnn.
     rewrite leb_ltb_beq_conv in Hnnn;
       rewrite orb_true_iff in Hnnn; destruct Hnnn as [Hnnn|Hnnn].
      rewrite ltb_leb_iff in Hnnn; simpl in Hnnn.
      rewrite leb_ltb_beq_conv in Hnnn; rewrite orb_false_iff in Hnnn;
        destruct Hnnn as (_, Hnnn); rewrite beq_nat_sym in Hnnn;
          rewrite Hnnn in H'; simpl in H'; discriminate.

      rewrite Hnnn in H, H'; simpl in H, H'.
      rewrite beq_nat_true_iff in Hnnn; subst nn.
      rewrite ltb_antirefl, beq_ord_refl.
      simpl in Ho, Hoo.
      repeat rewrite andb_true_iff in Ho, Hoo.
      destruct Ho as (((_, _), Ho), _).
      destruct Hoo as (((_, _), Hoo), _).
      apply Hq; trivial.

  rewrite btb_beb_iff in Hbtp; simpl in Hbtp.
  unfold beb_ord in Hbtp; rewrite orb_true_iff in Hbtp.
  destruct Hbtp as [Hpp'|Hpp'].
   rewrite btb_beb_iff in Hpp'; simpl in Hpp';
     unfold beb_ord in Hpp'; rewrite orb_false_iff in Hpp'.
   destruct Hpp' as (_, Hpp'); rewrite Hpp' in H'.
   apply btb_minus; trivial.

  rewrite beq_ord_eq in Hpp'; subst p'.
  rewrite beq_ord_refl in H'.
  case_eq (btb_ord p pp); intros Hbt; [
    simpl in H; rewrite Hbt in H; simpl in H; discriminate|].
   rewrite btb_beb_iff in Hbt; simpl in Hbt.
   unfold beb_ord in Hbt; rewrite orb_true_iff in Hbt.
   destruct Hbt as [Hbt|Heq]; [
     simpl in H'; rewrite btb_beb_iff in Hbt; simpl in Hbt;
       unfold beb_ord in Hbt; rewrite orb_false_iff in Hbt;
         destruct Hbt as (Hbt, Heq); rewrite Hbt, Heq in H';
           simpl in H'; discriminate|].
    rewrite beq_ord_eq in Heq; subst pp.
    case_eq (ltb nn n); intros Heqn; simpl in H.
     rewrite btb_antirefl in H; repeat rewrite beq_ord_refl in H;
       rewrite Heqn in H; simpl in H; discriminate.

     simpl in H'; simpl ord_minus.
     simpl in Ho, Hoo.
     repeat rewrite andb_true_iff in Ho, Hoo.
     destruct Ho as (((_, _), Ho), _).
     destruct Hoo as (((_, _), Hoo), Hdegree).
     rewrite btb_antirefl in H, H' |- *; simpl in H, H'.
     repeat rewrite beq_ord_refl in H, H'; simpl in H, H'.
     rewrite beq_ord_refl.
     rewrite Heqn in H; simpl in H, H'.
     rewrite ltb_leb_iff in Heqn; simpl in Heqn.
     rewrite leb_ltb_beq_conv in Heqn; rewrite orb_true_iff in Heqn.
     destruct Heqn as [Hlt|Heq].
      rewrite Hlt; simpl; rewrite btb_antirefl;
        repeat rewrite beq_ord_refl; simpl; rewrite orb_true_iff.
      case_eq (ltb nn (n+n')); intros Heqn;
        rewrite Heqn in H'; simpl in H' |- *; [left|right].
       rewrite ltb_iff in Hlt, Heqn |- *.
       apply lt_le_weak in Hlt; unfold lt in Heqn |- *.
       apply minus_le_compat_r with (p:=n) in Heqn.
       rewrite minus_plus in Heqn.
       rewrite <- minus_Sn_m in Heqn; trivial.

       rewrite ltb_leb_iff in Heqn; unfold beb_ord in Heqn;
         simpl in Heqn; rewrite leb_ltb_beq_conv in Heqn;
           rewrite orb_true_iff in Heqn; destruct Heqn as [Hltn|Heqn].
        rewrite ltb_leb_iff in Hltn; unfold beb_ord in Hltn;
          simpl in Hltn; rewrite leb_ltb_beq_conv in Hltn;
            rewrite orb_false_iff in Hltn; destruct Hltn as (Hltn,Heqn).
        rewrite beq_nat_sym in Heqn; rewrite Heqn in H';
          simpl in H'; discriminate.

        rewrite Heqn in H'; simpl in H'.
        rewrite beq_nat_true_iff in Heqn; subst nn.
        rewrite minus_plus; rewrite <- (beq_nat_refl n'); simpl.
        simpl in Ho'; repeat rewrite andb_true_iff in Ho'.
        destruct Ho' as (((_, _), Ho'), _).
        apply btb_minus; trivial.

      rewrite beq_nat_true_iff in Heq; subst nn.
      rewrite ltb_antirefl.
      rewrite <- (beq_nat_refl n) in H; simpl in H.
      apply btb_minus; trivial.
       destruct qq; simpl;
         [|simpl in Hdegree; rewrite Hdegree; simpl]; trivial.
Qed.

(******************************************************************)
(*Cantor Normal Form Ordinals*)
(******************************************************************)
Definition CNFO := {o : Ord | CNF o = true}.

Definition CNFO_plus (o : CNFO) (o' : CNFO) : CNFO.
destruct o as (o, CNFo); destruct o' as (o', CNFo').
exists (ord_plus o o').
apply CNF_ord_plus; trivial.
Defined.

Definition CNFO_pred (o : CNFO) : CNFO.
destruct o as (o, CNFO).
exists (ord_pred o).
apply CNF_ord_pred; trivial.
Defined.

Definition CNFO_minus (o : CNFO) (o' : CNFO) : CNFO.
destruct o as (o, CNFo); destruct o' as (o', CNFo').
exists (ord_minus o o').
apply CNF_ord_minus; trivial.
Defined.

Definition CNFO_nat (n : nat) : CNFO.
exists (fin n); simpl; trivial.
Defined.

Definition CNFO_btb (o o' : CNFO) :=
  btb_ord (proj1_sig o) (proj1_sig o').

Definition CNFO_beq (o o' : CNFO) :=
  beq_ord (proj1_sig o) (proj1_sig o').

(******************************************************************)
(*A path with an ordinal length*)
(******************************************************************)

Section Path.

 Variable A : Type.
 Variable eq_A : A -> A -> bool.

 Definition domain (o : CNFO) := {i: CNFO|CNFO_btb o i = true}.

 Definition path (o : CNFO) := (domain o) -> A.

 Definition join (o o' : CNFO) (p : path o) (p' : path o') :
   option (path (CNFO_plus (CNFO_pred o) o')).
 case_eq (ZeroO (proj1_sig o')); intros HO; [exact None|].
  (*The second path is not length 0*)
  case_eq (SuccO (proj1_sig o)); intro HS.
   (*The first path is of length (w^pi*ci + S n) *)
   assert (domain o) as po. (*The last index of fst path*)
    exists (CNFO_pred o).
    destruct o, o'; simpl in HS |- *.
    unfold CNFO_btb; apply btb_pred_S in HS; trivial.
   assert (domain o') as po'. (*The first index of snd path*)
    exists (CNFO_nat 0).
    destruct o'; unfold CNFO_btb; simpl.
    apply not_0_bt_0; trivial.
   case_eq (eq_A (p po) (p' po')); intro Heq; [|exact None].
    (*The last el of fst path is equal to the fst el of snd path*)
    assert (f : path (CNFO_plus (CNFO_pred o) o')).
     intros oo; destruct oo as (oo, Hoo).
     case_eq (btb_ord (ord_pred (proj1_sig o)) (proj1_sig oo));
     intros Hpart.
      (*The index oo < o - 1*)
      assert (domain o) as poo.
       exists oo.
       apply btb_ord_trans with (2:=Hpart).
       apply btb_pred_S; trivial.
      exact (p poo).
      (*The index oo >= o - 1*)
      assert (domain o') as poo.
       exists (CNFO_minus oo (CNFO_pred o)).
       unfold CNFO_btb in Hoo |- *.
       destruct o as (o, cnfo); destruct o' as (o', cnfo');
         destruct oo as (oo, cnfoo); simpl in Hoo, Hpart |- *.
       apply plus_bt_minus; trivial.
        apply CNF_ord_pred; trivial.
      exact (p' poo).
    exact (Some f).

   (*The length of fst path is not succ case*)
   assert (f : path (CNFO_plus (CNFO_pred o) o')).
    intros oo; destruct oo as (oo, Hoo).
    case_eq (CNFO_btb o oo); intros Hpart.
      (*The index oo < o*)
      assert (domain o) as poo.
       exists oo; trivial.
      exact (p poo).
      (*The index oo >= o*)
      assert (domain o') as poo.
       exists (CNFO_minus oo o).
       unfold CNFO_btb in Hoo, Hpart |- *.
       destruct o as (o, cnfo); destruct o' as (o', cnfo');
         destruct oo as (oo, cnfoo); simpl in Hoo, Hpart, HS |- *.
        rewrite eq_pred_notS in Hoo; trivial.
        apply plus_bt_minus; trivial.
      exact (p' poo).
    exact (Some f).
 Defined.

End Path.

(******************************************************************)
(*Set of paths*)
(******************************************************************)

Set Implicit Arguments.

Section SetOfPaths.

 Parameter A : Type.
 Parameter eq_A : A -> A -> bool.

 Definition PathSet (o : CNFO) := path A o -> Prop.

 Definition pathin o (s : PathSet o) (p : path A o) := s p.

 Inductive setjoin o o' (s : PathSet o) (s' : PathSet o') :
   PathSet (CNFO_plus (CNFO_pred o) o') :=
   jointwo : forall p p' p'',
     pathin s p ->
     pathin s' p' ->
     join A eq_A o o' p p' = Some p'' ->
     pathin (setjoin s s') p''.

 Definition set_include o o' (s : PathSet o) (s' : PathSet o') :=
   CNFO_beq o o' /\

 Lemma setjoin_comm : forall or os oq
   (r : PathSet or) (s : PathSet os) (q : PathSet oq),
   setjoin (setjoin r s) q

 (*Don't requrie elements are different, infinitely many elements*)
(* Record PathSet := mkset {
   elelen : CNFO -> CNFO;
   elemen : forall (o : CNFO), path A (elelen o)
 }.

 Definition constone : CNFO.
 exists (fin 1); trivial.
 Defined.

 Definition one : PathSet.
 exists (fun _ => constone).
 intro index.
 unfold path.
 *)


Load "./syntax".
Import Nat.

Fixpoint match_natlist {A: Type} (l: list (nat * A)) n def :=
  match l with
  | [] => def
  | (n1, h) :: t => if eqb n1 n then h else match_natlist t n def
  end.

Fixpoint subst_type l t :=
  match t with
  | TyVar n => match_natlist l n t
  | Bool => Bool
  | Arrow t1 t2 =>
    subst_type l t1 |--> subst_type l t2
  end.

Fixpoint subst_type_term l t :=
  match t with
  | Var n => Var n
  | Abs x typ e1 =>
    Abs x (subst_type l typ) (subst_type_term l e1)
  | Tru => Tru
  | Fls => Fls
  | App e1 e2 => App (subst_type_term l e1) (subst_type_term l e2)
  | If e1 e2 e3 => If (subst_type_term l e1) (subst_type_term l e2) (subst_type_term l e3)
  end.

Definition subst_type_list subl (ctx: context) := map (subst_type subl) ctx.

Theorem T22_1_2 : forall Γ σ t T,
    Γ |- t \in T -> subst_type_list σ Γ |- subst_type_term σ t \in subst_type σ T.
Proof.
  intros. generalize dependent σ. induction H; simpl; intros; try solve [econstructor; eauto].
  -
    constructor; eauto. generalize dependent n1.
    induction ctx; simpl; intros; simpl in H; auto.
    destruct n1; simpl in H; try discriminate.
    destruct n1. simpl. simpl in H. inversion H; subst. reflexivity.
    simpl. simpl in H. apply IHctx in H. apply H.
Qed.

Fixpoint tyn_in_type n ty :=
  match ty with
  | TyVar n1 => eqb n n1
  | t1 |--> t2 => (tyn_in_type n t1) || (tyn_in_type n t2)
  | _ => false
  end.

Fixpoint tyn_in_term n t :=
  match t with
  | App e1 e2 => (tyn_in_term n e1) || (tyn_in_term n e2)
  | Abs x typ e1 => if tyn_in_type n typ then true else (tyn_in_term n e1)
  | If e1 e2 e3 => (tyn_in_term n e1) || (tyn_in_term n e2) || (tyn_in_term n e3)
  | _ => false
  end.

Fixpoint tyn_in_list n l :=
  match l with
  | [] => false
  | ty :: t => (tyn_in_type n ty) || (tyn_in_list n t)
  end.

Fixpoint max_tyvar_type n ty :=
  match ty with
  | TyVar m => if ltb n m then m else n
  | ty1 |--> ty2 =>
    let n1 := max_tyvar_type n ty1 in
    let n2 := max_tyvar_type n ty2 in
    if ltb n1 n2 then n2 else n1
  | _ => n
  end.

Fixpoint max_tyvar_term n t :=
  match t with
  | Abs _ ty e1 =>
    let n1 := max_tyvar_type n ty in
    let n2 := max_tyvar_term n e1 in
    if ltb n1 n2 then n2 else n1
  | App e1 e2 =>
    let n1 := max_tyvar_term n e1 in
    let n2 := max_tyvar_term n e2 in
    if ltb n1 n2 then n2 else n1
  | If e1 e2 e3 =>
    let n1 := max_tyvar_term n e1 in
    let n2 := max_tyvar_term n e2 in
    let n3 := max_tyvar_term n e3 in
    let r := if ltb n1 n2 then n2 else n1 in
    if ltb r n3 then n3 else r
  | _ => n
  end.

Fixpoint max_tyvar_list n l :=
  match l with
  | [] => n
  | h :: t =>
    let m := max_tyvar_type n h in
    let r := if ltb n m then m else n in
    max_tyvar_list r t
  end.

Lemma Smax_tyvar_type_is_not_in : forall typ n n1,
    max_tyvar_type n typ < n1 ->
    tyn_in_type n1 typ = false.
Proof.
  induction typ; simpl; intros; auto.
  -
    destruct ltb eqn:IH1.
    apply Nat.ltb_lt in IH1. apply Nat.lt_trans with (p:= n1) in IH1; auto.
    apply IHtyp1 in IH1. apply IHtyp2 in H. rewrite IH1, H. reflexivity.
    apply Nat.ltb_ge in IH1. apply Nat.le_lt_trans with (p:= n1) in IH1; auto.
    apply IHtyp1 in H. apply IHtyp2 in IH1. rewrite IH1, H; reflexivity.
  -
    destruct ltb eqn:IH.
    +
      apply Nat.lt_neq in H. apply Nat.eqb_neq in H. rewrite Nat.eqb_sym in H. rewrite H. reflexivity.
    +
      apply Nat.ltb_ge in IH. apply Nat.le_lt_trans with (p:= n1) in IH; auto.
      rewrite Nat.eqb_sym. apply Nat.lt_neq in IH. apply Nat.eqb_neq in IH. rewrite IH. reflexivity.
Qed.

Lemma Smax_tyvar_term_is_not_in : forall e n m,
    max_tyvar_term n e < m ->
    tyn_in_term m e = false.
Proof.
  induction e; simpl; intros; auto.
  -
    destruct ltb eqn:IH.
    assert (tyn_in_type m typ = false).
    +
      apply Smax_tyvar_type_is_not_in with n. apply Nat.ltb_lt in IH.
      apply Nat.lt_trans with (max_tyvar_term n e); auto.
    +
      rewrite H0. apply IHe in H. apply H.
    +
      apply Nat.ltb_ge in IH. apply Nat.le_lt_trans with (p:= m) in IH; auto. apply IHe in IH.
      apply Smax_tyvar_type_is_not_in in H. rewrite IH, H. reflexivity.
  -
    destruct ltb eqn:IH.
    +
      apply Nat.ltb_lt in IH. apply Nat.lt_trans with (p:= m) in IH; auto.
      apply IHe1 in IH. apply IHe2 in H. rewrite IH, H; reflexivity.
    +
      apply Nat.ltb_ge in IH. eapply Nat.le_lt_trans in IH; eauto.
      apply IHe1 in H. apply IHe2 in IH. rewrite IH, H; reflexivity.
  -
    destruct (max_tyvar_term n e1 <? max_tyvar_term n e2) eqn:IH1.
    +
      destruct (max_tyvar_term n e2 <? max_tyvar_term n e3) eqn:IH2.
      ++
        apply Nat.ltb_lt in IH2. apply Nat.ltb_lt in IH1.
        apply Nat.lt_trans with (p:= m) in IH2; auto.
        apply Nat.lt_trans with (p:= m) in IH1; auto.
        apply IHe1 in IH1. apply IHe2 in IH2. apply IHe3 in H.
        rewrite IH1, IH2, H; reflexivity.
      ++
        apply Nat.ltb_lt in IH1. apply Nat.ltb_ge in IH2.
        apply Nat.lt_trans with (p:= m) in IH1; auto.
        apply Nat.le_lt_trans with (p:= m) in IH2; auto.
        apply IHe1 in IH1. apply IHe2 in H. apply IHe3 in IH2.
        rewrite IH1, IH2, H; reflexivity.
    +
      apply Nat.ltb_ge in IH1.
      destruct (max_tyvar_term n e1 <? max_tyvar_term n e3) eqn:IH2.
      ++
        apply Nat.ltb_lt in IH2. apply Nat.lt_trans with (p:= m) in IH2; auto.
        apply Nat.le_lt_trans with (p:= m) in IH1; auto.
        apply IHe1 in IH2. apply IHe2 in IH1. apply IHe3 in H.
        rewrite IH1, IH2, H; reflexivity.
      ++
        apply Nat.ltb_ge in IH2.
        apply Nat.le_lt_trans with (p:= m) in IH1; auto.
        apply Nat.le_lt_trans with (p:= m) in IH2; auto.
        apply IHe1 in H. apply IHe2 in IH1. apply IHe3 in IH2.
        rewrite H, IH1, IH2; reflexivity.
Qed.

Lemma max_tyvar_list_n_lt_m : forall l n m,
    max_tyvar_list n l < m ->
    n < m.
Proof.
  induction l; simpl; intros; eauto.
  destruct ltb eqn:IH; eauto.
  apply Nat.ltb_lt in IH. apply Nat.lt_trans with (p:= m) in IH; auto.
Qed.

Lemma Smax_tyvar_list_is_not_in : forall l n m,
    max_tyvar_list n l < m ->
    tyn_in_list m l = false.
Proof.
  induction l; simpl; intros; auto.
  destruct ltb eqn:IH.
  -
    erewrite IHl; eauto.
    apply max_tyvar_list_n_lt_m in H. apply Smax_tyvar_type_is_not_in in H.
    rewrite H. reflexivity.
  -
    apply Nat.ltb_ge in IH.
    apply Nat.le_lt_trans with (p:= m) in IH.
    apply Smax_tyvar_type_is_not_in in IH.
    erewrite IHl; eauto.
    rewrite IH. reflexivity.
    apply max_tyvar_list_n_lt_m in H; apply H.
Qed.

Definition max_tyvar_list_term n l e :=
  let n1 := max_tyvar_list n l in
  let m := max_tyvar_term n e in
  if ltb n1 m then m else n1.

Lemma max_tyvar_list_term_is_not_in : forall n l e m,
    max_tyvar_list_term n l e < m ->
    tyn_in_list m l = false /\ tyn_in_term m e = false.
Proof.
  intros. unfold max_tyvar_list_term in H.
  destruct ltb eqn:IH.
  -
    apply Nat.ltb_lt in IH.
    apply Nat.lt_trans with (p:= m) in IH; auto.
    apply Smax_tyvar_list_is_not_in in IH. rewrite IH.
    apply Smax_tyvar_term_is_not_in in H. rewrite H. split; reflexivity.
  -
    apply Nat.ltb_ge in IH.
    apply Nat.le_lt_trans with (p:= m) in IH; auto.
    apply Smax_tyvar_term_is_not_in in IH.
    apply Smax_tyvar_list_is_not_in in H.
    auto.
Qed.

Reserved Notation "Γ |-- n ` t \in T | m ` C "(at level 50).
Inductive Constrait_Type : context -> nat -> term -> ty -> nat -> list (ty * ty) -> Prop :=
| CT_Var : forall x T Γ F,
    getbinding x Γ = Some T ->
    Γ |-- F ` Var x \in T | F ` []
| CT_Abs : forall Γ x T1 t2 T2 C F' F,
    (T1:: Γ) |-- F ` t2 \in T2 | F' ` C ->
    Γ |-- F ` (Abs x T1 t2) \in T1 |--> T2 | F' ` C
| CT_App : forall Γ t1 ty1 C1 t2 ty2 C2 F' F'' F,
    Γ |-- F ` t1 \in ty1 | F' ` C1 -> Γ |-- F' ` t2 \in ty2 | F'' ` C2 ->
    Γ |-- F ` App t1 t2 \in (TyVar (F'')) | (S F'') ` ((ty1, ty2 |--> TyVar (F'') ) :: C1 ++ C2)
| CT_Tru : forall Γ F,
    Γ |-- F ` Tru \in Bool | F ` []
| CT_Fls : forall Γ F,
    Γ |-- F ` Fls \in Bool | F ` []
| CT_If : forall e1 e2 e3 ty1 ty2 ty3 F1 F2 F3 C1 C2 C3 Γ F,
    Γ |-- F ` e1 \in ty1 | F1 ` C1 -> Γ |-- F1 ` e2 \in ty2 | F2 ` C2 ->
    Γ |-- F2 ` e3 \in ty3 | F3 ` C3 ->
    Γ |-- F ` If e1 e2 e3 \in ty3 | F3 ` ( (ty1, Bool):: (ty2, ty3) :: C1 ++ C2 ++ C3 )
where "Γ |-- n ` t \in T | m ` C" := (Constrait_Type Γ n t T m C).

Fixpoint Constrait_Type_fix Γ n e :=
  match e with
  | Var x => match getbinding x Γ with
             | Some ty => Some (ty, n, nil)
             | None => None
             end
  | Abs _ ty1 e1 =>
    match Constrait_Type_fix (ty1 :: Γ) n e1 with
    | Some (ty, n1, l) => Some (ty1 |--> ty, n1, l)
    | None => None
    end
  | App e1 e2 =>
    match Constrait_Type_fix Γ n e1 with
    | Some (ty1, n1, C1) =>
      match Constrait_Type_fix Γ n1 e2 with
      | Some (ty2, n2, C2) =>
        Some (TyVar (n2), S n2, (ty1, ty2 |--> (TyVar (n2)) ):: C1 ++ C2)
      | None => None
      end
    | None => None
    end
  | Tru => Some (Bool, n, nil)
  | Fls => Some (Bool, n, nil)
  | If e1 e2 e3 =>
    match Constrait_Type_fix Γ n e1 with
    | Some (ty1, n1, C1) =>
      match Constrait_Type_fix Γ n1 e2 with
      | Some (ty2, n2, C2) =>
        match Constrait_Type_fix Γ n2 e3 with
        | Some (ty3, n3, C3) => Some (ty3, n3, (ty1, Bool):: (ty2, ty3) :: C1 ++ C2 ++ C3)
        | Noen => None
        end
      | None => None
      end
    | None => None
    end
  end.

Lemma Constrait_Type_fix_Correct1 : forall Γ n e typ m C,
    Γ |-- n ` e \in typ | m ` C -> Constrait_Type_fix Γ n e = Some (typ, m, C).
Proof.
  intros.
  induction H; simpl; auto.
  +
    rewrite H. reflexivity.
  +
    rewrite IHConstrait_Type. reflexivity.
  +
    rewrite IHConstrait_Type1, IHConstrait_Type2. reflexivity.
  +
    rewrite IHConstrait_Type1, IHConstrait_Type2, IHConstrait_Type3; reflexivity.
Qed.

Lemma Constrait_Type_fix_Correct2 : forall e Γ n typ m C,
    Constrait_Type_fix Γ n e = Some(typ, m, C) -> Γ |-- n ` e \in typ | m ` C.
Proof.
  induction e; simpl; intros; auto.
  -
    destruct getbinding eqn:IH; try discriminate.
    inversion H; subst. constructor. rewrite IH. reflexivity.
  -
    destruct Constrait_Type_fix eqn:IH; try discriminate.
    destruct p. destruct p. apply IHe in IH. inversion H; subst.
    econstructor; eauto.
  -
    destruct Constrait_Type_fix eqn:IH1; try discriminate.
    destruct p. destruct p. apply IHe1 in IH1.
    destruct Constrait_Type_fix eqn:IH2; try discriminate.
    destruct p. destruct p. apply IHe2 in IH2.
    inversion H; subst.
    econstructor; eauto.
  -
    inversion H; subst; constructor.
  -
    inversion H; subst; constructor.
  -
    destruct Constrait_Type_fix eqn:IH1; try discriminate.
    destruct p. destruct p. apply IHe1 in IH1.
    destruct Constrait_Type_fix eqn:IH2; try discriminate.
    destruct p. destruct p. apply IHe2 in IH2.
    destruct Constrait_Type_fix eqn:IH3; try discriminate.
    destruct p. destruct p. apply IHe3 in IH3.
    inversion H; subst.
    econstructor; eauto.
Qed.

Definition CT_fix Γ e := Constrait_Type_fix Γ (S(max_tyvar_list_term 0 Γ e)) e.

Compute (CT_fix []  (Abs "x" (TyVar 0) (Abs "y" (TyVar 1) (Abs "z" (TyVar 2)
           (App (App (Var 2) (Var 0) ) (App (Var 1) (Var 0)) )) ))).

Fixpoint Constrais_sol_bool σ C :=
  match C with
  | nil => true
  | (ty1, ty2) :: t =>
    if eqb_ty (subst_type σ ty1) (subst_type σ ty2) then
      (Constrais_sol_bool σ t)
    else false
  end.

Lemma Constrais_sol_bool_app : forall σ C1 C2,
    Constrais_sol_bool σ (C1 ++ C2) = true ->
    Constrais_sol_bool σ C1 = true /\ Constrais_sol_bool σ C2 = true.
Proof.
  induction C1; simpl; intros; auto.
  destruct a.
  destruct eqb_ty; try discriminate.
  apply IHC1 in H. apply H.
Qed.

Theorem T22_3_5 : forall e Γ S C σ T n m,
    Γ |-- n ` e \in S | m ` C ->
    subst_type σ S = T -> Constrais_sol_bool σ C = true ->
    subst_type_list σ Γ |- subst_type_term σ e \in T.
Proof.
  induction e; simpl; intros; auto.
  -
    rewrite <- H0.
    inversion H; subst.
    assert (Var n = subst_type_term σ (Var n)). reflexivity.
    rewrite H0.
    apply T22_1_2. constructor; auto.
  -
    inversion H; subst.
    eapply IHe in H10; eauto.
    constructor. apply H10.
  -
    inversion H; subst.
    simpl in H1.
    destruct eqb_ty eqn:IH1; try discriminate.
    apply eqb_ty_eq in IH1; subst.
    apply Constrais_sol_bool_app in H1. destruct H1.
    econstructor; eauto.
  -
    inversion H; subst. simpl. constructor.
  -
    inversion H; subst. simpl. constructor.
  -
    inversion H; subst. simpl in H1.
    destruct eqb_ty eqn:IH1; try discriminate.
    apply eqb_ty_eq in IH1; subst.
    destruct eqb_ty eqn:IH2; try discriminate.
    apply eqb_ty_eq in IH2; subst.
    apply Constrais_sol_bool_app in H1. destruct H1.
    apply Constrais_sol_bool_app in H1; destruct H1.
    constructor; eauto.
Qed.

Lemma app_Constrais_sol_bool : forall σ C1 C2,
    Constrais_sol_bool σ C1 = true -> Constrais_sol_bool σ C2 = true ->
    Constrais_sol_bool σ (C1 ++ C2) = true.
Proof.
  induction C1; simpl; intros; auto.
  destruct a. destruct eqb_ty; try discriminate.
  apply IHC1; auto.
Qed.

Lemma getbind_sub : forall σ Γ n T S,
  getbinding n (subst_type_list σ Γ) = Some T ->
  getbinding n Γ = Some S ->
  subst_type σ S = T.
Proof.
  induction Γ; simpl; intros.
  -
    destruct n; discriminate.
  -
    destruct n; simpl in H, H0.
    inversion H0; subst. inversion H; subst. reflexivity.
    eapply IHΓ; eauto.
 Qed.

Fixpoint max_sigma n (σ: list (nat * ty) ) :=
  match σ with
  | nil => n
  | (m, _):: rest =>
    let x := if ltb n m then m else n in
    max_sigma x rest
  end.

Lemma CT_n_lt : forall e Γ n typ m C,
    Γ |-- n ` e \in typ | m ` C -> n <= m.
Proof.
  intros. induction H; auto.
  -
    eapply le_trans with (p:= F'') in IHConstrait_Type1; eauto.
  -
    eapply le_trans with (p:= F2) in IHConstrait_Type1; eauto.
    eapply le_trans with (p:= F3) in IHConstrait_Type1; eauto.
Qed.

Fixpoint dom_sigma_in n (σ :list (nat * ty)) :=
  match σ with
  | nil => false
  | (m, _) :: rest => if eqb n m then true else dom_sigma_in n rest
  end.

Fixpoint dom_sigma_in_range n m σ :=
  match m with
  | 0 => false
  | S m' => dom_sigma_in (S n) σ || dom_sigma_in_range (S n) m' σ
  end.

Lemma dom_sigma_range_correct : forall m n σ,
    dom_sigma_in_range n m σ = false ->
    (forall x, n <= S x -> x <= (n + m) -> dom_sigma_in x σ = false).
Proof.
Abort.

Fixpoint subst_type_opt l t n m :=
  match t with
  | Bool => Some Bool
  | TyVar x =>
    if ltb n x && leb x m then None
    else Some (match_natlist l x t)
  | t1 |--> t2 =>
    match subst_type_opt l t1 n m , subst_type_opt l t2 n m with
    | Some ty1, Some ty2 => Some (ty1 |--> ty2)
    | _, _ => None
    end
  end.

Fixpoint opt_subst_type_list σ Γ n m :=
  match Γ with
  | nil => Some nil
  | h :: t =>
    match subst_type_opt σ h n m with
    | Some h' =>
      match opt_subst_type_list σ t n m with
      | Some t' => Some (h' :: t')
      | None => None
      end
    | None => None
    end
  end.

Fixpoint opt_subst_type_term σ e n m :=
  match e with
  | Abs x typ e1 =>
    match subst_type_opt σ typ n m, opt_subst_type_term σ e1 n m with
    | Some ty', Some e' => Some (Abs x ty' e')
    | _, _ => None
    end
  | App e1 e2 =>
    match opt_subst_type_term σ e1 n m, opt_subst_type_term σ e2 n m with
    | Some e1', Some e2' => Some (App e1' e2')
    | _, _ => None
    end
  | If e1 e2 e3 =>
    match opt_subst_type_term σ e1 n m, opt_subst_type_term σ e2 n m, opt_subst_type_term σ e3 n m with
    | Some e1', Some e2', Some e3' => Some (If e1' e2' e3')
    | _, _, _ => None
    end
  | _ => Some e
  end.

Lemma subst_type_opt_refl : forall σ typ n,
    subst_type_opt σ typ n n = Some (subst_type σ typ).
Proof.
  induction typ; simpl; intros; auto.
  -
    rewrite IHtyp1, IHtyp2. reflexivity.
  -
    destruct ltb eqn:IH1; simpl; auto.
    apply ltb_lt in IH1. apply leb_gt in IH1. rewrite IH1. reflexivity.
Qed.

Lemma opt_subst_type_term_refl : forall σ e n,
    opt_subst_type_term σ e n n = Some (subst_type_term σ e).
Proof.
  induction e; simpl; intros; eauto.
  -
    rewrite IHe. rewrite subst_type_opt_refl. reflexivity.
  -
    rewrite IHe1, IHe2. reflexivity.
  -
    rewrite IHe1, IHe2, IHe3. reflexivity.
Qed.

Lemma opt_subst_type_list_refl : forall σ Γ n,
    opt_subst_type_list σ Γ n n = Some (subst_type_list σ Γ).
Proof.
  induction Γ; simpl; intros; auto.
  rewrite IHΓ. rewrite subst_type_opt_refl. reflexivity.
Qed.

Lemma opt_to_subst_type : forall typ σ n m t',
    subst_type_opt σ typ n m = Some t' ->
    subst_type σ typ = t'.
Proof.
  induction typ; simpl; intros; auto.
  -
    inversion H; subst; auto.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    apply IHtyp1 in IH1.
    destruct subst_type_opt eqn:IH2; try discriminate.
    apply IHtyp2 in IH2.
    inversion H; subst.
    reflexivity.
  -
    destruct ltb; simpl in H.
    destruct leb; try discriminate.
    inversion H; subst. reflexivity.
    inversion H; subst. reflexivity.
Qed.

Lemma opt_to_subst_list : forall l σ n m l',
    opt_subst_type_list σ l n m = Some l' ->
    subst_type_list σ l = l'.
Proof.
  induction l; simpl; intros; auto.
  -
    inversion H; subst. reflexivity.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    destruct opt_subst_type_list eqn:IH2; try discriminate.
    apply opt_to_subst_type in IH1.
    inversion H; subst.
    apply IHl in IH2. rewrite IH2.
    reflexivity.
Qed.

Lemma opt_to_subst_term : forall e σ n m e',
    opt_subst_type_term σ e n m = Some e' ->
    subst_type_term σ e = e'.
Proof.
  induction e; simpl; intros; try solve [inversion H; subst; reflexivity].
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    apply opt_to_subst_type in IH1.
    destruct opt_subst_type_term eqn:IH2; try discriminate.
    apply IHe in IH2. inversion H; subst.
    reflexivity.
  -
    destruct opt_subst_type_term eqn:IH1; try discriminate.
    apply IHe1 in IH1.
    destruct opt_subst_type_term eqn:IH2; try discriminate.
    apply IHe2 in IH2.
    inversion H; subst. reflexivity.
  -
    destruct opt_subst_type_term eqn:IH1; try discriminate.
    apply IHe1 in IH1.
    destruct opt_subst_type_term eqn:IH2; try discriminate.
    apply IHe2 in IH2.
    destruct opt_subst_type_term eqn:IH3; try discriminate.
    apply IHe3 in IH3.
    inversion H; subst; reflexivity.
Qed.

Lemma dom_notin_app : forall σ1 σ2 n,
    dom_sigma_in n σ1 = false ->
    dom_sigma_in n σ2 = false ->
    dom_sigma_in n (σ1 ++ σ2) = false.
Proof.
  induction σ1; simpl; intros; auto.
  destruct a. destruct eqb; try discriminate.
  apply IHσ1; auto.
Qed.

Lemma dom_notin_app_eq : forall ad n σ,
    dom_sigma_in n ad = false ->
    match_natlist σ n (TyVar n) = match_natlist (ad ++ σ) n (TyVar n).
Proof.
  induction ad; simpl; intros.
  -
    reflexivity.
  -
    destruct a. destruct eqb eqn:IH; try discriminate.
    apply IHad with (σ := σ) in H; eauto.
    rewrite eqb_sym. rewrite IH. rewrite H. reflexivity.
Qed.

Lemma subst_type_opt_m : forall ty1 n m x σ ty2,
    x <= m ->
    subst_type_opt σ ty1 n m = Some ty2 ->
    subst_type_opt σ ty1 n x = Some ty2.
Proof.
  induction ty1; simpl; intros; auto.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    eapply IHty1_1 in IH1; eauto.
    destruct subst_type_opt eqn:IH2; try discriminate.
    eapply IHty1_2 in IH2; eauto.
    inversion H0; inversion IH1; inversion IH2; subst.
    rewrite IH1, IH2. reflexivity.
  -
    destruct ltb eqn:IH1; destruct leb eqn:IH2; try discriminate;
      simpl in H0; inversion H0; subst; try rewrite andb_false_l; auto.
    apply ltb_lt in IH1. apply leb_gt in IH2.
    apply le_lt_trans with (p:= n) in H; auto.
    apply leb_gt in H. rewrite H. simpl. reflexivity.
Qed.

Lemma opt_subst_type_list_m : forall l n m x σ l',
    x <= m ->
    opt_subst_type_list σ l n m = Some l' ->
    opt_subst_type_list σ l n x = Some l'.
Proof.
  induction l; simpl; auto; intros.
  destruct subst_type_opt eqn:IH1; try discriminate.
  eapply subst_type_opt_m in IH1; eauto. rewrite IH1.
  destruct opt_subst_type_list eqn:IH2; try discriminate.
  eapply IHl in IH2; eauto. rewrite IH2.
  apply H0.
Qed.

Lemma opt_subst_type_term_m : forall e n m x σ e',
    x <= m ->
    opt_subst_type_term σ e n m = Some e' ->
    opt_subst_type_term σ e n x = Some e'.
Proof.
  induction e; simpl; intros; auto.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    erewrite subst_type_opt_m; eauto.
    destruct opt_subst_type_term eqn:IH2; try discriminate.
    erewrite IHe; eauto.
  -
    destruct opt_subst_type_term eqn:IH1; try discriminate.
    erewrite IHe1; eauto; clear IH1.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe2; eauto.
  -
    destruct opt_subst_type_term eqn:IH1; try discriminate.
    erewrite IHe1; eauto; clear IH1.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe2; eauto; clear IH.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe3; eauto; clear IH.
Qed.

Lemma subst_type_opt_n : forall ty1 n m x σ ty2,
    n <= x <= m ->
    subst_type_opt σ ty1 n m = Some ty2 ->
    subst_type_opt σ ty1 x m = Some ty2.
Proof.
  induction ty1; simpl; intros; auto.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    eapply IHty1_1 in IH1; eauto.
    destruct subst_type_opt eqn:IH2; try discriminate.
    eapply IHty1_2 in IH2; eauto.
    inversion H0; inversion IH1; inversion IH2; subst.
    rewrite IH1, IH2. reflexivity.
  -
    destruct ltb eqn:IH1.
    +
      destruct leb eqn:IH2; try discriminate.
      simpl in H0. inversion H0; subst.
      apply ltb_lt in IH1. apply leb_gt in IH2.
      destruct H.
      apply le_lt_trans with (p:= n) in H1; auto. apply ltb_lt in H1.
      rewrite H1. simpl. reflexivity.
    +
      rewrite andb_false_l in H0. inversion H0; subst.
      destruct H. apply ltb_ge in IH1.
      apply le_trans with (p:= x) in IH1; auto.
      apply ltb_ge in IH1. rewrite IH1.
      rewrite andb_false_l. reflexivity.
Qed.

Lemma subst_list_opt_n : forall l n m x σ l0,
    n <= x <= m ->
    opt_subst_type_list σ l n m = Some l0 ->
    opt_subst_type_list σ l x m = Some l0.
Proof.
  induction l; simpl; intros; auto.
  destruct subst_type_opt eqn:IH1; try discriminate.
  destruct opt_subst_type_list eqn:IH2; try discriminate.
  eapply subst_type_opt_n in IH1; eauto. rewrite IH1.
  eapply IHl in IH2; eauto. rewrite IH2.
  inversion H; subst; auto.
Qed.

Lemma subst_term_opt_n : forall e n m x σ e0,
    n <= x <= m ->
    opt_subst_type_term σ e n m = Some e0 ->
    opt_subst_type_term σ e x m = Some e0.
Proof.
  induction e; simpl; intros; auto.
  -
    destruct subst_type_opt eqn:IH1; try discriminate.
    erewrite subst_type_opt_n; eauto.
    destruct opt_subst_type_term eqn:IH2; try discriminate.
    erewrite IHe; eauto.
  -
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe1; eauto; clear IH.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe2; eauto; clear IH.
  -
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe1; eauto; clear IH.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe2; eauto; clear IH.
    destruct opt_subst_type_term eqn:IH; try discriminate.
    erewrite IHe3; eauto; clear IH.
Qed.

Lemma dom_in_app : forall σ1 σ2 n typ,
    dom_sigma_in n σ1 = true ->
    match_natlist (σ1 ++ σ2) n typ = match_natlist σ1 n typ.
Proof.
  induction σ1; simpl; intros; auto.
  -
    inversion H; subst.
  -
    destruct a. rewrite eqb_sym. destruct eqb; auto.
Qed.

Lemma subst_type_eq_add : forall t1 σ1 σ2 ad,
    subst_type σ1 t1 = subst_type σ2 t1 ->
    subst_type (ad ++ σ1) t1 = subst_type (ad ++ σ2) t1.
Proof.
  induction t1; simpl; intros; auto.
  -
    inversion H; subst.
    erewrite IHt1_1, IHt1_2; eauto.
  -
    induction ad; simpl; auto.
    destruct a.
    rewrite IHad. reflexivity.
Qed.

Lemma max_tyvar_app : forall e1 e2 m n,
    max_tyvar_term n (App e1 e2) < m ->
    max_tyvar_term n e1 < m /\ max_tyvar_term n e2 < m.
Proof.
  simpl; intros.
  destruct ltb eqn:IH.
  apply ltb_lt in IH. split; auto. eapply lt_trans; eauto.
  apply ltb_ge in IH. apply le_lt_trans with (p:= m) in IH; auto.
Qed.

Lemma max_tyvar_abs : forall e1 t1 m n x,
    max_tyvar_term n ( Abs x t1 e1 ) < m ->
    max_tyvar_term n e1 < m /\ max_tyvar_type n t1 < m.
Proof.
  simpl; intros.
  destruct ltb eqn:IH.
  apply ltb_lt in IH. split; auto. eapply lt_trans; eauto.
  apply ltb_ge in IH. split; auto. eapply le_lt_trans; eauto.
Qed.

Lemma max_tyvar_if : forall e1 e2 e3 m n ,
    max_tyvar_term n ( If e1 e2 e3 ) < m ->
    max_tyvar_term n e1 < m /\ max_tyvar_term n e2 < m /\ max_tyvar_term n e3 < m.
Proof.
  simpl; intros.
  destruct (ltb (max_tyvar_term n e1) (max_tyvar_term n e2) ) eqn:IH1.
  -
    apply ltb_lt in IH1. destruct ltb eqn:IH2.
    ++
      apply ltb_lt in IH2.
      repeat split; auto. eapply lt_trans in IH2; eauto.
      eapply lt_trans; eauto.
      eapply lt_trans; eauto.
    ++
      apply ltb_ge in IH2.
      repeat split; auto.
      eapply lt_trans; eauto.
      eapply le_lt_trans in H; eauto.
  -
    apply ltb_ge in IH1. destruct ltb eqn:IH2.
    +
      apply ltb_lt in IH2.
      repeat split; auto.
      eapply lt_trans; eauto.
      apply le_lt_trans with (p:= max_tyvar_term n e3) in IH1; auto.
      apply lt_le_trans with (p:=m) in IH1; auto.
      apply lt_le_incl; auto.
    +
      apply ltb_ge in IH2.
      repeat split; auto.
      eapply le_lt_trans; eauto.
      eapply le_lt_trans; eauto.
Qed.

Lemma max_tyvar_list_lt : forall Γ n m,
    max_tyvar_list n Γ < m ->
    n < m.
Proof.
  induction Γ; intros; auto.
  simpl in H.
  destruct ltb eqn:IH; eauto.
  apply ltb_lt in IH.
  eapply IHΓ in H. eapply lt_trans; eauto.
Qed.

Lemma max_list_getbind : forall Γ m typ n x,
    max_tyvar_list x Γ < m ->
    getbinding n Γ = Some typ ->
    tyn_in_type m typ = false.
Proof.
  induction Γ; intros; auto.
  -
    destruct n; simpl in H0; try discriminate.
  -
    destruct n; simpl in H0.
    inversion H0; subst; clear H0.
    simpl in H.
    destruct ltb eqn:IH1.
    apply max_tyvar_list_lt in H.
    apply Smax_tyvar_type_is_not_in with x; auto.
    apply ltb_ge in IH1.
    apply max_tyvar_list_lt in H.
    apply Smax_tyvar_type_is_not_in with x; auto.
    apply le_lt_trans with x; auto.
    eapply IHΓ in H0; eauto.
Qed.

Lemma max_type_ch : forall t1 n m x,
    n < m < x ->
    max_tyvar_type n t1 < x ->
    max_tyvar_type m t1 < x.
Proof.
  induction t1; simpl; intros; auto.
  -
    destruct H; auto.
  -
    destruct (ltb (max_tyvar_type n t1_1) (max_tyvar_type n t1_2) ) eqn:IH1.
    apply ltb_lt in IH1.
    destruct ltb eqn:IH2; auto.
    eapply IHt1_2 in H0; eauto.
    apply ltb_ge in IH2.
    apply IHt1_1 with n; auto.
    eapply lt_trans; eauto.

    apply ltb_ge in IH1.
    destruct ltb eqn:IH2; eauto.
    apply ltb_lt in IH2.
    apply IHt1_2 with n; auto.
    eapply le_lt_trans; eauto.
  -
    destruct H.
    destruct (n0 <? n) eqn:IH1.
    apply ltb_lt in IH1.
    destruct ltb; auto.
    apply ltb_ge in IH1.
    apply le_lt_trans with (p:= x) in IH1; auto.
    destruct ltb; auto.
Qed.

Lemma max_list_ch : forall Γ n m x,
    n < m < x ->
    max_tyvar_list n Γ < x ->
    max_tyvar_list m Γ < x.
Proof.
  induction Γ; simpl; intros; destruct H; auto.
  destruct ltb eqn:IH1.
  -
    apply ltb_lt in IH1.
    destruct ltb eqn:IH2.
    +
      apply ltb_lt in IH2.
      generalize H0; intros.
      apply max_tyvar_list_n_lt_m in H0.
      generalize max_type_ch; intros.
      eapply IHΓ; eauto.
      destruct (ltb (max_tyvar_type n a) m) eqn:IH.
      apply ltb_lt in IH.
      eapply IHΓ with (max_tyvar_type n a); auto.
      apply ltb_ge in IH.
Admitted.

Lemma max_list_app : forall Γ m G x,
    max_tyvar_list x Γ < m ->
    max_tyvar_list x G < m ->
    max_tyvar_list x (Γ ++ G) < m.
Proof.
  induction Γ; intros; auto.
  simpl. simpl in H.
  destruct ltb eqn:IH.
  apply ltb_lt in IH.
  generalize H; intros.
  apply IHΓ; auto.
  apply max_list_ch with x; auto.
  split; auto. apply max_tyvar_list_n_lt_m in H.
  apply H.
  apply IHΓ; eauto.
Qed.

Lemma CT_nont : forall e Γ n m T C,
    Γ |-- n ` e \in T | m ` C ->
    max_tyvar_list 0 Γ < n ->
    max_tyvar_term 0 e < n ->
    forall x, m <= x -> tyn_in_type x T = false.
Proof.
  intros. generalize dependent x. induction H; simpl; intros; auto.
  -
    eapply max_list_getbind; eauto.
    apply lt_le_trans with F; eauto.
  -
    apply CT_n_lt in H.
    apply orb_false_iff. apply max_tyvar_abs in H1. destruct H1.
    split; auto.
    eapply Smax_tyvar_type_is_not_in.
    apply lt_le_trans with F'; eauto.
    apply lt_le_trans with F; eauto.
    apply IHConstrait_Type; auto.
    assert (T1 :: Γ = [T1] ++ Γ); auto.
    rewrite H4.
    apply max_list_app; auto.
    simpl. destruct ltb; auto.
    apply max_tyvar_list_n_lt_m in H0. apply H0.
  -
    apply eqb_neq. intro.
    subst. apply nle_succ_diag_l in H3. apply H3.
  -
    apply CT_n_lt in H, H2, H3.
    apply max_tyvar_if in H1.
    destruct H1. destruct H5.
    apply IHConstrait_Type3; auto.
    apply lt_le_trans with F; auto.
    apply le_trans with F1; auto.
    apply lt_le_trans with F; auto.
    apply le_trans with F1; auto.
Qed.

Fixpoint ext_sigma (σ: list (nat * ty)) n m :=
  match σ with
  | nil => nil
  | (x, t1) :: rest =>
    if (n <? x) && (x <=? m) then (x, t1) :: (ext_sigma rest n m)
    else ext_sigma rest n m
  end.

Theorem T22_3_7 : forall e Γ S1 C σ T n m,
    max_tyvar_list 0 Γ < n ->
    max_tyvar_term 0 e < n ->
    subst_type_list σ Γ |- subst_type_term σ e \in T ->
    Γ |-- n ` e \in S1 | m ` C ->
    (forall x, n < x <= m -> dom_sigma_in x σ = false) ->
    exists σ', (forall typ, subst_type_opt σ' typ n m = Some (subst_type σ typ)) /\
    subst_type σ' S1 = T /\ Constrais_sol_bool σ' C = true.
Proof.
  intros. generalize dependent σ. generalize dependent T.
  induction H2; simpl; intros; auto.
  -
    inversion H2; subst. exists σ. repeat split;  intros; auto.
    apply subst_type_opt_refl.
    eapply getbind_sub; eauto.
  -
    inversion H1; subst.
    apply max_tyvar_abs in H0. destruct H0.
    eapply IHConstrait_Type in H9; eauto; clear IHConstrait_Type.
    destruct H9. destruct H5. destruct H6.
    exists x0. repeat split; intros; auto. rewrite H6.
    admit.
    simpl.
    destruct ltb eqn:IH; auto.
    admit.
  -
    inversion H1; subst.
    eapply IHConstrait_Type1 in H6; eauto; clear IHConstrait_Type1.
    eapply IHConstrait_Type2 in H8; eauto; clear IHConstrait_Type2.
    destruct H6. destruct H2. destruct H4.
    destruct H8. destruct H6; destruct H7.
    admit. admit. admit. admit. admit. admit.
  -
    exists σ. inversion H1; subst; repeat split; intros; auto.
    apply subst_type_opt_refl.
  -
    exists σ. inversion H1; subst; repeat split; intros; auto.
    apply subst_type_opt_refl.
  -
    inversion H1; subst.
    apply CT_n_lt in H2_, H2_0, H2_1.
    eapply IHConstrait_Type1 in H7; eauto; clear IHConstrait_Type1.
    eapply IHConstrait_Type2 in H9; eauto; clear IHConstrait_Type2.
    eapply IHConstrait_Type3 in H10; eauto; clear IHConstrait_Type3.
    destruct H7. destruct H2. destruct H4.
    destruct H9. destruct H6. destruct H7.
    destruct H10. destruct H9. destruct H10.
Abort.


Require Import Problem PeanoNat Nat.

Lemma plus_decomp (m n : nat) (f : nat -> nat) (x : nat)
  : iter (m + n) f x = iter m f (iter n f x).
Proof.
  induction m; simpl; auto.
Qed.

Lemma mult_decomp (m n : nat) (f : nat -> nat) (x : nat)
  : iter (m * n) f x = iter m (iter n f) x.
Proof.
  induction m; simpl; [auto|].
  rewrite plus_decomp; auto.
Qed.

Lemma beta (n y : nat) (f g : nat -> nat)
  : (forall x, f x = g x) -> iter n f y = iter n g y.
Proof.
  intros.
  induction n; [auto|].
  simpl; rewrite IHn; auto.
Qed.

Theorem solution: task.
Proof.
  unfold task.
  induction n; [auto|].
  intros; simpl.
  rewrite mult_decomp.
  apply beta.
  auto.
Qed.