(** Cantor's pairing function
    (Originally  Russel O'Connors [goedel] contrib  *)

Require Import Arith Coq.Lists.List .
From hydras Require Import extEqualNat primRec.
From hydras Require Import Compat815.
Import Nat.

(**  * Bijection from [nat * nat] to [nat] *)

(** ** Preliminary definitions *)

(** Sum of all natural numbers upto [n] *)

(* begin snippet sumToNDef:: no-out *)
Definition sumToN (n : nat) :=
  nat_rec (fun _ => nat) 0 (fun x y : nat => S x + y) n.
(* end snippet sumToNDef *)

(* begin snippet sumToN1:: no-out *)
Lemma sumToN1 n : n <= sumToN n.
(* end snippet sumToN1 *)
Proof.
  induction n as [| n Hrecn]; [trivial |];
    simpl in |- *; apply le_n_S, Nat.le_add_r.
Qed.

(* begin snippet sumToN2:: no-out *)
Lemma sumToN2 b a :  a <= b -> sumToN a <= sumToN b.
(* end snippet sumToN2 *)
Proof.
  revert a; induction b as [| b Hrecb]; intros.
  - simpl in |- *; rewrite  (Nat.le_0_r a) in H; now subst.
  - rewrite  Nat.lt_eq_cases in H; destruct H as [H | H].
    + transitivity (sumToN b).
      * apply Hrecb; auto.
        apply Compat815.lt_n_Sm_le; auto.
      * cbn in |- *; apply le_S; rewrite Nat.add_comm.
        apply le_add_r.
    + subst a; reflexivity.
Qed.

(* begin snippet sumToNPR:: no-out *)
Lemma sumToNIsPR : isPR 1 sumToN.
Proof.
  unfold sumToN in |- *.
  apply indIsPR with (f := fun x y : nat => S x + y).
  apply compose2_2IsPR
    with (f := fun x y : nat => S x)
         (g := fun x y : nat => y)
         (h := plus).
  - apply filter10IsPR, succIsPR.
  - apply pi2_2IsPR.
  - apply plusIsPR.
Qed.
(* end snippet sumToNPR *)

(** ** Definition and properties of [cPair] *)

(**  The [cPair] function defined below is slightly different
     from the "usual" Cantor pairing function shown in  a big part
     of the litterature (and Coq's standard library).
      Since both versions are equivalent upto a swap of the
      rguments [a] and [b], we still use  Russel O'Connors notations *)

(* begin snippet cPairDef *)
Definition cPair (a b : nat) := a + sumToN (a + b).

Compute cPair 4 0.
(* end snippet cPairDef *)

(* begin snippet cPairIsPR:: no-out *)
Lemma cPairIsPR : isPR 2 cPair.
Proof.
  unfold cPair; apply compose2_2IsPR
    with
    (f := fun x y : nat => x)
    (g := fun x y : nat => sumToN (x + y))
    (h := plus).
  - apply pi1_2IsPR.
  - apply compose2_1IsPR; [apply plusIsPR | apply sumToNIsPR].
  - apply plusIsPR.
Qed.
(* end snippet cPairIsPR *)

Section CPair_Injectivity.

  Remark cPairInjHelp :
    forall a b c d : nat, cPair a b = cPair c d -> a + b = c + d.
  Proof.
    assert (H: forall a b : nat, a < b -> a + sumToN a < sumToN b).
    {
      simple induction b.
      - intros H; elim (Nat.nlt_0_r _ H).
      -  intros n H H0; simpl in |- *.
         assert (H1: a <= n)
         by (apply Compat815.lt_n_Sm_le; assumption).
         rewrite Nat.lt_eq_cases in H1; destruct H1.
        +  apply Nat.lt_trans with (sumToN n).
            * auto.
            * apply Compat815.le_lt_n_Sm.
              rewrite Nat.add_comm; apply le_add_r.
            +  rewrite H1.
               apply Nat.lt_succ_diag_r .
    }
    unfold cPair in |- *;
    assert
      (H0: forall a b c d : nat,
          a <= c -> b <= d -> a + sumToN c = b + sumToN d -> c = d).
    { intros a b c d H0 H1 H2; induction (le_gt_cases c d).
      - induction (Compat815.le_lt_or_eq _ _ H3).
        + assert (H5: a + sumToN c < sumToN d).
          { apply Nat.le_lt_trans with (c + sumToN c); [| auto].
            now apply Nat.add_le_mono_r; auto.
          }
          rewrite H2 in H5; elim (Compat815.lt_not_le _ _ H5).
          rewrite Nat.add_comm;apply le_add_r.
        + auto.
      - assert (H4: b + sumToN d < sumToN c).
      { apply Nat.le_lt_trans with (d + sumToN d).
        - apply Nat.add_le_mono_r; auto.
        - auto.
      }
      rewrite <- H2 in H4;  elim (Compat815.lt_not_le _ _ H4).
      rewrite add_comm; apply le_add_r.
    }
    intros; eapply H0.
    - apply Nat.le_add_r.
    - apply Nat.le_add_r.
    - auto.
  Qed.

  (* begin snippet cPairInj1:: no-out *)
  Lemma cPairInj1 a b c d: cPair a b = cPair c d -> a = c.
  (* end snippet cPairInj1 *)
  Proof.
    intro H; assert (H0: a + b = c + d)
      by (apply cPairInjHelp; auto).
    unfold cPair in H; rewrite (Nat.add_comm a) in H;
      rewrite (Nat.add_comm c) in H.
    rewrite H0 in H; now rewrite Nat.add_cancel_l in H.
  Qed.

  (* begin snippet cPairInj2:: no-out *)
  Lemma cPairInj2  a b c d : cPair a b = cPair c d -> b = d.
  (* end snippet cPairInj2 *)
  Proof.
    intro H;  assert (H0: a + b = c + d) by
      ( apply cPairInjHelp; auto ).
    assert (H1: a = c) by (eapply cPairInj1; apply H).
    rewrite H1 in H0; now rewrite Nat.add_cancel_l in H0.
  Qed.

End CPair_Injectivity.

Section CPair_projections.

  (* @todo document boundedSearch *)

  (* begin snippet searchXY *)
  Let searchXY (a : nat) :=
        boundedSearch (fun a y : nat => ltBool a (sumToN (S y))) a.
  (* end snippet searchXY *)

  (* begin snippet cPairPi12 *)
  Definition cPairPi1 (a : nat) := a - sumToN (searchXY a).
  Definition cPairPi2 (a : nat) := searchXY a - cPairPi1 a.
  (* end snippet cPairPi12 *)

Lemma cPairProjectionsHelp (a b: nat):
  b < sumToN (S a) -> sumToN a <= b -> searchXY b = a.
Proof.
  intros H H0; unfold searchXY in |- *.
  induction (boundedSearch2 (fun b y : nat => ltBool b (sumToN (S y))) b).
  - rewrite H1.
    induction (eq_nat_dec b a).
    + auto.
    + elim (ltBoolFalse b (sumToN (S a))).
      * apply (boundedSearch1
                 (fun b y : nat => ltBool b (sumToN (S y))) b).
        rewrite H1.
        destruct (Nat.lt_gt_cases b a) as [H2 _]; specialize (H2 b0);
          destruct H2 as [H2 | H2].
        -- rewrite Nat.lt_nge in H2. destruct H2.
           apply Nat.le_trans with (sumToN a).
           apply sumToN1.
           auto.
        -- auto.
      * auto.
  - set (c := boundedSearch (fun b y : nat => ltBool b (sumToN (S y))) b) in *.
    induction (eq_nat_dec c a).
    + auto.
    + elim (ltBoolFalse b (sumToN (S a))).
      apply (boundedSearch1 (fun b y : nat => ltBool b (sumToN (S y))) b).
      fold c in |- *.
      rewrite lt_gt_cases in b0; destruct b0 as [H2 | H2]; [trivial|].
      rewrite Nat.le_ngt in H0; destruct H0.
      * apply Nat.lt_le_trans with (sumToN (S c)).
        -- apply ltBoolTrue.
           auto.
        -- assert (S c <= a).
           { apply Compat815.lt_n_Sm_le.
             now rewrite <- Nat.succ_lt_mono.
           } apply sumToN2; auto.
      * assumption.
      * assumption.
Qed.

(* begin snippet cPairProjections:: no-out *)
Lemma cPairProjections a: cPair (cPairPi1 a) (cPairPi2 a) = a.
(* end snippet cPairProjections *)
Proof.
  revert a; assert (H:
        forall a b : nat, b < sumToN a ->
                          cPair (cPairPi1 b) (cPairPi2 b) = b).
  { intros a b H; induction a as [| a Hreca].
    - simpl in H; elim (Nat.nlt_0_r _ H).
    - induction (Nat.le_gt_cases (sumToN a) b).
     assert (searchXY b = a)
       by (apply cPairProjectionsHelp; auto).
      unfold cPair in |- *.
      replace (cPairPi1 b + cPairPi2 b) with a.
      unfold cPairPi1 in |- *.
      rewrite H1; now rewrite Nat.sub_add.
      unfold cPairPi2 in |- *.
      rewrite H1, Nat.add_comm,  Nat.sub_add.
      auto.
      unfold cPairPi1 in |- *.
      rewrite H1.
      simpl in H.
      erewrite Nat.add_le_mono_l.
      rewrite Nat.add_comm, sub_add.

      apply Compat815.lt_n_Sm_le; auto.
      rewrite add_comm;  apply H; auto.
      auto.
      apply Hreca.
      auto.
  }
  intros a; apply H with (S a).
  apply Nat.lt_le_trans with (S a).
  apply Nat.lt_succ_diag_r .
  apply sumToN1.
Qed.

Remark searchXYIsPR : isPR 1 searchXY.
Proof.
  unfold searchXY in |- *.
  apply boundSearchIsPR with (P := fun a y : nat => ltBool a (sumToN (S y))).
  unfold isPRrel in |- *.
  apply
    compose2_2IsPR
    with
    (h := charFunction 2 ltBool)
    (f := fun a y : nat => a)
    (g := fun a y : nat => sumToN (S y)).
  - apply pi1_2IsPR.
  - apply filter01IsPR with (g := fun y : nat => sumToN (S y)).
    apply compose1_1IsPR.
    + apply succIsPR.
    + apply sumToNIsPR.
 - apply ltIsPR.
Qed.

(* begin snippet  cPairPi1IsPR:: no-out *)
Lemma cPairPi1IsPR : isPR 1 cPairPi1.
(* end snippet  cPairPi1IsPR *)
Proof.
  unfold cPairPi1 in |- *.
  apply compose1_2IsPR
  with
    (g := minus)
    (f := fun x : nat => x)
    (f' := fun a : nat => sumToN (searchXY a)).
  - apply idIsPR.
  - apply compose1_1IsPR.
    + apply searchXYIsPR.
    + apply sumToNIsPR.
  - apply minusIsPR.
Qed.

(* begin snippet  cPairProjections1:: no-out *)
Lemma cPairProjections1 (a b : nat): cPairPi1 (cPair a b) = a.
(* end snippet  cPairProjections1 *)
Proof.
  unfold cPair, cPairPi1  in |- *.
  replace (searchXY (a + sumToN (a + b))) with (a + b).
  now rewrite Nat.add_sub.
  symmetry  in |- *; apply cPairProjectionsHelp.
  - simpl in |- *; apply Nat.lt_succ_r.
    apply Nat.add_le_mono_r, Nat.le_add_r.
  - rewrite (Nat.add_comm a (sumToN (a + b))); apply le_add_r.
Qed.

(* begin snippet  cPairProjections2:: no-out *)
Lemma cPairProjections2 (a b : nat): cPairPi2 (cPair a b) = b.
(* end snippet  cPairProjections2 *)
Proof.
  unfold cPairPi2 in |- *; rewrite cPairProjections1; unfold cPair in |- *.
  replace (searchXY (a + sumToN (a + b))) with (a + b).
  - rewrite Nat.add_comm; apply Nat.add_sub .
  - symmetry  in |- *; apply cPairProjectionsHelp; simpl in |- *.
    + rewrite Nat.lt_succ_r; apply Nat.add_le_mono_r, Nat.le_add_r.
    + rewrite (Nat.add_comm a (sumToN (a + b)));apply le_add_r.
Qed.

(* begin snippet  cPairPi2IsPR:: no-out *)
Lemma cPairPi2IsPR : isPR 1 cPairPi2.
(* end snippet  cPairPi2IsPR *)
Proof.
  unfold cPairPi2 in |- *.
  apply compose1_2IsPR with (g := minus) (f := searchXY) (f' := cPairPi1).
  - apply searchXYIsPR.
  - apply cPairPi1IsPR.
  - apply minusIsPR.
Qed.

End CPair_projections.

Section CPair_Order.

  (* begin snippet cPairLe1:: no-out *)
  Lemma cPairLe1 (a b : nat) : a <= cPair a b.
  (* end snippet cPairLe1 *)
  Proof. unfold cPair in |- *; apply Nat.le_add_r. Qed.

  (* begin snippet cPairLe1A:: no-out *)
  Lemma cPairLe1A (a : nat) : cPairPi1 a <= a.
  (* end snippet cPairLe1A *)
  Proof.
    transitivity (cPair (cPairPi1 a) (cPairPi2 a)).
    - apply cPairLe1.
    - rewrite cPairProjections; apply le_n.
  Qed.

  (* begin snippet cPairLe2:: no-out *)
  Lemma cPairLe2 ( a b : nat) : b <= cPair a b.
  (* end snippet cPairLe2 *)
  Proof.
    unfold cPair in |- *; eapply Nat.le_trans with (b + a).
    - apply Nat.le_add_r.
    - rewrite (Nat.add_comm b a); transitivity (sumToN (a + b)).
      + apply sumToN1.
      + rewrite (Nat.add_comm _ (sumToN (a + b))); apply le_add_r.
  Qed.

  (* begin snippet cPairLe2A:: no-out *)
  Lemma cPairLe2A (a: nat): cPairPi2 a <= a.
  (* end snippet cPairLe2A *)
  Proof.
    transitivity (cPair (cPairPi1 a) (cPairPi2 a)).
    - apply cPairLe2.
    - rewrite cPairProjections; apply le_n.
  Qed.

  (* begin snippet cPairLe3:: no-out *)
  Lemma cPairLe3 (a b c d : nat): a <= b -> c <= d -> cPair a c <= cPair b d.
  (* end snippet cPairLe3 *)
  Proof.
    intros H H0; unfold cPair in |- *;
      transitivity (a + sumToN (b + d)).
    - apply Nat.add_le_mono_l, sumToN2; transitivity (a + d).
      + now apply Nat.add_le_mono_l.
      + now apply Nat.add_le_mono_r.
    - now apply Nat.add_le_mono_r.
  Qed.

  (* begin snippet cPairLt1:: no-out *)
  Lemma cPairLt1 (a b : nat): a < cPair a (S b).
  (* end snippet cPairLt1 *)
  Proof.
    unfold cPair in |- *.
    rewrite (Nat.add_comm a (S b)); simpl in |- *.
    rewrite Nat.add_comm; simpl in |- *; rewrite Nat.add_comm.
    apply le_n_S, Nat.le_add_r.
  Qed.

  (* begin snippet cPairLt2:: no-out *)
  Lemma cPairLt2 (a b : nat): b < cPair (S a) b.
  (* end snippet cPairLt2 *)
  Proof.
    unfold cPair in |- *; simpl in |- *;
      unfold lt in |- *; apply le_n_S.
    eapply Nat.le_trans.
    - apply Nat.le_add_r.
    - rewrite Nat.add_comm at 1.
      apply Nat.add_le_mono_l.
      apply le_S.
      eapply Nat.le_trans.
      + apply Nat.le_add_r.
      + rewrite Nat.add_comm; apply Nat.le_add_r.
  Qed.

End CPair_Order.

Require Import Extraction.
Section code_nat_list.

(* begin snippet codeListDef:: no-out *)
Fixpoint codeList (l : list nat) : nat :=
  match l with
  | nil => 0
  | n :: l' => S (cPair n (codeList l'))
  end.
Compute codeList (3::1::nil).
Compute codeList (2::3::1::nil).
(* end snippet codeListDef *)

(* begin snippet codeListInj:: no-out *)
Lemma codeListInj (l m : list nat): codeList l = codeList m -> l = m.
Proof.
  (* ... *)
(* end snippet codeListInj *)

  revert m; induction l as [| a l Hrecl].
  - intros m H; destruct m as [| n l].
   + reflexivity.
   + discriminate H.
  - intros m H; destruct m as [| n l0].
    + discriminate H.
    + (* begin snippet codeListInja:: no-in unfold *)
      simpl in H.
      (* end snippet codeListInja *) replace n with a.
      * rewrite (Hrecl l0); [reflexivity |].
        eapply cPairInj2; apply eq_add_S, H.
      * eapply cPairInj1; apply eq_add_S, H.
Qed.

(* begin snippet codeNthDef:: no-out  *)

Definition codeNth (n m:nat) : nat :=
  let X := nat_rec (fun _ : nat => nat)
             m
             (fun _ Hrecn : nat => cPairPi2 (pred Hrecn)) n
  in cPairPi1 (pred X).

(* end snippet codeNthDef *)

(** drops [n] first elements from [l] *)
Let drop (n : nat) : forall (l : list nat), list nat.
Proof.
  induction n as [| n Hrecn].
  - exact (fun l => l).
  - intros l; apply Hrecn; destruct l.
   + exact (nil (A:=nat)).
   + exact l.
Defined.

(* begin snippet codeNthCorrect:: no-out *)
Lemma codeNthCorrect :
  forall (n : nat) (l : list nat), codeNth n (codeList l) = nth n l 0.
(* end snippet codeNthCorrect *)
Proof.
  unfold codeNth in |- *.
  set
    (A :=
       fun l : list nat => match l with
                           | nil => nil (A:=nat)
                           | _ :: l0 => l0
                           end) in *.
  assert (H: forall l : list nat,
             cPairPi2 (pred (codeList l)) = codeList (A l)).
  { destruct l; simpl in |- *.
    apply (cPairProjections2 0 0).
    apply cPairProjections2.
  }
  assert
    (H0: forall (n : nat) (l : list nat),
        nat_rec (fun _ : nat => nat) (codeList l)
          (fun _ Hrecn : nat => cPairPi2 (pred Hrecn)) n =
          codeList (drop n l)).
  {
    simple induction n; simpl in |- *.
    reflexivity.
    intros n0 H0 l; rewrite H0, H.
    unfold A in |- *; clear H0; revert l.
    induction n0 as [| n0 Hrecn0]; simpl in |- *; intros.
    - reflexivity.
    - destruct l.
      + apply (Hrecn0 nil).
      + apply Hrecn0.
  }
  intros n l.
  replace (nth n l 0) with match drop n l with
                           | nil => 0
                           | a :: _ => a
                           end.
  rewrite H0; destruct (drop n l).
  + simpl in |- *; apply (cPairProjections1 0 0).
  + simpl in |- *;  apply cPairProjections1.
  + revert l; induction n as [| n Hrecn].
   * destruct l; reflexivity.
   * destruct l.
    -- simpl in Hrecn; destruct n; apply (Hrecn nil).
    -- simpl in |- *; auto.
Qed.

(* begin snippet codeNthIsPR:: no-out *)
Lemma codeNthIsPR : isPR 2 codeNth.
(* end snippet codeNthIsPR *)
Proof.
  unfold codeNth in |- *; apply compose2_1IsPR
    with
    (g := fun x : nat => cPairPi1 (pred x))
    (f := fun n m : nat =>
            nat_rec (fun _ : nat => nat) m
              (fun _ Hrecn : nat => cPairPi2 (pred Hrecn)) n).
  - apply ind1ParamIsPR
    with
    (g := fun m : nat => m)
    (f := fun _ Hrecn m : nat => cPairPi2 (pred Hrecn)).
    + apply filter010IsPR with (g := fun x : nat => cPairPi2 (pred x)).
      apply compose1_1IsPR.
      * apply predIsPR.
      * apply cPairPi2IsPR.
    + apply idIsPR.
  - apply compose1_1IsPR.
    + apply predIsPR.
    + apply cPairPi1IsPR.
Qed.

End code_nat_list.

Extraction codeNth.
Print codeNth.

Section Strong_Recursion.
(* begin snippet evalStrongRecDef *)
Definition evalStrongRecHelp (n : nat) (f : naryFunc (S (S n))) :
  naryFunc (S n) :=
  evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil _) (codeList nil))
    (evalComposeFunc (S (S n)) 2
       (Vector.cons _ f _
          (Vector.cons _ (evalProjFunc (S (S n)) n
                            (Nat.lt_lt_succ_r _ _
                               (Nat.lt_succ_diag_r  _))) _
             (Vector.nil _)))
       (fun a b : nat => S (cPair a b))).

Definition evalStrongRec (n : nat) (f : naryFunc (S (S n))) :
  naryFunc (S n) :=
  evalComposeFunc (S n) 1
    (Vector.cons _
       (fun z : nat => evalStrongRecHelp n f (S z)) _ (Vector.nil _))
    (fun z : nat => cPairPi1 (pred z)).
(* end snippet evalStrongRecDef *)

(* begin snippet evalStrongRecPR:: no-out *)
Lemma evalStrongRecIsPR (n : nat) (f : naryFunc (S (S n))) :
  isPR (S (S n))  f -> isPR (S n) (evalStrongRec n f).
(* end snippet evalStrongRecPR *)
Proof.
  intros; unfold evalStrongRec, evalStrongRecHelp in |- *.
  fold (naryFunc (S n)) in |- *.
  set
    (A :=
       evalPrimRecFunc n
         (evalComposeFunc n 0 (Vector.nil (naryFunc n)) (codeList nil))
         (evalComposeFunc (S (S n)) 2
            (Vector.cons (naryFunc (S (S n))) f 1
               (Vector.cons (naryFunc (S (S n)))
                  (evalProjFunc (S (S n)) n
                     (Nat.lt_lt_succ_r n (S n)
                        (Nat.lt_succ_diag_r  n))) 0
                  (Vector.nil (naryFunc (S (S n))))))
            (fun a b : nat => S (cPair a b))))
    in *.
  assert (H0: isPR (S n) A).
  { unfold A in |- *.
    assert (isPR 2 (fun a b : nat => S (cPair a b))).
    { apply compose2_1IsPR.
      apply cPairIsPR.
      apply succIsPR.
    }
    assert (H1: isPR 1 (fun z : nat => cPairPi1 (pred z))).
    { apply compose1_1IsPR.
      apply predIsPR.
      apply cPairPi1IsPR.
    }
    induction H as (x, p).
    induction H0 as (x0, p0).
    induction H1 as (x1, p1).
    exists
      (primRecFunc n (composeFunc n 0 (PRnil _) zeroFunc)
         (composeFunc (S (S n)) 2
            (PRcons _ _ x
               (PRcons _ _ (projFunc (S (S n)) n
                              (Nat.lt_lt_succ_r n (S n)
                                 (Nat.lt_succ_diag_r  n)))
                  (PRnil _))) x0)).
    apply
      extEqualTrans
      with
      (evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil _) 0)
         (evalComposeFunc (S (S n)) 2
            (Vector.cons _ (evalPrimRec _ x) _
               (Vector.cons _ (evalProjFunc (S (S n)) n
                                 (Nat.lt_lt_succ_r n (S n)
                                    (Nat.lt_succ_diag_r  n))) _
                  (Vector.nil _))) (evalPrimRec _ x0))).
    apply extEqualRefl.
    apply extEqualPrimRec.
    simpl in |- *.
    apply extEqualRefl.
    apply extEqualCompose.
    unfold extEqualVector, extEqualVectorGeneral, Vector.t_rect in |- *.
    repeat split; auto.
    apply extEqualRefl.
    auto.
  }
  assert (H1: isPR (S n) (fun z : nat => A (S z))).
  { apply compose1_NIsPR; auto.
    apply succIsPR.
  }
  clear H0; assert (H0: isPR 1 (fun z : nat => cPairPi1 (pred z))).
  { apply compose1_1IsPR.
    apply predIsPR.
    apply cPairPi1IsPR.
  }
  induction H0 as (x, p).
  induction H1 as (x0, p0).
  exists (composeFunc (S n) 1 (PRcons _ _ x0 (PRnil _)) x).
  simpl in |- *.
  fold (naryFunc n) in |- *.
  intros c; apply extEqualCompose.
  unfold extEqualVector in |- *.
  simpl in |- *; repeat split.
  - apply (p0 c).
  -  trivial.
Qed.

(* begin snippet computeEvalStrongRecHelp:: no-out *)
Lemma computeEvalStrongRecHelp :
  forall (n : nat) (f : naryFunc (S (S n))) (c : nat),
    evalStrongRecHelp n f (S c) =
      compose2 n (evalStrongRecHelp n f c)
        (fun a0 : nat =>
           evalComposeFunc n 2
             (Vector.cons (naryFunc n) (f c a0) 1
                (Vector.cons (naryFunc n) (evalConstFunc n a0) 0
                   (Vector.nil (naryFunc n))))
             (fun a1 b0 : nat => S (cPair a1 b0))).
(* end snippet computeEvalStrongRecHelp:: no-out *)
Proof.
  intros n f c; unfold evalStrongRecHelp at 1 in |- *; simpl in |- *.
  fold (naryFunc n) in |- *.
  induction (eq_nat_dec n (S n)).
  - destruct (neq_succ_diag_r n a).
  - induction (eq_nat_dec n n).
    + replace
        (evalPrimRecFunc n
           (evalComposeFunc n 0 (Vector.nil (naryFunc n)) 0)
           (fun a0 a1 : nat =>
              evalComposeFunc n 2
                (Vector.cons (naryFunc n) (f a0 a1) 1
                   (Vector.cons (naryFunc n)
                      (evalConstFunc n a1) 0 (Vector.nil (naryFunc n))))
                (fun a2 b0 : nat => S (cPair a2 b0))) c)
        with
        (evalStrongRecHelp n f c).
      reflexivity.
      unfold evalStrongRecHelp at 1 in |- *.
      simpl in |- *.
      fold (naryFunc n) in |- *.
      induction (eq_nat_dec n (S n)).
      elim b; auto.
      induction (eq_nat_dec n n).
      * reflexivity.
      * elim b1; auto.
    + elim b0; auto.
Qed.

Fixpoint listValues  (f : naryFunc 2) (n : nat) : list nat :=
  match n with
    0 => nil
  | S m => evalStrongRec _ f m :: listValues f m
  end.

Lemma evalStrongRecHelp1 :
 forall (f : naryFunc 2) (n m : nat),
   m < n ->
   codeNth (n - S m) (evalStrongRecHelp _ f n) = evalStrongRec _ f m.
Proof.
  assert
    (H: forall (f : naryFunc 2) (n : nat),
        evalStrongRecHelp _ f n = codeList (listValues f n)).
  {
    intros f n; induction n as [| n Hrecn].
    - simpl in |- *; unfold evalStrongRecHelp in |- *; simpl in |- *.
      reflexivity.
    - unfold evalStrongRecHelp in |- *; simpl in |- *;
        unfold evalStrongRecHelp in Hrecn; simpl in Hrecn; rewrite Hrecn.
      unfold evalStrongRec in |- *; simpl in |- *.
      now rewrite cPairProjections1, Hrecn.
  }
  intros f n m H0; rewrite H, codeNthCorrect.
  induction n as [| n Hrecn].
   - elim (Nat.nlt_0_r _ H0).
   - induction (Compat815.le_lt_or_eq _ _ H0).
     rewrite Nat.sub_succ_l; simpl in |- *.
     rewrite Hrecn.
     reflexivity.
     apply Nat.succ_lt_mono; auto.
     apply Compat815.lt_n_Sm_le; auto.
     inversion H1.
     rewrite  Nat.sub_diag; reflexivity.
Qed.

Lemma evalStrongRecHelpParam :
  forall (a n c : nat) (f : naryFunc (S (S (S a)))),
    extEqual a (evalStrongRecHelp (S a) f n c)
      (evalStrongRecHelp a (fun x y : nat => f x y c) n).
Proof.
  intros a n c f; unfold evalStrongRecHelp in |- *.
  eapply extEqualTrans.
  - apply extEqualSym.
    apply evalPrimRecParam.
  - assert
    (H: extEqual (S a)
       (evalPrimRecFunc a
          (evalComposeFunc (S a) 0
             (Vector.nil (naryFunc (S a))) (codeList nil) c)
          (fun x y : nat =>
             evalComposeFunc (S (S (S a))) 2
               (Vector.cons (naryFunc (S (S (S a)))) f 1
                  (Vector.cons (naryFunc (S (S (S a))))
                     (evalProjFunc (S (S (S a))) (S a)
                        (Nat.lt_lt_succ_r (S a) (S (S a))
                           (Nat.lt_succ_diag_r  (S a)))) 0
                     (Vector.nil (naryFunc (S (S (S a)))))))
               (fun a0 b : nat => S (cPair a0 b)) x y c))
       (evalPrimRecFunc a
          (evalComposeFunc a 0 (Vector.nil (naryFunc a)) (codeList nil))
          (evalComposeFunc (S (S a)) 2
             (Vector.cons (naryFunc (S (S a))) (fun x y : nat => f x y c) 1
                (Vector.cons (naryFunc (S (S a)))
                   (evalProjFunc (S (S a)) a (Nat.lt_lt_succ_r a (S a)
                                                (Nat.lt_succ_diag_r  a))) 0
                   (Vector.nil (naryFunc (S (S a))))))
             (fun a0 b : nat => S (cPair a0 b))))).
    { apply
        (extEqualPrimRec a
           (evalComposeFunc (S a) 0
              (Vector.nil (naryFunc (S a)))
              (codeList nil) c)).
      simpl in |- *; apply extEqualRefl.
      - simpl in |- *; fold (naryFunc a) in |- *.
        induction
          (sumbool_rec
             (fun _ : {a = S a} + {a <> S a} =>
                {S a = S (S a)} + {S a <> S (S a)})
             (fun a0 : a = S a => left (S a <> S (S a)) (f_equal S a0))
             (fun b : a <> S a => right (S a = S (S a)) (not_eq_S a (S a) b))
             (eq_nat_dec a (S a))).
        + elim (Compat815.lt_not_le (S a) (S (S a))).
          * apply Nat.lt_succ_diag_r.
          * rewrite <- a0; auto.
        + induction
            (sumbool_rec (fun _ : {a = a} + {a <> a} =>
                            {S a = S a} + {S a <> S a})
               (fun a0 : a = a => left (S a <> S a) (f_equal S a0))
               (fun b0 : a <> a => right (S a = S a) (not_eq_S a a b0))
               (eq_nat_dec a a)).
            induction (eq_nat_dec a (S a)).
          * elim (Compat815.lt_not_le a (S a)).
            -- apply Nat.lt_succ_diag_r.
            -- rewrite <- a1; auto.
          * induction (eq_nat_dec a a).
            -- intros;  apply extEqualRefl.
            -- elim b1; auto.
          * elim b0; auto.
    }
    apply (H n).
Qed.

Lemma evalStrongRecHelp2 :
  forall (a : nat) (f : naryFunc (S (S a))) (n m : nat),
    m < n ->
    extEqual _
      (evalComposeFunc _ 1
         (Vector.cons _ (evalStrongRecHelp _ f n) 0 (Vector.nil _))
         (fun b : nat => codeNth (n - S m) b)) (evalStrongRec _ f m).
Proof.
  intro a; fold (naryFunc a) in |- *.
  induction a as [| a Hreca].
  - simpl in |- *.
    apply evalStrongRecHelp1.
  - simpl in |- *.
  intros f n m H c; fold (naryFunc a) in |- *.
  set (g := fun x y : nat => f x y c) in *.
  assert
    (H0: extEqual a
       (evalComposeFunc a 1
          (Vector.cons (naryFunc a)
             (evalStrongRecHelp a g n) 0 (Vector.nil (naryFunc a)))
          (fun b : nat => codeNth (n - S m) b)) (evalStrongRec a g m))
      by (apply Hreca; auto).
  unfold g in H0; clear g Hreca.
  apply extEqualTrans with (evalStrongRec a (fun x y : nat => f x y c) m).
  + apply
    extEqualTrans
    with
    (evalComposeFunc a 1
       (Vector.cons (naryFunc a)
          (evalStrongRecHelp a (fun x y : nat => f x y c) n)
          0 (Vector.nil (naryFunc a)))
       (fun b : nat => codeNth (n - S m) b)).
    * apply extEqualCompose; unfold extEqualVector in |- *.
      simpl in |- *; repeat split.
      apply evalStrongRecHelpParam.
      apply extEqualRefl.
    * apply H0.
  + unfold evalStrongRec in |- *; simpl in |- *.
    fold (naryFunc a) in |- *; apply extEqualCompose.
    unfold extEqualVector in |- *; simpl in |- *; repeat split.
    * apply extEqualSym.
      apply evalStrongRecHelpParam.
    * apply extEqualRefl.
Qed.

Lemma callIsPR (g : nat -> nat) :
 isPR 1 g -> isPR 2 (fun a recs : nat => codeNth (a - S (g a)) recs).
Proof.
  intros H; apply  compose2_2IsPR
    with (f := fun a recs : nat => a - S (g a))
         (g := fun a recs : nat => recs).
  - apply filter10IsPR with (g := fun a : nat => a - S (g a)).
    apply compose1_2IsPR with
      (f := fun a : nat => a)
      (f' := fun a : nat => S (g a)).
    + apply idIsPR.
    + apply compose1_1IsPR.
      * assumption.
      * apply succIsPR.
    + apply minusIsPR.
  - apply pi2_2IsPR.
  - apply codeNthIsPR.
Qed.

End Strong_Recursion.

Lemma div2IsPR : isPR 1 div2.
Proof.
  assert
    (H: isPR 1
          (evalStrongRec 0
             (fun n recs : nat =>
                switchPR n
                  (switchPR (pred n)
                     (S (codeNth (n - S (pred (pred n))) recs))
                     0)
                  0))).
  { apply evalStrongRecIsPR.
    assert (H : isPR 2 (fun n recs : nat => 0)).
    { exists (composeFunc 2 0 (PRnil _) zeroFunc).
      simpl in |- *; auto.
    }
    apply compose2_3IsPR with
    (f1 := fun n recs : nat => n)
    (f2 := fun n recs : nat =>
             switchPR (pred n)
               (S (codeNth (n - S (pred (pred n))) recs)) 0)
    (f3 := fun n recs : nat => 0).
    - apply pi1_2IsPR.
    - apply compose2_3IsPR with
        (f1 := fun n recs : nat => pred n)
        (f2 := fun n recs : nat =>
                 S (codeNth (n - S (pred (pred n))) recs))
        (f3 := fun n recs : nat => 0).
      + apply filter10IsPR.
        apply predIsPR.
      + apply compose2_1IsPR with
            (f := fun n recs : nat =>
                    codeNth (n - S (pred (pred n))) recs).
        * apply compose2_2IsPR with
            (f := fun n recs : nat => n - S (pred (pred n)))
            (g := fun n recs : nat => recs).
          apply filter10IsPR with
            (g := fun n : nat => n - S (pred (pred n))).
          apply compose1_2IsPR with
            (f := fun n : nat => n)
            (f' := fun n : nat => S (pred (pred n))).
          apply idIsPR.
          apply compose1_1IsPR with
            (f := fun n : nat => pred (pred n)).
          apply compose1_1IsPR; apply predIsPR.
          apply succIsPR.
          apply minusIsPR.
          apply pi2_2IsPR.
          apply codeNthIsPR.
        * apply succIsPR.
      + auto.
      + apply switchIsPR.
    - auto.
    - apply switchIsPR.
  }
  destruct H as [x p]; exists x.
  eapply extEqualTrans.
  - apply p.
  - clear p x; simpl in |- *; intro c.
    set  (f := fun n recs : nat =>
                 switchPR n (switchPR (pred n)
                               (S (codeNth (n - S (pred (pred n)))
                                     recs)) 0)  0) in *.
    elim c using Compat815.ind_0_1_SS.
    + unfold evalStrongRec in |- *; simpl in |- *; auto.
    + unfold evalStrongRec in |- *; simpl in |- *;
        apply cPairProjections1.
    + intros n H; unfold evalStrongRec, evalComposeFunc,
        evalOneParamList
        in |- *.
      rewrite computeEvalStrongRecHelp.
      unfold f at 2 in |- *;
        set (A := S (S n) - S (pred (pred (S (S n))))) in *.
      simpl in |- *; rewrite cPairProjections1; apply eq_S.
      rewrite <- H; unfold A in |- *; apply evalStrongRecHelp1.
      auto.
Qed.

(** abbreviations a la Lisp (to improve) *)

Module LispAbbreviations.
  #[global] Notation car n := (cPairPi1 n).
  #[global] Notation caar n := (cPairPi1 (cPairPi1 n)).
  #[global] Notation cadr n := (cPairPi1 (cPairPi2 n)).

  #[global] Notation cdr n := (cPairPi2 n).
  #[global] Notation cddr n := (cPairPi2 (cPairPi2 n)).
  #[global] Notation cdddr n := (cPairPi2 (cPairPi2 (cPairPi2 n))).
  #[global] Notation cddddr n :=
    (cPairPi2 (cPairPi2 (cPairPi2 (cPairPi2 n)))).

End LispAbbreviations.

(** ** Triples
   (moved from codeSubFormula.v)
*)

Definition cTriple (a b c : nat) : nat := cPair a (cPair b c).

Definition cTriplePi1 (n : nat) : nat := cPairPi1 n.

Definition cTriplePi2 (n : nat) : nat := cPairPi1  (cPairPi2 n).

Definition cTriplePi3 (n : nat) : nat := cPairPi2 (cPairPi2 n).

Lemma cTripleIsPR : isPR 3 cTriple.
Proof.
  unfold cTriple; apply compose3_2IsPR with
    (g := cPair)
    (f1 := fun a b c : nat => a)
    (f2 := fun a b c : nat => cPair b c).
  - apply pi1_3IsPR.
  - apply filter011IsPR with (g := fun b c : nat => cPair b c).
    apply cPairIsPR.
  - apply cPairIsPR.
Qed.

Lemma cTriplePi1IsPR : isPR 1 cTriplePi1.
Proof. apply cPairPi1IsPR. Qed.

Lemma cTriplePi2IsPR : isPR 1 cTriplePi2.
Proof.
  unfold cTriplePi2; apply compose1_1IsPR.
  - apply cPairPi2IsPR.
  - apply cPairPi1IsPR.
Qed.

Lemma cTriplePi3IsPR : isPR 1 cTriplePi3.
Proof.
  unfold cTriplePi3; apply compose1_1IsPR; apply cPairPi2IsPR.
Qed.

Lemma cTripleProj1 (a b c : nat) :  cTriplePi1 (cTriple a b c) = a.
Proof.  unfold cTriplePi1, cTriple; apply cPairProjections1. Qed.

Lemma cTripleProj2 (a b c : nat) : cTriplePi2 (cTriple a b c) = b.
Proof.
  unfold cTriplePi2, cTriple; rewrite cPairProjections2;
    apply cPairProjections1.
Qed.

Lemma cTripleProj3 (a b c : nat) : cTriplePi3 (cTriple a b c) = c.
Proof.
  unfold cTriplePi3, cTriple; rewrite cPairProjections2.
  apply cPairProjections2.
Qed.

Lemma cTripleProj (a: nat) :
 cTriple (cTriplePi1 a) (cTriplePi2 a) (cTriplePi3 a) = a.
Proof.
unfold cTriple, cTriplePi1, cTriplePi2, cTriplePi3;
  repeat rewrite cPairProjections; reflexivity.
Qed.


Require Import Coq.Init.Nat.
Require Import Coq.Arith.PeanoNat.

Inductive tree : Type :=
  | Nil
  | Node (v : nat) (l r : tree).

Fixpoint insert (t : tree) (v : nat) : tree :=
  match t with
  | Nil => Node v Nil Nil
  | Node v' l r => if v <? v'
                   then Node v' (insert l v) r
                   else if v' <? v
                        then Node v' l (insert r v)
                        else t
  end.

Lemma insert_not_Nil : forall (t : tree) (v : nat),
  insert t v <> Nil.
Proof.
  intros t v. induction t as [| v' l IHl r IHr]; simpl;
  (try destruct (v <? v'));
  (try destruct (v' <? v));
  intros H; discriminate H.
Qed.

Fixpoint search (t : tree) (v : nat) : bool :=
   match t with
   | Nil => false
   | Node v' l r => if v <? v'
                   then search l v
                   else if v' <? v
                        then search r v
                        else true
  end.

Fixpoint ForallT (t : tree) (P : nat -> Prop) : Prop :=
  match t with
  | Nil => True
  | Node v' l r => P v' /\ ForallT l P /\ ForallT r P
  end.

Inductive BST : tree -> Prop :=
  | BST_Empty: BST Nil
  | BST_Node (v : nat) (l r : tree) :
    BST l ->
    BST r ->
    ForallT l (fun x => x < v) ->
    ForallT r (fun x => x > v) ->
    BST (Node v l r).

Lemma ForallT_insert : forall (t : tree) (P : nat -> Prop) (v : nat),
  P v -> ForallT t P -> ForallT (insert t v) P.
Proof.
 intros t P v H1 H2. induction t as [| v' l IHr r IHl]; simpl.
 - repeat split. apply H1.
 - destruct (v <? v').
  + simpl. simpl in H2. destruct H2 as [H2 [H3 H4]]. repeat split.
    * apply H2.
    * apply IHr. apply H3.
    * apply H4.
  + destruct (v' <? v).
    * simpl. simpl in H2.
      destruct H2 as [H2 [H3 H4]]. repeat split; auto.
    * auto.
Qed.

Theorem insertBST : forall (v : nat) (t : tree),
  BST t -> BST (insert t v).
Proof.
  intros v t H. induction H as [| v' l r H1 IHl H2 IHr H3 H4].
  - simpl. constructor; try constructor.
  - simpl. destruct (v<? v') eqn: E1.
    + constructor; auto. apply ForallT_insert.
      * apply Nat.ltb_lt. apply E1.
      * auto.
    + destruct (v'<? v) eqn: E2.
      * constructor; auto. apply ForallT_insert.
        -- unfold gt. apply Nat.ltb_lt. apply E2.
        -- auto.
      * constructor; auto.
Qed.

Fixpoint InT (t : tree) (v : nat) : Prop :=
  match t with
  | Nil => False
  | Node v' l r => v = v' \/ InT l v \/ InT r v
  end.

Lemma ForallT_InT : forall (t : tree) (v : nat) (P : nat -> Prop),
  ForallT t P -> InT t v -> P v.
Proof.
  intros t v P H H'. induction t as [| v' l IHl r IHr].
  - inversion H'.
  - simpl in H'. simpl in H. destruct H' as [H' | [H' | H']].
    + destruct H as [H _]. rewrite H'. apply H.
    + destruct H as [_ [H _]]. apply IHl; auto.
    + destruct H as [_ [_ H]]. apply IHr; auto.
Qed.

Theorem searchBST : forall (v : nat) (t : tree),
  BST t -> search t v = true <-> InT t v.
Proof.
  intros v t H. split; induction H as [| v1 l1 r1 H1 H3 H2 H4 IHl1 IHr1].
  - intros H. discriminate.
  - simpl. destruct (v <? v1) eqn: E1.
    + intros H. right. left. auto.
    + destruct (v1 <? v) eqn: E2.
      * intros H. right. right. auto.
      * intros H. left. clear H.
        apply Nat.ltb_ge in E1. apply Nat.ltb_ge in E2.
        apply Nat.le_antisymm; auto.
  - simpl. auto.
  - simpl. intros [H | [H | H]].
    + rewrite H. rewrite Nat.ltb_irrefl. reflexivity.
    + apply ForallT_InT with (v := v) in IHl1; auto.
      apply Nat.ltb_lt in IHl1. rewrite IHl1. apply H3. apply H.
    + apply ForallT_InT with (v := v) in IHr1; auto.
      unfold gt in IHr1. apply Nat.ltb_lt in IHr1. rewrite IHr1.
      apply Nat.ltb_lt in IHr1. apply Nat.lt_le_incl in IHr1.
      apply Nat.ltb_ge in IHr1. rewrite IHr1. apply H4. apply H.
Qed.

(* -------------- AVL -------------- *)
Fixpoint height (t : tree) : nat :=
  match t with
  | Nil => 0
  | Node v l r => S (max (height l) (height r))
  end.

(* BT = Balanced Tree *)
Inductive BT : tree -> Prop :=
  | BT_Empty: BT Nil
  | BT_Node_Eq (v : nat) (l r : tree) :
    BT l ->
    BT r ->
    height r = height l ->
    BT (Node v l r)
  | BT_Node_R (v : nat) (l r : tree) :
    BT l ->
    BT r ->
    height r = S (height l) ->
    BT (Node v l r)
  | BT_Node_L (v : nat) (l r : tree) :
    BT l ->
    BT r ->
    height l = S (height r) ->
    BT (Node v l r).

Definition AVL (t : tree) : Prop :=
  BST t /\ BT t.

Definition left_rotate (t : tree) : tree :=
  match t with
  | Node v1 l1 (Node v2 l2 r2) => Node v2 (Node v1 l1 l2) r2
  | _ => t
  end.

Lemma ForallT_lt_trans : forall (n m : nat) (t : tree),
  n < m -> ForallT t (fun x : nat => x < n) -> ForallT t (fun x : nat => x < m).
Proof.
  intros n m t H1 H2. induction t as [| v l IHl r IHr];
  simpl; auto.
  repeat split.
  - simpl in H2. destruct H2 as [H2 H3].
    apply Nat.lt_trans with (m := n); auto.
  - apply IHl. simpl in H2. destruct H2 as [H2 [H3 H4]].
    auto.
  - apply IHr. simpl in H2. destruct H2 as [H2 [H3 H4]].
    auto.
Qed.

Lemma left_rotate_BST : forall (t : tree),
  BST t -> BST (left_rotate t).
Proof.
  intros t H. inversion H; unfold left_rotate.
  - constructor.
  - destruct r as [| v' l' r'].
    + rewrite H4. apply H.
    + constructor.
      * inversion H1. constructor; auto.
        simpl in H3. destruct H3 as [H3 [H12 H13]].
        auto.
      * inversion H1; auto.
      * simpl in H3. destruct H3 as [H3 [H12 H13]].
        simpl. repeat split.
        -- auto.
        -- apply ForallT_lt_trans with (n := v); auto.
        -- inversion H1. auto.
      * inversion H1. auto.
Qed.

Lemma ForallT_left_rotate : forall (P : nat -> Prop) (t : tree),
  ForallT t P ->
  ForallT (left_rotate t) P.
Proof.
  intros P t H. induction t as [| v1 l1 IHl1 r1 IHr1]; auto.
  unfold left_rotate. destruct r1 as [| l2 r2]; auto.
  simpl. simpl in H. destruct H as [H1 [H2 [H3 [H4 H5]]]].
  repeat split; auto.
Qed.

Definition right_rotate (t : tree) : tree :=
  match t with
  | Node v1 (Node v2 l2 r2) r1 => Node v2 l2 (Node v1 r2 r1)
  | _ => t
  end.

Lemma ForallT_gt_trans : forall (n m : nat) (t : tree),
  n > m -> ForallT t (fun x : nat => x > n) -> ForallT t (fun x : nat => x > m).
Proof.
  intros n m t H1 H2. induction t as [| v l IHl r IHr];
  simpl; auto.
  repeat split.
  - simpl in H2. destruct H2 as [H2 H3].
    apply Nat.lt_trans with (m := n); auto.
  - apply IHl. simpl in H2. destruct H2 as [H2 [H3 H4]].
    auto.
  - apply IHr. simpl in H2. destruct H2 as [H2 [H3 H4]].
    auto.
Qed.

Lemma right_rotate_BST : forall (t : tree),
  BST t -> BST (right_rotate t).
Proof.
  intros t H. inversion H; unfold right_rotate.
  - constructor.
  - destruct l as [| v' l' r'].
    + rewrite H4. auto.
    + constructor.
      * inversion H0. auto.
      * constructor; auto.
        -- inversion H0. auto.
        -- simpl in H2. destruct H2 as [H2 [H5 H6]]. auto.
      * inversion H0. auto.
      * simpl. repeat split.
        -- simpl in H2. destruct H2 as [H2 [H5 H6]]. auto.
        -- inversion H0. auto.
        -- simpl in H2. destruct H2 as [H2 [H5 H6]].
           apply ForallT_gt_trans with (n := v); auto.
Qed.

Lemma ForallT_right_rotate : forall (P : nat -> Prop) (t : tree),
  ForallT t P ->
  ForallT (right_rotate t) P.
Proof.
  intros P t H. induction t as [| v1 l1 IHl1 r1 IHr1]; auto.
  unfold right_rotate. destruct l1 as [| l2 r2]; auto.
  simpl. simpl in H. destruct H as [H1 [[H2 [H3 H4]] H5]].
  repeat split; auto.
Qed.

Inductive Diff : Type :=
  | Zero
  | One
  | MinusOne
  | Two
  | MinusTwo
  | Impossible.

Definition diff (t : tree) : Diff :=
  match t with
  | Nil => Zero
  | Node _ l r => let hl := height l in
                  let hr := height r in
                    if hl =? hr
                    then Zero
                    else if hl =? (S hr)
                    then One
                    else if (S hl) =? hr
                    then MinusOne
                    else if hl =? (S (S hr))
                    then Two
                    else if (S (S hl)) =? hr
                    then MinusTwo
                    else Impossible
  end.

Lemma diff_Zero : forall (v : nat) (l r : tree),
  diff (Node v l r) = Zero <-> height l = height r.
Proof.
  intros. split.
  - intros H. unfold diff in H.
    destruct (height l =? height r) eqn: E.
    apply Nat.eqb_eq; apply E.
    destruct (height l =? S (height r)). discriminate.
    destruct (S (height l) =? height r). discriminate.
    destruct (height l =? S (S (height r))). discriminate.
    destruct (S (S (height l)) =? height r); discriminate.
  - intros H. apply Nat.eqb_eq in H. unfold diff. rewrite H. auto.
Qed.

Lemma diff_One : forall (v : nat) (l r : tree),
  diff (Node v l r) = One <-> height l = S (height r).
Proof.
  intros. split.
  - intros H. unfold diff in H.
    destruct (height l =? height r). discriminate.
    destruct (height l =? S (height r)) eqn: E.
    apply Nat.eqb_eq; apply E.
    destruct (S (height l) =? height r). discriminate.
    destruct (height l =? S (S (height r))). discriminate.
    destruct (S (S (height l)) =? height r); discriminate.
  - intros H. unfold diff.
    destruct (height l =? height r) eqn: E.
    apply Nat.eqb_eq in E. rewrite H in E. apply Nat.neq_succ_diag_l in E.
    inversion E.
    apply Nat.eqb_eq in H. rewrite H. auto.
Qed.

Lemma neq_succ_2_diag_l : forall (n : nat),
  S (S n) <> n.
Proof.
  intros n H. induction n as [| n' IHn'].
  - discriminate.
  - apply Nat.succ_inj in H. apply IHn' in H. inversion H.
Qed.

Lemma diff_MinusOne : forall (v : nat) (l r : tree),
  diff (Node v l r) = MinusOne <-> S (height l) = height r.
Proof.
  intros. split.
  - intros H. unfold diff in H.
    destruct (height l =? height r). discriminate.
    destruct (height l =? S (height r)). discriminate.
    destruct (S (height l) =? height r) eqn: E.
    apply Nat.eqb_eq; apply E.
    destruct (height l =? S (S (height r))). discriminate.
    destruct (S (S (height l)) =? height r); discriminate.
  - intros H. unfold diff.
    destruct (height l =? height r) eqn: E1.
    apply Nat.eqb_eq in E1. rewrite E1 in H.
    apply Nat.neq_succ_diag_l in H. inversion H.
    destruct (height l =? S (height r)) eqn: E2.
    apply Nat.eqb_eq in E2. rewrite E2 in H.
    apply neq_succ_2_diag_l in H. inversion H.
    apply Nat.eqb_eq in H. rewrite H. reflexivity.
Qed.

Lemma neq_succ_3_diag_l : forall (n : nat),
  n <> S (S (S n)).
Proof.
  intros n H. induction n as [| n' IHn'].
  - discriminate.
  - apply Nat.succ_inj in H. apply IHn' in H. inversion H.
Qed.

Lemma diff_Two : forall (v : nat) (l r : tree),
  diff (Node v l r) = Two <-> height l = S (S (height r)).
Proof.
  intros. split.
  - intros H. unfold diff in H.
    destruct (height l =? height r). discriminate.
    destruct (height l =? S (height r)). discriminate.
    destruct (S (height l) =? height r). discriminate.
    destruct (height l =? S (S (height r))) eqn: E.
    apply Nat.eqb_eq; apply E.
    destruct (S (S (height l)) =? height r); discriminate.
  - intros H. unfold diff.
    destruct (height l =? height r) eqn: E1.
    apply Nat.eqb_eq in E1. rewrite E1 in H.
    symmetry in H. apply neq_succ_2_diag_l in H. inversion H.
    destruct (height l =? S (height r)) eqn: E2.
    apply Nat.eqb_eq in E2. rewrite E2 in H.
    apply Nat.succ_inj in H. symmetry in H.
    apply Nat.neq_succ_diag_l in H. inversion H.
    destruct (S (height l) =? height r) eqn: E3.
    apply Nat.eqb_eq in E3. rewrite <- E3 in H.
    apply neq_succ_3_diag_l in H. inversion H.
    apply Nat.eqb_eq in H. rewrite H. reflexivity.
Qed.

Lemma neq_succ_4_diag_l : forall (n : nat),
  S (S (S (S n))) <> n.
Proof.
  intros n H. induction n as [| n' IHn'].
  - discriminate.
  - apply Nat.succ_inj in H. apply IHn' in H. inversion H.
Qed.

Lemma diff_MinusTwo : forall (v : nat) (l r : tree),
  diff (Node v l r) = MinusTwo <-> S (S (height l)) = height r.
Proof.
  intros. split.
  - intros H. unfold diff in H.
    destruct (height l =? height r). discriminate.
    destruct (height l =? S (height r)). discriminate.
    destruct (S (height l) =? height r). discriminate.
    destruct (height l =? S (S (height r))). discriminate.
    destruct (S (S (height l)) =? height r) eqn: E.
    apply Nat.eqb_eq; apply E. inversion H.
  - intros H. unfold diff.
    destruct (height l =? height r) eqn: E1.
    apply Nat.eqb_eq in E1. rewrite E1 in H.
    apply neq_succ_2_diag_l in H. inversion H.
    destruct (height l =? S (height r)) eqn: E2.
    apply Nat.eqb_eq in E2. rewrite E2 in H.
    symmetry in H. apply neq_succ_3_diag_l in H. inversion H.
    destruct (S (height l) =? height r) eqn: E3.
    apply Nat.eqb_eq in E3. rewrite <- E3 in H.
    apply Nat.succ_inj in H. apply Nat.neq_succ_diag_l in H. inversion H.
    destruct (height l =? S (S (height r))) eqn: E4.
    apply Nat.eqb_eq in E4. rewrite E4 in H.
    apply neq_succ_4_diag_l in H. inversion H.
    apply Nat.eqb_eq in H. rewrite H. reflexivity.
Qed.

(* ---------- insert AVL ----------*)
Definition rebalance_right (t : tree) : tree :=
  match t with
  | Nil => Nil
  | Node v l r => match diff l with
                  | MinusOne => right_rotate (Node v (left_rotate l) r)
                  | _ => right_rotate (Node v l r)
                  end
  end.

Lemma rebalance_right_BST : forall (t : tree),
  BST t -> BST (rebalance_right t).
Proof.
  intros t H. unfold rebalance_right. inversion H.
  - constructor.
  - destruct (diff l); apply right_rotate_BST; subst; auto.
    constructor; auto.
    + apply left_rotate_BST; auto.
    + destruct l as [| v1 l1 r1]; auto.
      simpl. destruct r1 as [| v2 l2 r2]; auto.
      inversion H. simpl in H9.
      destruct H9 as [H11 [H12 [H13 [H14]]]].
      simpl in H2. destruct H2 as [H15 [H16]].
      simpl. repeat split; assumption.
Qed.

Lemma ForallT_rebalance_right : forall (P : nat -> Prop) (t : tree),
  ForallT t P ->
  ForallT (rebalance_right t) P.
Proof.
  intros P t H. induction t as [| v1 l1 IHl1 r1 IHr1]; auto.
  unfold rebalance_right. destruct (diff l1);
  apply ForallT_right_rotate; auto.
  simpl. simpl in H. destruct H as [H1 [H2 H3]].
  repeat split; auto.
  apply ForallT_left_rotate. auto.
Qed.

Definition rebalance_left (t : tree) : tree :=
  match t with
  | Nil => Nil
  | Node v l r => match diff r with
                  | One => left_rotate (Node v l (right_rotate r))
                  | _ => left_rotate (Node v l r)
                  end
  end.

Lemma rebalance_left_BST : forall (t : tree),
  BST t -> BST (rebalance_left t).
Proof.
  intros t H. unfold rebalance_left. inversion H.
  - constructor.
  - destruct (diff r); apply left_rotate_BST; subst; auto.
    constructor; auto.
    + apply right_rotate_BST; auto.
    + unfold right_rotate. destruct r as [| v1 l1 r1];
      auto. destruct l1 as [| v2 l2 r2]; auto.
      simpl in H3. destruct H3 as [H5 [[H7 [H8]]]].
      simpl. repeat split; assumption.
Qed.

Lemma ForallT_rebalance_left : forall (P : nat -> Prop) (t : tree),
  ForallT t P ->
  ForallT (rebalance_left t) P.
Proof.
  intros P t H. induction t as [| v1 l1 IHl1 r1 IHr1]; auto.
  unfold rebalance_left. destruct (diff r1);
  apply ForallT_left_rotate; auto.
  simpl. simpl in H. destruct H as [H1 [H2 H3]].
  repeat split; auto.
  apply ForallT_right_rotate. auto.
Qed.

Definition rebalance (t : tree) : tree :=
  match diff t with
  | Two => rebalance_right t
  | MinusTwo => rebalance_left t
  | _ => t
  end.

Theorem rebalance_BST : forall (t : tree),
  BST t -> BST (rebalance t).
Proof.
  intros t H. unfold rebalance. inversion H.
  - constructor.
  - destruct (diff (Node v l r)); subst; auto.
    + apply rebalance_right_BST; auto.
    + apply rebalance_left_BST; auto.
Qed.

Fixpoint insertAVL (t : tree) (v : nat) : tree :=
  match t with
  | Nil => Node v Nil Nil
  | Node v' l r => if v <? v'
                   then rebalance (Node v' (insertAVL l v) r)
                   else if v' <? v
                        then rebalance (Node v' l (insertAVL r v))
                        else t
  end.

Lemma max_Sn_n : forall (n : nat),
  max (S n) n = S n.
Proof.
  intros n. apply max_l. auto.
Qed.

Lemma max_n_Sn : forall (n : nat),
  max n (S n) = S n.
Proof.
  intros n. rewrite Nat.max_comm. apply max_Sn_n.
Qed.

Lemma max_SSn_n : forall (n: nat),
  max (S (S n)) n = S ( S n).
Proof.
  intros n. induction n as [| n' IHn']; auto.
  simpl. destruct n'; auto.
Qed.

Lemma insertAVL_height : forall (t : tree) (v: nat),
  BT t ->
  height (insertAVL t v) = S (height t) \/ height (insertAVL t v) = height t.
Proof.
  intros. induction H as
    [|
     v' l r BTl IHl BTr IHr EQlr |
     v' l r BTl IHl BTr IHr EQlr |
     v' l r BTl IHl BTr IHr EQlr ].
  - simpl. left. reflexivity.
  - simpl. destruct (v <? v').
    + unfold rebalance. destruct (diff (Node v' (insertAVL l v) r)) eqn:EQ;
      try (simpl; destruct IHl as [IHl | IHl]; [
        rewrite IHl; destruct (S (height l) <=? height r) eqn: EQ2; [
           apply Nat.leb_le in EQ2; right; f_equal; rewrite max_r; auto;
              symmetry; apply max_r; rewrite Nat.le_succ_l in EQ2;
              apply Nat.lt_le_incl in EQ2; apply EQ2 |
           rewrite Nat.leb_gt in EQ2; left; f_equal; rewrite max_l; [
              f_equal; unfold lt in EQ2; apply le_S_n in EQ2;
                 symmetry; apply max_l; apply EQ2 |
             apply Nat.lt_le_incl; apply EQ2 ]]|
        right; f_equal; rewrite IHl; reflexivity ]).
     * unfold rebalance_right. destruct (diff (insertAVL l v)) eqn:EQ2;
       try (unfold right_rotate; destruct (insertAVL l v); [
            simpl; apply diff_Two in EQ; simpl in EQ; discriminate |
            simpl; apply diff_Two in EQ; simpl in EQ; injection EQ as EQ;
              destruct IHl; [
              simpl in H; injection H as H; rewrite <- H; rewrite EQ;
                 rewrite max_Sn_n;
                 pose proof (Nat.max_spec (height t2) (height t1)) as H1;
                 destruct H1 as [ [H1 H2] | [H1 H2]]; [
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     simpl; rewrite Nat.max_assoc; right; f_equal; f_equal;
                     apply max_r; rewrite max_l; auto; rewrite EQ in H1; unfold lt in H1;
                     apply le_S_n; auto |
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     rewrite max_Sn_n; left; f_equal; apply max_r; rewrite EQ in H1; auto ] |
              simpl in H; rewrite EQ in H; rewrite EQlr in H; apply neq_succ_2_diag_l in H;
                 inversion H ]]).
        unfold right_rotate. destruct (insertAVL l v) eqn:EQ3.
        -- simpl. rewrite EQlr. right. f_equal. rewrite Nat.max_id. reflexivity.
        -- unfold left_rotate. destruct t2 eqn:EQ4.
           ++ simpl. apply diff_MinusOne in EQ2. discriminate.
           ++ simpl. apply diff_MinusOne in EQ2. simpl in EQ2. injection EQ2 as EQ2.
              apply diff_Two in EQ. simpl in EQ. injection EQ as EQ. rewrite EQ2 in EQ.
              rewrite Nat.max_comm in EQ. rewrite max_Sn_n in EQ. injection EQ as EQ.
              assert (H: max (height t1) (height t3) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite EQ2. rewrite Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. clear H.
              assert (H: max (height t4) (height r) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite <- EQ. rewrite <- Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. rewrite Nat.max_id. rewrite EQ. rewrite EQlr.
              left. rewrite Nat.max_id. reflexivity.
      * apply diff_MinusTwo in EQ. destruct IHl.
        -- rewrite <- EQlr in H. rewrite H in EQ. symmetry in EQ.
           apply neq_succ_3_diag_l in EQ. inversion EQ.
        -- rewrite <- EQlr in H. rewrite H in EQ.
           apply neq_succ_2_diag_l in EQ. inversion EQ.
    +  destruct (v' <? v).
       * unfold rebalance. destruct (diff (Node v' l (insertAVL r v))) eqn:EQ;
         try ( simpl; destruct IHr as [IHr | IHr]; [
            rewrite IHr; rewrite EQlr; left; rewrite Nat.max_id; rewrite Nat.max_comm;
            rewrite max_Sn_n; reflexivity |
            rewrite IHr; rewrite EQlr; right; reflexivity ]).
         -- apply diff_Two in EQ. destruct IHr.
            ++ rewrite EQlr in H. rewrite H in EQ.
               apply neq_succ_3_diag_l in EQ. inversion EQ.
            ++ rewrite EQlr in H. rewrite H in EQ. symmetry in EQ.
               apply neq_succ_2_diag_l in EQ. inversion EQ.
         -- apply diff_MinusTwo in EQ. destruct IHr.
            ++ rewrite EQlr in H. rewrite H in EQ. apply Nat.neq_succ_diag_l in EQ.
               inversion EQ.
            ++ rewrite EQlr in H. rewrite H in EQ. apply neq_succ_2_diag_l in EQ.
               inversion EQ.
       * simpl. right. reflexivity.
  - simpl. destruct (v <? v').
    + unfold rebalance. destruct (diff (Node v' (insertAVL l v) r)) eqn:EQ;
      try (simpl; destruct IHl as [IHl | IHl]; [
        rewrite IHl; destruct (S (height l) <=? height r) eqn: EQ2; [
           apply Nat.leb_le in EQ2; right; f_equal; rewrite max_r; auto;
              symmetry; apply max_r; rewrite Nat.le_succ_l in EQ2;
              apply Nat.lt_le_incl in EQ2; apply EQ2 |
           rewrite Nat.leb_gt in EQ2; left; f_equal; rewrite max_l; [
              f_equal; unfold lt in EQ2; apply le_S_n in EQ2;
                 symmetry; apply max_l; apply EQ2 |
             apply Nat.lt_le_incl; apply EQ2 ]]|
        right; f_equal; rewrite IHl; reflexivity ]).
     * unfold rebalance_right. destruct (diff (insertAVL l v)) eqn:EQ2;
        try (unfold right_rotate; destruct (insertAVL l v); [
            simpl; apply diff_Two in EQ; simpl in EQ; discriminate |
            simpl; apply diff_Two in EQ; simpl in EQ; injection EQ as EQ;
              destruct IHl; [
              simpl in H; injection H as H; rewrite <- H; rewrite EQ;
                 rewrite max_Sn_n;
                 pose proof (Nat.max_spec (height t2) (height t1)) as H1;
                 destruct H1 as [ [H1 H2] | [H1 H2]]; [
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     simpl; rewrite Nat.max_assoc; right; f_equal; f_equal;
                     apply max_r; rewrite max_l; auto; rewrite EQ in H1; unfold lt in H1;
                     apply le_S_n; auto |
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     rewrite max_Sn_n; left; f_equal; apply max_r; rewrite EQ in H1; auto ] |
            simpl in H; rewrite EQ in H; rewrite EQlr in H; symmetry in H; apply neq_succ_3_diag_l in H;
                 inversion H]]).
        unfold right_rotate. destruct (insertAVL l v) eqn:EQ3.
        -- simpl. rewrite EQlr. right. f_equal. rewrite Nat.max_comm. rewrite max_Sn_n.
           reflexivity.
        -- unfold left_rotate. destruct t2 eqn:EQ4.
           ++ simpl. apply diff_MinusOne in EQ2. discriminate.
           ++ simpl. apply diff_MinusOne in EQ2. simpl in EQ2. injection EQ2 as EQ2.
              apply diff_Two in EQ. simpl in EQ. injection EQ as EQ. rewrite EQ2 in EQ.
              rewrite Nat.max_comm in EQ. rewrite max_Sn_n in EQ. injection EQ as EQ.
              assert (H: max (height t1) (height t3) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite EQ2. rewrite Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. clear H.
              assert (H: max (height t4) (height r) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite <- EQ. rewrite <- Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. rewrite Nat.max_id. rewrite EQ. rewrite EQlr.
              left. rewrite Nat.max_comm. rewrite max_Sn_n. reflexivity.
      * apply diff_MinusTwo in EQ. destruct IHl.
        -- rewrite <- EQlr in H. rewrite H in EQ.
           apply neq_succ_2_diag_l in EQ. inversion EQ.
        -- rewrite EQlr in EQ. rewrite H in EQ.
           apply Nat.neq_succ_diag_l in EQ. inversion EQ.
    +  destruct (v' <? v).
       * unfold rebalance. destruct (diff (Node v' l (insertAVL r v))) eqn:EQ;
         try (simpl; destruct IHr as [IHr | IHr]; [
             rewrite IHr; rewrite EQlr; left; rewrite Nat.max_comm;
             rewrite max_SSn_n; rewrite Nat.max_comm;
            rewrite max_Sn_n; reflexivity |
            rewrite IHr; rewrite EQlr; right; reflexivity ]).
         -- apply diff_Two in EQ. destruct IHr.
            ++ rewrite EQlr in H. rewrite H in EQ. symmetry in EQ.
               apply neq_succ_4_diag_l in EQ. inversion EQ.
            ++ rewrite EQlr in H. rewrite H in EQ.
               apply neq_succ_3_diag_l in EQ. inversion EQ.
         -- apply diff_MinusTwo in EQ. destruct IHr.
            ++ unfold rebalance_left. Arguments max: simpl never.
               destruct ( diff (insertAVL r v)) eqn:EQ2;
               try (unfold left_rotate; destruct (insertAVL r v); [ discriminate |
                    simpl in EQ; injection EQ as EQ;
                      simpl in H; injection H as H; simpl;
                      pose proof (Nat.max_spec (height t1) (height t2)) as H1;
                 destruct H1 as [ [H1 H2] | [H1 H2]]; [
                   rewrite H2 in EQ; rewrite <- EQ;
                     rewrite <- EQ in H1; unfold lt in H1; apply le_S_n in H1; right;
                     rewrite EQlr; rewrite max_n_Sn; f_equal; apply max_r; rewrite max_l; auto |
                   rewrite H2 in EQ; rewrite <- EQ;
                     rewrite max_n_Sn; left; f_equal; f_equal; rewrite EQlr; rewrite max_n_Sn;
                     apply max_l; rewrite <- EQ in H1; auto ]]).
                unfold left_rotate. destruct (insertAVL r v) eqn: EQ3.
                ** inversion EQ2.
                ** apply diff_One in EQ2. unfold right_rotate. destruct t1.
                   --- discriminate.
                   --- simpl in EQ2. simpl in EQ. rewrite EQ2 in EQ. rewrite max_Sn_n in EQ.
                       injection EQ as EQ. simpl in H. injection H as H. rewrite EQ2 in H.
                       rewrite max_Sn_n in H. injection EQ2 as EQ2.
                       Arguments max : simpl nomatch. simpl.
                       assert (H': max (height l) (height t1_1) = height l).
                       { rewrite EQ. rewrite <- Nat.max_comm in EQ2. rewrite <- EQ2.
                         rewrite <- Nat.max_assoc. rewrite Nat.max_id. reflexivity. }
                       rewrite H'. clear H'.
                       assert (H': max (height t1_2) (height t2) = height l).
                       { rewrite Nat.max_comm. rewrite <- EQ2. rewrite <- Nat.max_assoc.
                         rewrite Nat.max_id. rewrite <- EQ in EQ2. apply EQ2. }
                       rewrite H'. rewrite EQlr. right. rewrite Nat.max_id. rewrite max_n_Sn.
                       reflexivity.
            ++ rewrite EQlr in H. rewrite H in EQ.
               apply Nat.neq_succ_diag_l in EQ. inversion EQ.
       * simpl. right. reflexivity.
  - simpl. destruct (v <? v').
    + unfold rebalance. destruct (diff (Node v' (insertAVL l v) r)) eqn:EQ;
      try (simpl; destruct IHl as [IHl | IHl]; [
        rewrite IHl; destruct (S (height l) <=? height r) eqn: EQ2; [
           apply Nat.leb_le in EQ2; right; f_equal; rewrite max_r; auto;
              symmetry; apply max_r; rewrite Nat.le_succ_l in EQ2;
              apply Nat.lt_le_incl in EQ2; apply EQ2 |
           rewrite Nat.leb_gt in EQ2; left; f_equal; rewrite max_l; [
              f_equal; unfold lt in EQ2; apply le_S_n in EQ2;
                 symmetry; apply max_l; apply EQ2 |
             apply Nat.lt_le_incl; apply EQ2 ]]|
        right; f_equal; rewrite IHl; reflexivity ]).
     * unfold rebalance_right. destruct (diff (insertAVL l v)) eqn:EQ2;
        try (unfold right_rotate; destruct (insertAVL l v); [
            simpl; apply diff_Two in EQ; simpl in EQ; discriminate |
            simpl; apply diff_Two in EQ; simpl in EQ; injection EQ as EQ;
              destruct IHl; [
              simpl in H; injection H as H; rewrite <- H; rewrite EQ;
                 rewrite max_Sn_n;
                 pose proof (Nat.max_spec (height t2) (height t1)) as H1;
                 destruct H1 as [ [H1 H2] | [H1 H2]]; [
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     simpl; rewrite Nat.max_assoc; right; f_equal; f_equal;
                     apply max_r; rewrite max_l; auto; rewrite EQ in H1; unfold lt in H1;
                     apply le_S_n; auto |
                  rewrite Nat.max_comm in H2; rewrite H2 in EQ; rewrite EQ;
                     rewrite max_Sn_n; left; f_equal; apply max_r; rewrite EQ in H1; auto ] |
            simpl in H; rewrite EQ in H; rewrite EQlr in H; apply Nat.neq_succ_diag_l in H;
                 inversion H]]).
        unfold right_rotate. destruct (insertAVL l v) eqn:EQ3.
        -- simpl. rewrite EQlr. inversion EQ2.
        -- unfold left_rotate. destruct t2 eqn:EQ4.
           ++ simpl. apply diff_MinusOne in EQ2. discriminate.
           ++ simpl. apply diff_MinusOne in EQ2. simpl in EQ2. injection EQ2 as EQ2.
              apply diff_Two in EQ. simpl in EQ. injection EQ as EQ. rewrite EQ2 in EQ.
              rewrite Nat.max_comm in EQ. rewrite max_Sn_n in EQ. injection EQ as EQ.
              assert (H: max (height t1) (height t3) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite EQ2. rewrite Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. clear H.
              assert (H: max (height t4) (height r) = max (height t3) (height t4)).
              { rewrite Nat.max_comm. rewrite <- EQ. rewrite <- Nat.max_assoc.
                rewrite Nat.max_id. reflexivity. }
              rewrite H. rewrite Nat.max_id. rewrite EQ. rewrite EQlr.
              right. rewrite max_Sn_n. reflexivity.
      * apply diff_MinusTwo in EQ. destruct IHl.
        -- rewrite EQlr in H. rewrite H in EQ.
           apply neq_succ_4_diag_l in EQ. inversion EQ.
        -- rewrite EQlr in H. rewrite H in EQ. symmetry in EQ.
           apply neq_succ_3_diag_l in EQ. inversion EQ.
    +  destruct (v' <? v).
       * unfold rebalance. destruct (diff (Node v' l (insertAVL r v))) eqn:EQ;
         try (simpl; destruct IHr as [IHr | IHr]; [
             rewrite IHr; rewrite EQlr; right; rewrite Nat.max_id;
            rewrite max_Sn_n; reflexivity |
             rewrite IHr; rewrite EQlr; right; reflexivity]).
         -- apply diff_Two in EQ. destruct IHr.
            ++ rewrite <- EQlr in H. rewrite H in EQ. symmetry in EQ.
               apply neq_succ_2_diag_l in EQ. inversion EQ.
            ++ rewrite EQlr in EQ. rewrite H in EQ. symmetry in EQ.
               apply Nat.neq_succ_diag_l in EQ. inversion EQ.
         -- apply diff_MinusTwo in EQ. destruct IHr.
            ++ rewrite <- EQlr in H. rewrite H in EQ. apply neq_succ_2_diag_l in EQ.
               inversion EQ.
            ++ rewrite EQlr in EQ. rewrite H in EQ. symmetry in EQ.
               apply neq_succ_3_diag_l in EQ. inversion EQ.
       * simpl. right. reflexivity.
Qed.

Lemma rebalance_right_BT : forall (l r : tree) (v : nat),
  BT l -> BT r -> height l = S (S (height r)) ->
  BT (rebalance_right (Node v l r)).
Proof.
  intros. unfold rebalance_right. destruct l; try discriminate.
  inversion H.
  - symmetry in H7. apply diff_Zero with (v:= v0) in H7. rewrite H7.
    unfold right_rotate. apply diff_Zero in H7. simpl in H1. injection H1 as H1.
    rewrite H7 in H1. rewrite Nat.max_id in H1. apply BT_Node_R.
    + auto.
    + apply BT_Node_L; auto.
    + simpl. rewrite H1. rewrite max_Sn_n. f_equal.
      rewrite H7. rewrite H1. reflexivity.
  - symmetry in H7. apply diff_MinusOne with (v:= v0) in H7. rewrite H7.
    unfold right_rotate. unfold left_rotate. destruct l2.
    + apply diff_MinusOne in H7. discriminate.
    + apply diff_MinusOne in H7. simpl in H7. simpl in H1.
      rewrite <- H7 in H1. rewrite max_n_Sn in H1. injection H1 as H1.
      injection H7 as H7. inversion H6.
      * rewrite H13 in H7. rewrite Nat.max_id in H7. apply BT_Node_Eq.
        -- apply BT_Node_Eq; auto.
        -- apply BT_Node_Eq; auto. rewrite <- H13 in H7. rewrite H7 in H1.
           symmetry in H1. apply H1.
        -- simpl. rewrite <- H1. rewrite H7. rewrite Nat.max_id. rewrite <- H13.
           rewrite Nat.max_id. auto.
      * rewrite H13 in H7. rewrite max_n_Sn in H7. apply BT_Node_Eq.
        -- apply BT_Node_L; auto.
        -- apply BT_Node_Eq; auto. rewrite <- H13 in H7. rewrite H7 in H1.
           symmetry in H1. apply H1.
        -- simpl. rewrite <- H1. rewrite H7. rewrite H13. rewrite Nat.max_id.
           rewrite max_Sn_n. auto.
      * rewrite H13 in H7. rewrite max_Sn_n in H7. apply BT_Node_Eq.
        -- apply BT_Node_Eq; auto. rewrite H7. apply H13.
        -- apply BT_Node_R; auto. rewrite <- H7. symmetry. apply H1.
        -- simpl. rewrite <- H1. rewrite H7. rewrite H13. rewrite Nat.max_id.
           rewrite max_n_Sn. reflexivity.
  - apply diff_One with (v:= v0) in H7. rewrite H7.
    apply diff_One in H7. simpl in H1. injection H1 as H1. unfold right_rotate.
    rewrite H7 in H1. rewrite max_Sn_n in H1. injection H1 as H1. apply BT_Node_Eq.
    + auto.
    + apply BT_Node_Eq; auto.
    + simpl. rewrite H1. rewrite Nat.max_id.
      rewrite H7. rewrite H1. reflexivity.
Qed.

Lemma rebalance_left_BT : forall (l r : tree) (v : nat),
  BT l -> BT r -> S (S (height l)) = height r ->
  BT (rebalance_left (Node v l r)).
Proof.
  intros. unfold rebalance_left. destruct r; try discriminate.
  inversion H0.
  - symmetry in H7. apply diff_Zero with (v:= v0) in H7. rewrite H7.
    unfold left_rotate. apply diff_Zero in H7. simpl in H1. rewrite H7 in H1.
    rewrite Nat.max_id in H1. injection H1 as H1. apply BT_Node_L.
    + rewrite <- H1 in H7. apply BT_Node_R; auto.
    + auto.
    + simpl. f_equal. rewrite H7. rewrite <- H1. rewrite max_n_Sn. reflexivity.
  - symmetry in H7. apply diff_MinusOne with (v:= v0) in H7. rewrite H7.
    unfold left_rotate. apply diff_MinusOne in H7. simpl in H1.
    rewrite <- H7 in H1. rewrite max_n_Sn in H1. injection H1 as H1.
    apply BT_Node_Eq.
    + apply BT_Node_Eq; auto.
    + auto.
    + simpl. rewrite H1. rewrite Nat.max_id. symmetry. apply H7.
  - apply diff_One with (v:= v0) in H7. rewrite H7.
    unfold left_rotate. unfold right_rotate. destruct r1.
    + apply diff_One in H7. discriminate.
    + apply diff_One in H7. simpl in H1. simpl in H7. injection H7 as H7.
      rewrite H7 in H1. rewrite max_Sn_n in H1. injection H1 as H1. inversion H5.
      * rewrite H13 in H7.
        rewrite Nat.max_id in H7. apply BT_Node_Eq.
        -- rewrite <- H7 in H1. apply BT_Node_Eq; auto.
        -- rewrite <- H13 in H7. apply BT_Node_Eq; auto.
        -- simpl. rewrite H1. rewrite <- H7. rewrite H13. reflexivity.
      * rewrite H13 in H7.
        rewrite max_n_Sn in H7. apply BT_Node_Eq.
        -- rewrite <- H7 in H1. apply BT_Node_L; auto.
        -- rewrite H7 in H13. apply BT_Node_Eq; auto.
        -- simpl. rewrite H1. rewrite <- H7. rewrite H13.
           rewrite Nat.max_id. rewrite max_Sn_n. reflexivity.
      * rewrite H13 in H7. rewrite max_Sn_n in H7. apply BT_Node_Eq.
        -- rewrite <- H13 in H7. rewrite <- H7 in H1. apply BT_Node_Eq; auto.
        -- apply BT_Node_R; auto.
        -- simpl. rewrite H1. rewrite <- H7. rewrite H13. rewrite Nat.max_id.
           f_equal. apply max_n_Sn.
Qed.

Theorem insertAVL_BT : forall (t : tree) (v : nat),
  BT t -> BT (insertAVL t v).
Proof.
  intros t v H. induction H.
  - simpl. apply BT_Node_Eq; try apply BT_Empty. reflexivity.
  - simpl. destruct (v <? v0).
    + unfold rebalance. destruct (diff (Node v0 (insertAVL l v) r)) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height l v) in H. destruct H.
           ++ rewrite <- H1 in H. apply diff_One with (v := v0) in H.
              rewrite H in EQ. discriminate.
           ++ rewrite <- H1 in H. apply diff_Zero with (v := v0) in H.
              rewrite H in EQ. discriminate.
    + destruct (v0 <? v).
      * unfold rebalance. destruct (diff (Node v0 l (insertAVL r v))) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height r v) in H0. destruct H0.
           ++ rewrite H1 in H0. symmetry in H0. apply diff_MinusOne with (v := v0) in H0.
              rewrite H0 in EQ. discriminate.
           ++ rewrite H1 in H0. symmetry in H0. apply diff_Zero with (v := v0) in H0.
              rewrite H0 in EQ. discriminate.
     * apply BT_Node_Eq; auto.
  - simpl. destruct (v <? v0).
    + unfold rebalance. destruct (diff (Node v0 (insertAVL l v) r)) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height l v) in H. destruct H.
           ++ rewrite <- H1 in H. apply diff_Zero with (v := v0) in H.
              rewrite H in EQ. discriminate.
           ++ rewrite <- H in H1. symmetry in H1. apply diff_MinusOne with (v := v0) in H1.
              rewrite H1 in EQ. discriminate.
    + destruct (v0 <? v).
      * unfold rebalance. destruct (diff (Node v0 l (insertAVL r v))) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height r v) in H0. destruct H0.
           ++ rewrite H1 in H0. symmetry in H0. apply diff_MinusTwo with (v := v0) in H0.
              rewrite H0 in EQ. discriminate.
           ++ rewrite H1 in H0. symmetry in H0. apply diff_MinusOne with (v := v0) in H0.
              rewrite H0 in EQ. discriminate.
     * apply BT_Node_R; auto.
  - simpl. destruct (v <? v0).
    + unfold rebalance. destruct (diff (Node v0 (insertAVL l v) r)) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height l v) in H. destruct H.
           ++ rewrite H1 in H. apply diff_Two with (v := v0) in H.
              rewrite H in EQ. discriminate.
           ++ rewrite H1 in H. apply diff_One with (v := v0) in H.
              rewrite H in EQ. discriminate.
    + destruct (v0 <? v).
      * unfold rebalance. destruct (diff (Node v0 l (insertAVL r v))) eqn:EQ.
        -- apply diff_Zero in EQ. apply BT_Node_Eq; auto.
        -- apply diff_One in EQ. apply BT_Node_L; auto.
        -- apply diff_MinusOne in EQ. apply BT_Node_R; auto.
        -- apply diff_Two in EQ. apply rebalance_right_BT; auto.
        -- apply diff_MinusTwo in EQ. apply rebalance_left_BT; auto.
        -- apply (insertAVL_height r v) in H0. destruct H0.
           ++ rewrite <- H1 in H0. symmetry in H0. apply diff_Zero with (v := v0) in H0.
              rewrite H0 in EQ. discriminate.
           ++ rewrite <- H0 in H1. apply diff_One with (v := v0) in H1.
              rewrite H1 in EQ. discriminate.
     * apply BT_Node_L; auto.
Qed.

Ltac detruct_contradiction exp :=
  try destruct exp; try contradiction; try (repeat (intros H; discriminate H)).

Lemma insertAVL_not_Nil : forall (t : tree) (v : nat),
  insertAVL t v <> Nil.
Proof.
  intros t v. induction t as [| v' l IHl r IHr]; simpl.
  - intros H. discriminate H.
  - destruct (v <? v').
    + unfold rebalance. detruct_contradiction (diff (Node v' (insertAVL l v) r)).
      * unfold rebalance_right. destruct (diff (insertAVL l v));
        unfold right_rotate; try detruct_contradiction (insertAVL l v);
        try detruct_contradiction (left_rotate (Node v0 t1 t2)).
      * unfold rebalance_left. destruct (diff r);
        unfold left_rotate; try detruct_contradiction r;
        try detruct_contradiction (right_rotate (Node v0 r1 r2)).
    + destruct (v' <? v); try (intros H; discriminate H).
      unfold rebalance. destruct (diff (Node v' (insertAVL l v) r));
      try detruct_contradiction (diff (Node v' l (insertAVL r v)));
      unfold rebalance_right; try detruct_contradiction (diff l);
      unfold right_rotate; try detruct_contradiction l;
      try detruct_contradiction (left_rotate (Node v0 l1 l2));
      unfold rebalance_left; try detruct_contradiction (diff (insertAVL r v));
      unfold left_rotate; try detruct_contradiction (insertAVL r v);
      try detruct_contradiction (right_rotate (Node v0 t1 t2));
      try detruct_contradiction (right_rotate (Node v1 t1 t2));
      try detruct_contradiction (right_rotate (Node v2 t3 t4)).
Qed.

Lemma ForallT_rebalance : forall (P : nat -> Prop) (t : tree),
  ForallT t P ->
  ForallT (rebalance t) P.
Proof.
  intros P t H1. induction t as [| v1 l1 IHl1 r1 IHr1]; auto.
  unfold rebalance. destruct (diff (Node v1 l1 r1)); auto.
  - apply ForallT_rebalance_right. auto.
  - apply ForallT_rebalance_left. auto.
Qed.

Lemma ForallT_insertAVL : forall (P : nat -> Prop) (t : tree) (v : nat),
  P v ->
  ForallT t P ->
  ForallT (insertAVL t v) P.
Proof.
  intros P t v H1 H2. induction t as [| v1 l1 IHl1 r1 IHr1]; simpl.
  - repeat split; auto.
  - simpl in H2. destruct H2 as [H2 [H3 H4]].
    destruct (v <? v1).
    + apply ForallT_rebalance. simpl.
      repeat split; auto.
    + destruct (v1 <? v).
      * apply ForallT_rebalance. simpl.
        repeat split; auto.
      * simpl. repeat split; auto.
Qed.

Lemma ltb_symm : forall (n m : nat),
  (n < m) -> (m > n).
Proof.
  intros n m H. induction n as [| n'];
  destruct m as [| m']; auto.
Qed.

Theorem insertAVL_BST : forall (t : tree) (v : nat),
  BST t -> BST (insertAVL t v).
Proof.
  intros t v H. induction H as [| v1 l1 r1 H1 IHl1 H2 IHr1 H3 H4]; simpl.
  - repeat constructor.
  - destruct (v <? v1) eqn: Ev1.
    + apply rebalance_BST. constructor; auto.
      apply ForallT_insertAVL; auto.
      apply Nat.ltb_lt in Ev1. auto.
    + destruct (v1 <? v) eqn: Ev2.
      * apply rebalance_BST. constructor; auto.
        apply ForallT_insertAVL; auto.
        apply Nat.ltb_lt in Ev2. apply ltb_symm in Ev2. auto.
      * constructor; auto.
Qed.

Theorem insertAVL_AVL : forall (t : tree) (v : nat),
  AVL t -> AVL (insertAVL t v).
Proof.
  unfold AVL. intros. destruct H. split.
  - apply insertAVL_BST. apply H.
  - apply insertAVL_BT. apply H0.
Qed.


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

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.
Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.
Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.
Fixpoint nonzeros (l:natlist) : natlist :=
    match l with
    | nil => nil
    | O :: t => nonzeros t
    | n :: t => n :: nonzeros t
    end.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof. Admitted.

Theorem add_comm : forall n m : nat,
  n + m = m + n.
Proof. Admitted.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof. Admitted.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof. Admitted.

Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Definition and (b1 b2 : bool) : bool :=
    match b1 with
    | false => false
    | true => match b2 with
        | false => false
        | true => true
        end
    end.

Lemma eqb_n_n_true : forall n : nat,
  eqb n n = true.
Proof. Admitted.

(* EXERCISE *)
Fixpoint eqblist (l1 l2 : natlist) : bool :=
    match l1 with
    | nil => match l2 with
        | nil => true
        | _ => false
        end
    | h :: t => match l2 with
        | nil => false
        | m :: n => and (eqb h m) (eqblist t n)
        end
    end.

Example test_eqblist1 :
    (eqblist nil nil = true).
Proof. simpl. reflexivity. Qed.

Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
Proof. simpl. reflexivity. Qed.

Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. simpl. reflexivity. Qed.

(* EXERCISE *)
Theorem eqblist_refl : forall l:natlist,
  true = eqblist l l.
Proof.
    intros l. induction l as [| n l' IHl'].
    - simpl. reflexivity.
    - simpl.
      rewrite -> IHl'.
      rewrite -> eqb_n_n_true.
      rewrite <- IHl'. simpl.
      reflexivity.
    Qed.


(*Sidorets Kirill et Ait gueni ssaid Abderrahmane*)
(* 1.2 λ-calcul simplement typé*)
  (* 1. Booléens (codage des constantes et des opérations de base) *)
  Section type_booleen.
    (*1.2.1*)
    Variable T : Set.
    Definition cbool := T -> T -> T.
    (*booléens de Church vrai: λx y.x*)
    Definition ctr : cbool := fun x y => x.
    Print ctr.
    (*booléens de Church faux: λx y.y*)
    Definition cfa : cbool := fun x y => y.
    Print cfa.
    (*if b then m else n : λ b m n .b m n*)
    Definition cif: cbool -> T ->T ->T :=fun (b : cbool) (t : T) (e : T) =>b t e.
    Variables F V : T.
    Compute cif ctr V F.
    Compute cif cfa V F.
    (* a and  b : λ a b.λx y. a (b x y) y *)
    Definition cand:cbool->cbool->cbool := fun (a:cbool) (b:cbool) =>fun (x:T) (y:T) =>a (b x y) y.
    Compute cand ctr ctr.
    Compute cand ctr cfa.
    Compute cand cfa cfa.
    Compute cand cfa ctr.
    (* a or  b : λ a b.λx y. a x (b x y) *)
    Definition cor :cbool->cbool->cbool:= fun (a:cbool) (b:cbool) =>fun (x:T)(y:T)=>a x (b x y).
    Compute cor ctr ctr.
    Compute cor ctr cfa.
    Compute cor cfa cfa.
    Compute cor cfa ctr.
    (*not b :λ b.λ x y . b y x*)
    Definition cnot:cbool->cbool := fun (b:cbool) => fun (x:T) (y:T)=> b y x.
    Compute cnot ctr.
    Compute cnot cfa.
  End type_booleen.
  (* 2. Entiers naturels (codage de quelques constantes, des opérations
   successeur, addition et multiplication, et du test à 0) *)
  Section type_nat.
  Variable T: Set.
    Definition compo : (T->T) -> (T->T) -> (T->T) :=fun g f => fun x => g (f x).

    Notation "g ° f" := (compo g f) (at level 10).
    Fixpoint iter (f:T->T) (n: nat) :=
    match n with
    | O => fun x => x
    | S p => f ° (iter f p)
    end.
    Definition cnat := (T->T) -> (T->T).
    Definition cnat_of : nat -> cnat := fun n => fun f => (iter f n).
    Notation "[ X ]N " := (cnat_of X) (at level 5).
    Definition test := [3]N.
    (* 0 :λ f x .x *)
    Definition c0: cnat := fun (f:T->T) (x:T) => x.
    (* 1 :λ f x . f x *)
    Definition c1: cnat := fun (f:T->T) (x:T) => f x.
    (* 2 :λ f x . f (f x) *)
    Definition c2: cnat := fun (f:T->T) (x:T) => f (f x).
    (* 3 :λ f x . f (f (f x)) *)
    Definition c3: cnat := fun (f:T->T) (x:T) => f (f (f x)).
    (* csucc(n)=n+1 : λ n.λ f x. f (n f x)*)
    Definition cS:= fun (n:cnat)=> fun (f:T->T) (x:T)  => ( f (n f x )).
    Compute c0.
    Compute c1.
    Compute c2.
    Compute c3.
    Compute cS c0.
    Compute cS c1.
    Compute cS c2.
    Compute cS c3.
    (* cadd (a,b)=a+b :λ n m.λ f x. n f (m f x) *)
    Definition cadd := fun (n:cnat) (m:cnat) => fun (f:T->T) (x:T) =>  n f (m f x).
    Compute cadd c1 c2.
    Compute cadd c0 c2.
    Compute cadd c3 c2.
    Compute cadd c3 c3.
    (* cmult (a,b)=a*b :λ n m.λ f . n (m f) *)
    Definition cmult := fun (n:cnat) (m:cnat) => fun (f:T->T)=>  n (m f).
    Compute cmult c1 c3.
    Compute cmult c2 c2.
    Compute cmult c2 c3.
    Compute cmult c1 c1.
    Compute cmult c2 c0.
    Compute cmult c0 c3.
    (* ceq0(n) = {si n =0 true sinon false}:λ n .λ x y . n (λ z.y ) x*)
    Definition cseq0 := fun (n:cnat)=> fun (x:T) (y:T)=> n (fun (z:T)=>y) x.
    Compute cseq0 c0.
    Compute cseq0 c1.
    Compute cseq0 c3.
  End type_nat.


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

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.
Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.
Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.
Fixpoint nonzeros (l:natlist) : natlist :=
    match l with
    | nil => nil
    | O :: t => nonzeros t
    | n :: t => n :: nonzeros t
    end.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof. Admitted.

Theorem add_comm : forall n m : nat,
  n + m = m + n.
Proof. Admitted.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof. Admitted.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof. Admitted.

(* EXERCISE *)
Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
    intros l. induction l as [| n l' IHl'].
    - reflexivity.
    - simpl. rewrite -> IHl'. reflexivity.
    Qed.

(* EXERCISE *)
Theorem rev_app_distr : forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1'. rewrite -> app_assoc. reflexivity.
  Qed.

(* An involution is a function that is its own inverse. That is, applying the function twice yield the original input. *)
(* EXERCISE *)
Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
    intros l. induction l as [| n l' IHl'].
    - simpl. reflexivity.
    - simpl. rewrite -> rev_app_distr. rewrite -> IHl'. simpl. reflexivity.
    Qed.

(* EXERCISE *)
Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
    intros l1 l2 l3 l4. induction l1 as [| n l1' IHl1'].
    - simpl. rewrite -> app_assoc. reflexivity.
    - simpl. rewrite -> app_assoc. rewrite -> app_assoc. reflexivity.
    Qed.

(* ADDITIONAL LEMMAS *)
Lemma app_assoc_with_nat : forall n : nat, forall l1 l2 : natlist,
    (n :: l1) ++ l2 = n :: (l1 ++ l2).
Proof.
    intros n. intros l1 l2. simpl. reflexivity.
    Qed.

Lemma nonzeros_Sn_l1 : forall n : nat, forall l1 : natlist,
    nonzeros(S n :: l1) = S n :: nonzeros l1.
Proof.
    intros n. intros l1. simpl. reflexivity. Qed.

Lemma nonzeros_Sn_l1_l2 : forall n : nat, forall l1 l2 : natlist,
    nonzeros(S n :: l1 ++ l2) = S n :: nonzeros(l1 ++ l2).
Proof.
    intros n. intros l1 l2. simpl. reflexivity. Qed.

Lemma Sn_app_l1_l2_assoc : forall n : nat, forall l1 l2 : natlist,
    (S n :: l1) ++ l2 = S n :: (l1 ++ l2).
Proof.
    intros n. intros l1 l2. simpl. reflexivity. Qed.

(* EXERCISE *)
Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
    intros l1 l2. induction l1 as [| n l1' IHl'].
    - simpl. reflexivity.
    - rewrite -> app_assoc_with_nat. destruct n.
     + simpl. rewrite -> IHl'. reflexivity.
     + rewrite -> nonzeros_Sn_l1_l2.
       rewrite -> nonzeros_Sn_l1.
       rewrite -> IHl'.
       rewrite -> Sn_app_l1_l2_assoc.
       reflexivity.
    Qed.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : auxiliary library for nat.
  author    : ZhengPu Shi
  date      : 2021.05
 *)

From Coq Require Export Init.Nat.
From Coq Require Export Arith.
From Coq Require Export PeanoNat.
From Coq Require Export Lia.
From Coq Require Export Bool.Bool.

(* From Coq Require Export Lra. *)
(* From Coq Require Export Setoid. (* R ==> R', Morphisms.respectful R R' *) *)

(* ######################################################################### *)
(** * More properties for nat *)

(** a natural number must be odd or even *)
Lemma nat_split : forall (n : nat), exists (x : nat),
    n = 2 * x \/ n = 2 * x + 1.
Proof.
  induction n.
  - exists 0. auto.
  - destruct IHn. destruct H.
    + exists x. right. subst. lia.
    + exists (x+1). left. subst. lia.
Qed.

(** Two step induction principle for natural number *)
Theorem nat_ind2 : forall (P : nat -> Prop),
    (P 0) -> (P 1) -> (forall n, P n -> P (S (S n))) -> (forall n, P n).
Proof.
  intros. destruct (nat_split n). destruct H2; subst; induction x; auto.
  - replace (2 * S x) with (S (S (2 * x))); [apply H1; auto | lia].
  - replace (2 * S x + 1) with (S (S (2 * x + 1))); [apply H1; auto | lia].
Qed.

(** Connect induction principle between nat and list *)
Lemma ind_nat_list {A} : forall (P : list A -> Prop) ,
    (forall n l, length l = n -> P l) -> (forall l, P l).
Proof.
  intros. apply (H (length l)). auto.
Qed.

(* ######################################################################### *)
(** * Extension for nat from (Verified Quantum Computing). *)

(* https://www.cs.umd.edu/~rrand/vqc/index.html *)

(*******************************)
(* Automation *)
(*******************************)

Lemma double_mult : forall (n : nat), (n + n = 2 * n).
Proof.
  intros. lia.
Qed.

Lemma pow_two_succ_l : forall x, 2^x * 2 = 2 ^ (x + 1).
Proof.
  intros. rewrite Nat.mul_comm. rewrite <- Nat.pow_succ_r'. rewrite Nat.add_1_r. auto.
Qed.

Lemma pow_two_succ_r : forall x, 2 * 2^x = 2 ^ (x + 1).
Proof.
  intros. rewrite <- Nat.pow_succ_r'. rewrite Nat.add_1_r. auto.
Qed.

Lemma double_pow : forall (n : nat), 2^n + 2^n = 2^(n+1).
Proof.
  intros. rewrite double_mult. rewrite pow_two_succ_r. reflexivity.
Qed.

Lemma pow_components : forall (a b m n : nat), a = b -> m = n -> a^m = b^n.
Proof.
  intuition.
Qed.

Ltac unify_pows_two :=
  repeat match goal with
    (* NB: this first thing is potentially a bad idea, do not do with 2^1 *)
    | [ |- context[ 4%nat ]]                  => replace 4%nat with (2^2)%nat
        by reflexivity
    | [ |- context[ (0 + ?a)%nat]]            => rewrite Nat.add_0_l
    | [ |- context[ (?a + 0)%nat]]            => rewrite Nat.add_0_r
    | [ |- context[ (1 * ?a)%nat]]            => rewrite Nat.mul_1_l
    | [ |- context[ (?a * 1)%nat]]            => rewrite Nat.mul_1_r
    | [ |- context[ (2 * 2^?x)%nat]]          => rewrite <- Nat.pow_succ_r'
    | [ |- context[ (2^?x * 2)%nat]]          => rewrite pow_two_succ_l
    | [ |- context[ (2^?x + 2^?x)%nat]]       => rewrite double_pow
    | [ |- context[ (2^?x * 2^?y)%nat]]       => rewrite <- Nat.pow_add_r
    | [ |- context[ (?a + (?b + ?c))%nat ]]   => rewrite Nat.add_assoc
    | [ |- (2^?x = 2^?y)%nat ]                => apply pow_components; try lia
    end.

(** Restoring Matrix dimensions *)
Ltac is_nat_equality :=
  match goal with
  | |- ?A = ?B => match type of A with
                | nat => idtac
                end
  end.

(* ######################################################################### *)
(** * Useful bdestruct tactic with the help of reflection *)
(** Use this tactic, the proposition of natural number comparision and the boolean
    calculation of natural number comparison are connected. *)

(** There havn't GT and GE in standard library. *)

Notation  "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a) (at level 70) : nat_scope.

(** Proposition and boolean are reflected. *)

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

(** These theorems are automatic used. *)
Global Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

(** bool-destruct，useful for boolean inequality of natural number *)
Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

(** This tactic makes quick, easy-to-read work of our running example. *)
Example reflect_example2: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros.
  bdestruct (a <? 5);  (* instead of: [destruct (ltb_reflect a 5)]. *)
  lia.
Qed.


From Coq Require Import Arith.

Fixpoint fib (n : nat) : nat :=
  match n with
  | 0 => 0
  | 1 => 1
  | S (S n as n') => fib n' + fib n
  end.

Fixpoint fib_aux (a b n : nat) : nat :=
  match n with
  | 0 => a
  | S n => fib_aux b (a + b) n
  end.

Definition fib2 (n : nat) : nat := fib_aux 0 1 n.

Theorem fib_eq (n : nat) : fib2 n = fib n.
Proof.
  intros.
  induction n.
  trivial.
  unfold fib2.
  assert (forall m a b, fib_aux a b (S m) = a * fib m + fib (S m) * b ).
    induction m.
    intros.
    simpl.
    simpl Nat.mul.
    rewrite (Nat.mul_comm a 0).
    simpl Nat.mul.
    simpl Nat.add.
    rewrite (Nat.add_comm b 0).
    simpl Nat.add.
    reflexivity.
    simpl in *.
    intros.
    rewrite IHm.
    ring.
  rewrite (H n 0 1).
  ring.
Qed.


Require Export P01.
(** **** Problem #2: 2 stars (blt_nat) *)
(** The [blt_nat] function tests [nat]ural numbers for [l]ess-[t]han,
    yielding a [b]oolean.  Use [Fixpoint] to define it. *)

Fixpoint blt_nat (n m : nat) : bool :=
  match n with
  | O =>
    match m with
    | O => false
    | S m' => true
    end
  | S n' =>
    match m with
    | O => false
    | S m' => blt_nat n' m'
    end
  end.

Example test_blt_nat1:             (blt_nat 2 2) = false.
Proof. reflexivity. Qed.
Example test_blt_nat2:             (blt_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_blt_nat3:             (blt_nat 4 2) = false.
Proof. reflexivity. Qed.