Set Implicit Arguments.

Require Import List.
Require Import Lt.
Require Import Le.
Require Import util.
Require Import list_utils.
Require Import Omega.
Require Import arith_lems.

Fixpoint nats (b: nat) (w: nat) {struct w}: list nat :=
  match w with
  | 0 => nil
  | S w' => b :: nats (S b) w'
  end.

Lemma nats_length (w b: nat): length (nats b w) = w.
Proof with auto.
  generalize w b; clear w b.
  induction w...
  simpl.
  intros.
  rewrite IHw...
Qed.

Lemma In_nats (w x b: nat): b <= x -> x < b + w -> In x (nats b w).
Proof with auto.
  revert w x b.
  induction w; intros.
    elimtype False.
    rewrite plus_0_r in H0.
    apply (lt_not_le x b H0)...
  simpl.
  destruct (le_lt_eq_dec _ _ H); [right | left]...
  apply IHw...
  omega.
Qed.

Lemma In_nats_inv (w x b: nat): In x (nats b w) -> b <= x < b + w.
Proof with auto.
  revert w x b.
  induction w; simpl; intros.
    inversion H.
  inversion H.
    omega.
  destruct (IHw x (S b) H0).
  omega.
Qed.

Lemma NoDup_nats (w b: nat): NoDup (nats b w).
Proof with auto.
  revert w b.
  induction w; simpl; intros.
    apply NoDup_nil.
  apply NoDup_cons...
  intro.
  destruct (In_nats_inv _ _ _ H).
  apply (le_Sn_n _ H0).
Qed.

Lemma nats_plus y x z: nats x (y + z) = nats x y ++ nats (y + x) z.
Proof with auto.
  revert y x z.
  induction y...
  intros.
  simpl.
  rewrite IHy.
  rewrite <- plus_n_Sm...
Qed.

Lemma nats_Sw b w: nats b (S w) = b :: nats (S b) w.
Proof. auto. Qed.

Lemma nats_split (w b i: nat): i <= w -> nats b w = nats b i ++ nats (b + i) (w - i).
Proof with auto.
  intros.
  destruct (le_exists_plus H).
  subst w.
  replace (i + x - i) with x by omega.
  rewrite nats_plus.
  rewrite plus_comm.
  reflexivity.
Qed.

Lemma nats_Sw' w b: nats b (S w) = nats b w ++ (w + b :: nil).
Proof with auto.
  revert w b.
  induction w...
  intros.
  rewrite nats_Sw.
  rewrite IHw.
  simpl.
  rewrite plus_n_Sm...
Qed.

Lemma split_pow2_range n:
  nats 1 (pow 2 n) = 1 :: concat (map (fun x => nats (pow 2 x + 1) (pow 2 x)) (nats 0 n)).
Proof with auto.
  induction n...
  simpl pow.
  rewrite plus_0_r.
  rewrite nats_plus.
  rewrite IHn.
  rewrite nats_Sw'.
  rewrite map_app.
  simpl.
  rewrite concat_app.
  rewrite plus_0_r.
  simpl.
  rewrite app_nil_r...
Qed.

Lemma nats_Sb w b: nats (S b) w = map S (nats b w).
Proof with auto.
  revert w b.
  induction w...
  simpl.
  intros.
  rewrite IHw...
Qed.

Require Import Relations.
Require vec.

Lemma filtered_sort (T: Set) (R: relation T) (P: preorder T R) (p: T -> T -> bool) (pc: forall x y, p y x = true -> ~ R y x) (l: list T): vec.sorted R l ->
  elemsR le (map (fun x => length (filter (p (fst x)) (snd x))) (splits l)) (nats 0 (length l)).
Proof with auto.
  induction l.
    simpl...
  intro.
  pose proof (IHl (vec.sorted_tail H)). clear IHl.
  simpl.
  apply eR_cons.
    rewrite (fst (conj_prod (list_utils.filter_none _ l)))...
    intros.
    unfold flip.
    pose proof (pc x a).
    destruct (p a x)...
    elimtype False.
    apply H2...
    apply (vec.sorted_cons_inv' P H x).
    rewrite vec.list_round_trip...
  rewrite map_map.
  simpl.
  apply elemsR_le_S in H0.
  rewrite nats_Sb.
  transitivity (map S (map (fun x => length (filter (p (fst x)) (snd x))) (splits l)))...
  rewrite map_map.
  apply elemsR_map_map.
  intros.
  destruct (p (fst x))...
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Object-level encoding of bounded universal quantification II *)

Require Import Arith List Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac gcd prime binomial sums bool_nat.

From Undecidability.H10.Matija
  Require Import cipher.

From Undecidability.H10.Dio
  Require Import dio_logic dio_expo dio_binary.

Set Implicit Arguments.

Local Infix "≲" := binary_le (at level 70, no associativity).
Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).
Local Infix "⇣" := nat_meet (at level 40, left associativity).
Local Infix "⇡" := nat_join (at level 50, left associativity).

(* seqs_of_ones l q u u1 iff

            l+1 < q
       and  u  = ∑(i<l) r^(2^(1+i))
       and  u1 = ∑(i<l) r^(2^(2+i))
       with r := 2^(4q)

  *)

Theorem dio_rel_seqs_of_ones l q u u1 : 𝔻F l -> 𝔻F q -> 𝔻F u -> 𝔻F u1
          -> 𝔻R (fun v => seqs_of_ones (l v) (q v) (u v) (u1 v)).
Proof.
  dio by lemma (fun v => seqs_of_ones_dio (l v) (q v) (u v) (u1 v)).
Defined.

#[export] Hint Resolve dio_rel_seqs_of_ones : dio_rel_db.

(* a is the q-cipher of some l-tuple *)

Theorem dio_rel_Code l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                          -> 𝔻R (fun v => Code (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => Code_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_Code : dio_rel_db.

(* c is the q-cipher of the l-tuple <x,...,x> *)

Theorem dio_rel_Const l q c x : 𝔻F l -> 𝔻F q -> 𝔻F c -> 𝔻F x
                             -> 𝔻R (fun v => Const (l v) (q v) (c v) (x v)).
Proof.
  dio by lemma (fun v => Const_dio (l v) (q v) (c v) (x v)).
Defined.

#[export] Hint Resolve dio_rel_Const : dio_rel_db.

(* a is the q-cipher of the l-tuple <0,...,l-1> *)

Theorem dio_rel_CodeNat l q a : 𝔻F l -> 𝔻F q -> 𝔻F a
                             -> 𝔻R (fun v => CodeNat (l v) (q v) (a v)).
Proof.
  dio by lemma (fun v => CodeNat_dio (l v) (q v) (a v)).
Defined.

#[export] Hint Resolve dio_rel_CodeNat : dio_rel_db.

(* Testing whether a is the q cipher of the sum of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_plus a b c : 𝔻F a -> 𝔻F b -> 𝔻F c
                               -> 𝔻R (fun v => Code_plus (a v) (b v) (c v)).
Proof. intros; unfold Code_plus; dio auto. Defined.

(* Testing whether a is the q cipher of the product of the tuples of q-ciphers b and c *)

Theorem dio_rel_Code_mult l q a b c : 𝔻F l -> 𝔻F q -> 𝔻F a -> 𝔻F b -> 𝔻F c
                                   -> 𝔻R (fun v => Code_mult (l v) (q v) (a v) (b v) (c v)).
Proof. intros; unfold Code_mult; dio auto. Defined.

#[export] Hint Resolve dio_rel_Code_plus dio_rel_Code_mult : dio_rel_db.

(* Now we have diophantine representations of q-cipher of the following l-tuple

    1) <x,...,x>  (for x < 2^q)
    2) <0,...,l-1>
    3) testing whether some code is a q-cipher of some tuple
    4) testing sum and product equality among q-ciphers

*)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frédéric Blanqui, 2014-02-18

Some structures on tropical numbers. *)

Set Implicit Arguments.

Require Import Arith OrdSemiRing2 Omega LogicUtil RelUtil Morphisms
SemiRing EqUtil Max.

Instance Tropical_as_Setoid : Setoid := LeibnizSetoid TropicalDom.

Instance Tropical_as_DS : DecidableSetoid.

Proof.
  apply Build_DecidableSetoid with (ds_setoid := Tropical_as_Setoid).
  simpl. intros.
  apply dec_beq with (beq := beq_TropicalDom). apply beq_TropicalDom_ok.
Defined.

(***********************************************************************)
(** Tropical ordered setoid *)

Definition gt m n :=
  match m, n with
    | PlusInf, PlusInf => False
    | PlusInf, _ => True
    | TPos _, PlusInf => False
    | TPos m, TPos n => m > n
  end.

Definition ge m n := gt m n \/ m = n.

Instance Tropical_as_OS : OrderedSetoid.

Proof.
  apply Build_OrderedSetoid with
  (os_setoid := Tropical_as_Setoid)
  (os_gt     := gt).
  simpl. intros x x' xx' y y' yy' xy. rewrite <- xx'.
  rewrite <- yy'. apply xy.
Defined.

(***********************************************************************)
(** Tropical semi-ring *)

Definition A0 := PlusInf.
Definition A1 := TPos 0.

Definition Aplus m n :=
  match m, n with
    | PlusInf, n     => n
    | m, PlusInf     => m
    | TPos m, TPos n => TPos (min m n)
  end.

Definition Amult m n :=
  match m, n with
    | PlusInf, _     => PlusInf
    | _, PlusInf     => PlusInf
    | TPos m, TPos n => TPos (m + n)
  end.

Require Import Min.

Lemma A_plus_comm : forall m n, Aplus m n = Aplus n m.

Proof.
  intros. unfold Aplus. destruct m; destruct n; trivial.
  rewrite min_comm. trivial.
Qed.

Lemma A_plus_assoc : forall m n p,
  Aplus m (Aplus n p) = Aplus (Aplus m n) p.

Proof.
  intros. unfold Aplus.
  destruct m; destruct n; destruct p; trivial.
  rewrite min_assoc. trivial.
Qed.

Lemma A_mult_comm : forall m n, Amult m n = Amult n m.

Proof.
  intros. unfold Amult. destruct m; destruct n; trivial.
  rewrite plus_comm. trivial.
Qed.

Lemma A_mult_assoc : forall m n p,
  Amult m (Amult n p) = Amult (Amult m n) p.

Proof.
  intros. unfold Amult.
  destruct m; destruct n; destruct p; trivial.
  rewrite plus_assoc. trivial.
Qed.

Import Compare. Import Min.

Lemma A_mult_plus_distr : forall m n p,
  Amult (Aplus m n) p = Aplus (Amult m p) (Amult n p).

Proof.
  intros. unfold Amult, Aplus.
  destruct m; destruct n; destruct p; trivial.
  destruct (le_dec n0 n).
  rewrite min_l. rewrite min_l. trivial.
  auto with arith. trivial.
  rewrite min_r. rewrite min_r. trivial.
  auto with arith. trivial.
Qed.

Instance Tropical_as_SR : SemiRing.

Proof.
  apply Build_SemiRing with
  (sr_ds  := Tropical_as_DS)
  (sr_0   := PlusInf)
  (sr_1   := TPos 0)
  (sr_add := Aplus)
  (sr_mul := Amult).
  (* Aplus s_eq as proper. *)
  intros x y z xx yy H. rewrite H. rewrite z. refl.
  (* Amult s_eq as proper. *)
  intros x y z xx yy H. rewrite H. rewrite z. refl.
  (* Semi-ring-theory. *)
  constructor; intros.
  compute; trivial.
  apply A_plus_comm.
  apply A_plus_assoc.
  destruct n; compute; trivial.
  compute; trivial.
  apply A_mult_comm.
  apply A_mult_assoc.
  apply A_mult_plus_distr.
Defined.

(***********************************************************************)
(** Tropical ordered semi-ring *)

Notation "x + y"    := (Aplus x y).
Notation "x * y"    := (Amult x y).
Notation "x >=_t y" := (ge x y) (at level 70).
Notation "x >_t y"  := (gt x y) (at level 70).

Lemma gt_trans : transitive gt.

Proof.
  intros x y z xy yz.
  destruct x; destruct y; destruct z; try solve [ auto | contr ].
  apply gt_trans with n0; auto.
Qed.

Lemma ge_trans : transitive ge.

Proof.
  intros x y z xy yz. destruct xy. destruct yz.
  left. apply (gt_trans x y z); hyp.
  subst y. left. hyp.
  subst x. hyp.
Qed.

Lemma gt_dec : rel_dec gt.

Proof.
  unfold rel_dec. intros.
  destruct x; destruct y; simpl; auto.
  destruct (gt_dec n n0); auto.
Defined.

Lemma ge_dec : rel_dec ge.

Proof.
  intros x y. destruct (gt_dec x y).
  left. left. hyp.
  destruct (@ds_eq_dec Tropical_as_DS x y).
  left. right. hyp.
  right. intro xy. destruct xy; auto.
Defined.

(* ge @ gt << gt : ge_gt_compat *)

Lemma ge_gt_compat: forall x y z, x >=_t y -> y >_t z -> x >_t z.

Proof with simpl; intuition.
    intros.
    destruct y; destruct x; destruct z; auto...
    destruct H. simpl in *. omega. injection H. intros. subst...
    destruct H. contr. discr.
Qed.

(* gt @ ge << gt : gt_ge_compat *)

Lemma gt_ge_compat: forall x y z, x >_t y -> y >=_t z -> x >_t z.

Proof.
  unfold ge, gt. destruct x; destruct y; destruct z; simpl; intuition;
  try discr.
  inversion H1. subst. hyp.
Qed.

Lemma ge_impl_pos_ge : forall m n, (m >= n)%nat -> TPos m >=_t TPos n.

Proof.
  intros. destruct (lt_eq_lt_dec m n) as [[m_n | m_n] | m_n].
  elimtype False. omega.
  subst m. right. refl.
  left. trivial.
Qed.

Lemma pos_ge_impl_ge : forall m n, TPos m >=_t TPos n -> (m >= n)%nat.

Proof.
  intros. destruct H. auto with arith.
  injection H. intro. subst m. auto with arith.
Qed.

Ltac tropical_ord :=
  match goal with
    | H: _ >_t PlusInf |- _ => contr
    | H: TPos _ >=_t PlusInf |- _ =>
      destruct H; [ contr | discr ]
    | H: TPos ?m >=_t TPos ?n |- _ =>
      assert ((m >= n)%nat);
        [ apply pos_ge_impl_ge; hyp
        | clear H; tropical_ord
        ]
    | |- PlusInf >=_t TPos _ => left; simpl; trivial
    | |- TPos ?m >=_t TPos ?n => apply ge_impl_pos_ge
    | _ => try solve [contr | discr]
  end.

Lemma plus_gt_compat: Proper (gt ==> gt ==> gt) Aplus.

Proof.
intros m m' H n n' H0.
destruct m; destruct n; destruct m'; destruct n';
simpl; trivial; tropical_ord.
apply NatUtil.min_gt_compat; hyp.
unfold Peano.gt. apply NatUtil.lt_min_intro_l. hyp.
unfold Peano.gt. apply NatUtil.lt_min_intro_r. hyp.
Qed.

Lemma plus_ge_compat: Proper (ge ==> ge ==> ge) Aplus.

Proof.
intros m m' H n n' H0.
destruct m; destruct n; destruct m'; destruct n';
simpl; trivial; tropical_ord.
apply NatUtil.min_ge_compat; hyp.
unfold Peano.ge. apply NatUtil.le_min_intro_l. hyp.
unfold Peano.ge. apply NatUtil.le_min_intro_r. hyp.
Qed.

Lemma mult_ge_compat: Proper (ge ==> ge ==> ge) Amult.

Proof.
intros m m' H n n' H0.
 destruct m; destruct n; destruct m'; destruct n';
 simpl; trivial; tropical_ord.
 omega.
Qed.

Instance Tropical_as_OSR : OrderedSemiRing.

Proof.
apply Build_OrderedSemiRing with
(osr_sr := Tropical_as_SR)
(osr_gt := gt)
(osr_ge := ge); simpl.
fo. fo.
(* Transitive ge *)
apply ge_trans.
(* Transitive gt *)
apply gt_trans.
(* rel_dec ge *)
apply ge_dec.
(* rel_dec gt *)
apply gt_dec.
(* ge @ gt << gt *)
apply ge_gt_compat.
(* gt @ ge << gt *)
apply gt_ge_compat.
(* Aplus gt proper: plus_gt_compat *)
apply plus_gt_compat.
(* Aplus ge proper: plus_ge_compat *)
apply plus_ge_compat.
(* Mult ge proper: mult_ge_compat *)
apply mult_ge_compat.
Defined.

Lemma tropical_plus_notInf_left :forall a b,
  a <> PlusInf -> Aplus a b <> PlusInf.

Proof.
  intros. destruct a.
  destruct b; simpl; discr.
  auto.
Qed.

Lemma tropical_mult_notInf : forall a b,
  a <> PlusInf -> b <> PlusInf -> Amult a b <> PlusInf.

Proof.
  intros.
  destruct a; auto.
  destruct b; auto.
  simpl. discr.
Qed.

Lemma tropical_plus_inf_max : forall x, x <> PlusInf -> PlusInf >_t x.

Proof.
  intros. destruct x. simpl. auto.
  elimtype False. apply H. trivial.
Qed.

Lemma A_plus_0_r : forall n, Aplus n PlusInf = n.

Proof.
  intros. unfold Aplus. destruct n; auto.
Qed.

Lemma A_plus_0_l : forall n, Aplus PlusInf n = n.

Proof.
  intros. rewrite A_plus_comm. apply A_plus_0_r.
Qed.

Lemma gt_irrefl : irreflexive gt.

Proof.
  intros x xx. destruct x.
  unfold gt in xx. omega.
  auto.
Qed.

Require Import SN.

Lemma gt_Fin_WF x : Acc (transp gt) (TPos x).

Proof.
  induction x using lt_wf_ind; apply Acc_intro; destruct y;
  auto || contr.
Qed.

Hint Resolve gt_Fin_WF.

Lemma gt_WF : WF gt.

Proof with auto; try contr.
  apply wf_transp_WF. intro x.
  destruct x...
  apply Acc_intro. intros. destruct y...
Qed.

Lemma ge_gt_eq : forall x y, x >=_t y -> x >_t y \/ x = y.

Proof.
  destruct 1; auto.
Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export pythagoras_difference_lemmas.
Require Export euclidean_constructions_2.
Require Export construction_lemmas_2.
Require Export ratios_elimination_lemmas.

Lemma grid_existence :
  forall O U, O<>U ->
  exists V,
  perp O U O V /\ O**U <> 0 /\ O**V <> 0.
Proof.
intros.
assert ( exists Y : Point, on_perp_d Y O U 1).
apply (on_perp_d_ex O U 1 H).
auto with field_hints.
elim H0;intros V HV.
exists V.
unfold on_perp_d in HV.
use HV.
repeat split;auto with Geom.
intro.
assert (O=V) by auto with Geom.
subst.
basic_simpl.
unfold Py in H2.
uniformize_dir_seg.
basic_simpl.
ring_simplify in H2.
assert (U=V).
cases_equality U V.
auto.
assert (U**V<>0).
auto with Geom.
assert (2 * U ** V * U ** V <> 0).
repeat (apply (nonzeromult));auto with Geom.
intuition.
intuition.
Qed.

Ltac construct_grid O U V H :=
 elim grid_existence;let H:= fresh in (
 intros O H; elim H; clear H;intros U H;elim H;clear H;intro V;intros H;decompose [and] H).

Lemma area_grid : forall O U V, perp O U O V ->
O ** U <> 0 -> O ** V <> 0 ->
 2*2*(S O U V * S O U V) = O**U*O**U*O**V*O**V.
Proof.
intros.
assert ( 2 * 2 * S U O V * S U O V = U ** O * U ** O * O ** V * O ** V).
apply (per_area U O V).
assert (perp U O O V) by auto with Geom.
auto with Geom.
uniformize_signed_areas.
basic_simpl.
ring_simplify_eq.
rewrite H2.
uniformize_dir_seg.
ring.
Qed.

Lemma grid_not_col : forall O U V, perp O U O V ->
O ** U <> 0 -> O ** V <> 0 -> ~ Col O U V.
Proof.
intros.
intro.
assert (parallel O U O V) by auto with Geom.
assert (~ parallel O U O V) by
(apply (perp_not_parallel);auto with Geom).
intuition.
Qed.

Lemma degen_py_elim : forall O U V, perp O U O V ->
O ** U <> 0 -> O ** V <> 0 ->
forall A B,  (* ~ Col A O V -> ~ Col B O U -> *)
Py A B A = 2*2*2*(
   (S O V A-S O V B) * (S O V A-S O V B) / (O**V * O**V) +
   (S O U A-S O U B) * (S O U A-S O U B) / (O**U * O**U)).
Proof.
intros.

cases_col A O V.
assert (Col O V A) by auto with Geom.
rewrite H3.
replace ((0 - S O V B) * (0 - S O V B)) with (S O V B  * S O V B) by ring.

replace (S O V A) with 0.
2:auto with Geom.
admit.
cases_col B O U.
admit.

assert ({Y : Point | on_inter_parallel_parallel Y A O U B O V}).
apply (on_inter_parallel_parallel_ex O U A O V B).
apply perp_not_parallel;auto with Geom.
auto.
elim H4;intros M HM;clear H4.

cases_equality M A.
subst M.
unfold on_inter_parallel_parallel in *.
use HM.
assert (parallel O V A B) by auto with Geom.
unfold parallel, S4 in H7.
admit.

cases_equality M B.
admit.

assert (T:=HM).
unfold on_inter_parallel_parallel in HM.
use HM.
assert ( perp M A O V)
by (apply (perp_para_perp O U O V M A);auto with Geom).
assert (perp M B M A)
by (apply (perp_para_perp O V M A M B);auto with Geom).
assert (per A M B).
assert (perp A M M B) by auto with Geom.
auto with Geom.
unfold per, Py in *.
uniformize_dir_seg.
basic_simpl.
IsoleVar (A ** B * A ** B) H12.
rewrite H12.
basic_simpl.
assert (A ** M / O ** U = S4 A O B V / S4 O O U V).
apply (elim_length_ratio_on_inter_parallel_parallel_2 A O U O U A O V B M);
auto with Geom.
assert (B ** M / O ** V = S4 B O A U / S4 O O V U).
apply (elim_length_ratio_on_inter_parallel_parallel_2 B O V O V B O U A M);
auto with Geom.
unfold on_inter_parallel_parallel in *.
use T;repeat split;auto with Geom.
basic_simpl.
replace (S4 B O A U) with (- S4 O B U A) in * by auto with Geom.
replace (S4 A O B V) with (- S4 O A V B) in * by auto with Geom.
unfold S4 in *.
IsoleVar (A**M) H13.
IsoleVar (B**M) H14.
assert (~ Col O U V).
apply grid_not_col;auto with Geom.
assert ( 2 * 2 * (S O U V * S O U V) = O ** U * O ** U * O ** V * O ** V).
apply area_grid;auto with Geom.
IsoleVar (S O U V * S O U V) H16.
assert (A ** M * A ** M = O ** U * O**U * ( (S O A V + S O V B) * (S O A V + S O V B) / (S O U V * S O U V))).
rewrite H13.
field;auto with Geom.
rewrite H16 in H18.
assert (B ** M * B ** M = O**V * O**V* ((S O B U + S O U A)* (S O B U + S O U A) / (S O V U * S O V U)
)).
rewrite H14.
field;auto with Geom.
uniformize_signed_areas.
basic_simpl.
rewrite H16 in H19.
rewrite H18.
rewrite H19.
field; auto with Geom.
apply nonzeromult;auto with Geom.
Qed.

Lemma py_to_pys : forall A B C,
 Py A B C = 1/2 * (Py A B A + Py B C B - Py A C A).
Proof.
intros.
unfold Py.
uniformize_dir_seg.
basic_simpl.
field;auto with Geom.
Qed.

Lemma py_elim :  forall O U V, perp O U O V ->
O ** U <> 0 -> O ** V <> 0 ->
forall A B C,
~ Col A O V -> ~ Col B O U ->
Py A B C =
(- (2*2*2)* O ** U * O ** U * S O V A * S O V B +
    2*2*2 * O ** U * O ** U * S O V A * S O V C +
    2*2*2 * O ** U * O ** U * S O V B * S O V B -
    2*2*2 * O ** U * O ** U * S O V B * S O V C -
    2*2*2 * O ** V * O ** V * S O U A * S O U B +
    2*2*2 * O ** V * O ** V * S O U A * S O U C +
    2*2*2 * O ** V * O ** V * S O U B * S O U B -
    2*2*2 * O ** V * O ** V * S O U B * S O U C) /
(O ** V * O ** V * O ** U * O ** U).
Proof.
intros.
rewrite py_to_pys.
repeat (rewrite (degen_py_elim O U V H) by auto with Geom).
field;auto with Geom.
Qed.

Ltac elim_pys O U V H1 H2 H3 :=
repeat (rewrite (degen_py_elim O U V H1 H2 H3));
repeat (rewrite (py_elim O U V H1 H2 H3)).


Require Import Extract.
Require Import Coq.Lists.List.
Require Import Recdef.
Require Import FunInd.
Require Import Coq.Numbers.BinNums.
Require Import Coq.omega.Omega.
Export ListNotations.

Definition key := Z.

Section BTREES.
Variable V : Type.
Variable b : nat.

(** Basic Definitions *)

Inductive tree : Type :=
  | node : key -> treelist -> tree
  | final : treelist -> tree
  | val : key -> V -> tree
with treelist : Type :=
  | tl_nil : treelist
  | tl_cons : tree -> treelist -> treelist.

Scheme tree_treelist_rec := Induction for tree Sort Type
with treelist_tree_rec := Induction for treelist Sort Type.

(*
treelist_tree_rec :
forall (P : tree -> Type) (P0 : treelist -> Type),
(forall (k : key) (t : treelist), P0 t -> P (node k t)) ->
(forall t : treelist, P0 t -> P (final t)) ->
(forall (k : key) (v : V), P (val k v)) ->
P0 tl_nil ->
(forall t : tree, P t -> forall t0 : treelist, P0 t0 -> P0 (tl_cons t t0)) ->
forall t : treelist, P0 t
*)

Definition cursor : Type := list nat * list treelist.

Inductive splitpair : Type :=
| One : treelist -> splitpair
| Two : treelist -> key -> treelist -> splitpair.

(** Example data *)

Definition pos_one : key := Zpos xH.
Definition neg_one : key := Zneg xH.
Definition zero : key := Z0.
Definition pos_six : key := Zpos (xO (xI xH)).
Definition default : V. Admitted.

Definition ex_treelist : treelist :=
  tl_cons (node pos_one
    (tl_cons (val neg_one default)
    (tl_cons (val pos_one default) tl_nil)))
  (tl_cons (final
    (tl_cons (val pos_six default) tl_nil))
  tl_nil).

Definition ex_treelist' : treelist :=
  tl_cons (final ex_treelist) tl_nil.

Definition ex_treelist'' : treelist :=
  tl_cons (val zero default) tl_nil.

(** Helper Functions *)

Fixpoint eq_pos (p1 : positive) (p2 : positive) :=
  match (p1,p2) with
  | (xI p1',xI p2') => eq_pos p1' p2'
  | (xO p1',xO p2') => eq_pos p1' p2'
  | (xH,xH) => true
  | (_,_) => false
  end.

Definition eq_key (k1 : key) (k2 : key) :=
  match (k1,k2) with
  | (Z0,Z0) => true
  | (Zpos p1,Zpos p2) => eq_pos p1 p2
  | (Zneg p1,Zneg p2) => eq_pos p1 p2
  | (_,_) => false
  end.

(* is p1 less than p2? *)
(* curVal carries the info of which was greater in the bit where they differed *)
Fixpoint lt_pos (p1 : positive) (p2 : positive) (curVal : bool) :=
  match p1 with
  | xH => (match p2 with
           | xH => curVal
           | _ => true
           end)
  | xO p1' => (match p2 with
               | xH => false
               | xO p2' => lt_pos p1' p2' curVal
               | xI p2' => lt_pos p1' p2' true
               end)
  | xI p1' => (match p2 with
               | xH => false
               | xO p2' => lt_pos p1' p2' false
               | xI p2' => lt_pos p1' p2' curVal
               end)
  end.

Definition lt_key (k1 : key) (k2 : key) :=
  match k1 with
  | Zpos p1 => (
    match k2 with
    | Zpos p2 => lt_pos p1 p2 false
    | _ => false
    end)
  | Z0 => (
    match k2 with
    | Zpos p2 => true
    | _ => false
    end)
  | Zneg p1 => (
    match k2 with
    | Zneg p2 => lt_pos p2 p1 false
    | _ => true
    end)
  end.

Fixpoint max_nat (m : nat) (n : nat) : nat :=
  match m with
  | O => n
  | S m' => (match n with
             | O => m
             | S n' => S (max_nat m' n')
             end)
  end.

Fixpoint unzip {A : Type} {B : Type} (l : list (A * B)) : list A * list B :=
  match l with
  | (a,b)::tl => (match unzip tl with (la, lb) => (a::la, b::lb) end)
  | [] => ([], [])
  end.

Fixpoint treelist_depth (f : treelist) : nat :=
  match f with
  | tl_nil => O
  | tl_cons t f => max_nat (tree_depth t) (treelist_depth f)
  end
with tree_depth (t : tree) : nat :=
  match t with
  | node _ f => S (treelist_depth f)
  | final f => S (treelist_depth f)
  | val _ _ => S O
  end.

Fixpoint zip (f1 : treelist) (f2 : treelist) : treelist :=
  match f1 with
  | tl_cons t f' => tl_cons t (zip f' f2)
  | tl_nil => f2
  end.

Fixpoint treelist_length (f : treelist) : nat :=
  match f with
  | tl_nil => O
  | tl_cons t f' => S (treelist_length f')
  end.

(* flip false causes floor of div *)
(* flip true causes ciel of div *)
Fixpoint div_two (n : nat) (flip : bool) : nat :=
  match n with
  | O => O
  | S n' => (match flip with
             | true => S (div_two n' false)
             | false => div_two n' true
             end)
  end.

Function lin_search (n : nat) (f : treelist) : option tree :=
  match f with
  | tl_cons t f' =>
    (match n with
     | O => Some t
     | S n' => lin_search n' f'
     end)
  | tl_nil => None
  end.

Fixpoint point (n : nat) (f : treelist): (treelist * option tree * treelist) :=
  match f with
  | tl_cons t f' =>
    (match n with
     | O => (tl_nil,Some t,f')
     | S n' => (match point n' f' with (f1,t',f2) => (tl_cons t f1,t',f2) end)
     end)
  | tl_nil => (tl_nil,None,tl_nil)
  end.

Function tl_app (f1 : treelist) (f2 : treelist) : treelist :=
  match f1 with
  | tl_nil => f2
  | tl_cons t f1' => tl_cons t (tl_app f1' f2)
  end.

(** MAKE_CURSOR section *)

(* Functions to create a cursor at a given key *)

Function make_cursor_rec (x: key) (f : treelist) (ci : list nat) (ct : list treelist) (n : nat) : cursor :=
  match f with
  | tl_nil => (n::ci,ct)
  | tl_cons (node k f') f =>
    if lt_key k x then make_cursor_rec x f ci ct (S n) else make_cursor_rec x f' (n::ci) (f'::ct) O
  | tl_cons (final f') tl_nil =>
    make_cursor_rec x f' (n::ci) (f'::ct) O
  | tl_cons (val k v) f =>
    if lt_key k x then make_cursor_rec x f ci ct (S n) else (n::ci,ct)
  | _ => ([],[])
  end.

Definition make_cursor (x : key) (f : treelist) : cursor := make_cursor_rec x f [] [f] O.

Function first_cursor_rec (f : treelist) (cn : list nat) (cf : list treelist) : cursor :=
  match f with
  | tl_nil => (cn,cf) (* Shouldn't be hit unless tree is empty *)
  | tl_cons (node _ f') _ => first_cursor_rec f' (0::cn) (f::cf)
  | tl_cons (final f') _ => first_cursor_rec f' (0::cn) (f::cf)
  | tl_cons (val _ _) _ => (0::cn,f::cf)
  end.

Definition first_cursor (f : treelist) : cursor := first_cursor_rec f [] [].

Function last_cursor_rec (f : treelist) (cn : list nat) (cf : list treelist) (n : nat) : cursor :=
  match f with
  | tl_nil => (n::cn,cf) (* Shouldn't be hit unless tree is empty *)
  | tl_cons t tl_nil =>
    (match t with
     | node _ f' => last_cursor_rec f' (n::cn) (f'::cf) O (* Shouldn't happen b/c always final before tl_nil *)
     | final f' => last_cursor_rec f' (n::cn) (f'::cf) O
     | val _ _ => ((S n)::cn, cf)
     end)
  | tl_cons t f' => last_cursor_rec f' cn cf (S n)
  end.

Definition last_cursor (f : treelist) : cursor := last_cursor_rec f [] [f] O.

(** NEXT & PREV section *)

Fixpoint next_node (cn : list nat) (cf : list treelist) : option (cursor * key) :=
  match (cn,cf) with
  | (n::cn',f::cf') =>
    (match point n f with
     | (_,Some (node k _),tl_cons (node _ f') _) => Some (((S n)::cn',f::cf'),k)
     | (_,Some (node k _),tl_cons (final f') _) => Some (((S n)::cn',f::cf'),k)
     | (_,Some (val k v), _) => Some ((n::cn',f::cf'),k)
     | _ =>
       (match next_node cn' cf' with
        | Some ((n'::cn,f'::cf),k) =>
          (match point n' f' with
           | (_,Some (node _ f1),_) => Some ((O::n'::cn,f1::f'::cf),k)
           | (_,Some (final f1),_) => Some ((O::n'::cn,f1::f'::cf),k)
           | _ => None
           end)
        | _ => None
        end)
     end)
  | (_,_) => None
  end.

Fixpoint prev_node (cn : list nat) (cf : list treelist) : option (cursor * key) :=
  match (cn,cf) with
  | (S n::cn',f::cf') =>
     (match point n f with
      | (_,Some (node k f'),_) => Some ((n::cn',f::cf'),k)
      | (_,Some (final f'),_) => None (* Shouldn't be possible *)
      | (_,Some (val k v),_) => Some ((S n::cn',f::cf'),k)
      | (_,None,_) => None (* Shouldn't be possible *)
      end)
  | (O::cn',f::cf') =>
     (match prev_node cn' cf' with
       | Some ((n::cn, f::cf),k) =>
         (match point n f with
          | (_,Some (node _ f'),_) => Some (((treelist_length f')-1::n::cn,f'::f::cf),k)
          | (_,Some (final f'),_) => Some (((treelist_length f')-1::n::cn,f'::f::cf),k)
          | _ => None
          end)
       | _ => None
       end)
  | (_,_) => None
  end.

Fixpoint move_to_next (c : cursor) : cursor :=
  match c with (cn,cf) =>
  (match next_node cn cf with
   | Some ((n::cn',cf'),_) => (S n::cn',cf')
   | _ => c
   end)
  end.

Fixpoint move_to_prev (c : cursor) : cursor :=
  match c with (cn,cf) =>
  (match prev_node cn cf with
   | Some ((S n::cn',cf'),_) => (n::cn',cf')
   | _ => c
   end)
  end.

(** GET section *)

Fixpoint get_tree (c : cursor) : option tree :=
  match c with (cn,cf) =>
  (match next_node cn cf with
   | Some ((n::_,f::_),_) => lin_search n f
   | _ => None
   end)
  end.

Fixpoint get_key (c : cursor) : option key :=
  match get_tree c with
  | Some (val k v) => Some k
  | _ => None
  end.

Fixpoint get (c : cursor) : option V :=
  match get_tree c with
  | Some (val k v) => Some v
  | _ => None
  end.

(** INSERT section *)

(* separates the nth element to move up *)
Fixpoint split (f : treelist) (n : nat) : splitpair :=
  match n with
  | O => (match f with
          | tl_nil => One f (* can't be split that far *)
          | tl_cons t f' => (match t with
                          | node k f'' => Two (tl_cons (final f'') tl_nil) k f' (* the node becomes a final *)
                          | val k v => Two (tl_cons t tl_nil) k f' (* preserve the key-value pair *)
                          | final f'' => One f (* can't be split that far *)
                          end)
           end)
  | S n' => (match f with
             | tl_nil => One f (* can't be split that far *)
             | tl_cons t f' => (match split f' n' with
                             | One f1 => One (tl_cons t f1)
                             | Two f1 k' f2 => Two (tl_cons t f1) k' f2
                             end)
             end)
  end.

Fixpoint decide_split (f : treelist) : splitpair :=
  if (Nat.leb (treelist_length f) b)
  then One f
  else split f (div_two (treelist_length f) false).

Fixpoint insert_across (s : splitpair) (f' : treelist) (n : nat) : treelist :=
  match f' with
  | tl_cons (node k f) f' =>
    (match n with
     | O =>
       (match s with
        | One f => tl_cons (node k f) f'
        | Two f1 k' f2 => tl_cons (node k' f1) (tl_cons (node k f2) f')
        end)
     | S n' => tl_cons (node k f) (insert_across s f' n')
     end)
  | tl_cons (final f) tl_nil =>
    (match n with
     | O =>
       (match s with
        | One f => tl_cons (final f) tl_nil
        | Two f1 k' f2 => tl_cons (node k' f1) (tl_cons (final f2) f')
        end)
     | S n' => tl_cons (final f) tl_nil (* This should never happen! *)
     end)
  | _ => tl_nil (* Shouldn't ever be hit. *)
  end.

Fixpoint insert_up (s : splitpair) (cn : list nat) (cf : list treelist) : cursor :=
  match (cn,cf) with
  | (n::cn,f::cf) =>
    (match decide_split (insert_across s f n) with
     | One f => (match insert_up (One f) cn cf with (cn,cf) => (n::cn,f::cf) end)
     | Two f1 k f2 =>
       (match insert_up (Two f1 k f2) cn cf with (cn,cf) =>
        if (Nat.leb (treelist_length f1) n) then ((n-(treelist_length f1))::cn, f2::cf)
        else (n::cn,f1::cf) end)
     end)
  | (_,_) => ([],[])
  end.

Fixpoint insert_val (x : key) (v : V) (n : nat) (f : treelist) : nat * treelist :=
  match f with
  | tl_cons (val k v') f =>
    (match n with
     | O => if eq_key k x then (O, tl_cons (val k v) f)
            else (S O, tl_cons (val x v) (tl_cons (val k v') f))
     | S n => match insert_val x v n f with (n, f) => (S n, tl_cons (val k v') f) end
     end)
  | tl_nil => (S O, tl_cons (val x v) tl_nil)
  | _ => (S O, tl_cons (val x v) tl_nil) (* should never happen *)
  end.

(* Returns a cursor correctly positioned for insertion
   Returns None if x is not in the range for c
 *)
Fixpoint position_for_insert (c : cursor) (x : key) : option cursor :=
  match c with (cn,cf) => (
  match next_node cn cf with
  | Some (cn1,cf1,k1) =>
    (match prev_node cn cf with
     | Some (cn2,cf2,k2) =>
        if (lt_key k1 x) then Some (cn1,cf1)
        else if negb (lt_key k2 x) then Some (cn2,cf2)
        else None
     | None => if lt_key k1 x then None else Some c
     end)
  | None =>
    (match prev_node cn cf with
     | Some (cn2,cf2,k2) => if lt_key k2 x then Some c else None
     | None => None
     end)
  end)
  end.

(* Needs to point the cursor to the right place (if it's straddling a leaf divide) *)
(* Then, insert (x,v) in (either replacing next or inserting before it) *)
(* Needs to bump the first n up to be past what was just inserted *)
(* Finally, turns that treelist into a splitpair and calls insert_up. *)
Fixpoint insert (x : key) (v : V) (c : cursor) : cursor :=
  match position_for_insert c x with
  | Some (n::cn,f::cf) =>
    (match insert_val x v n f with (n',f') =>
     (match decide_split f' with
      | One f'' => (match insert_up (One f'') cn cf with (cn',cf') => (n'::cn',f''::cf') end)
      | Two f1 k f2 =>
        (match insert_up (Two f1 k f2) cn cf with (cn',cf') =>
         if (Nat.leb (treelist_length f1) n') then ((n'-(treelist_length f1))::cn',f2::cf')
         else (n'::cn',f1::cf') end)
      end) end)
  | Some _ => ([S 0], [tl_cons (val x v) tl_nil]) (* tree must be empty *)
  | None => c
  end.

(** CURSOR_ELEMENTS *)

Fixpoint elements' (f : treelist) (base: list (key * V)) : list (key * V) :=
  match f with
  | tl_cons (node k f1) f2 => elements' f1 (elements' f2 base)
  | tl_cons (final f1) f2 => elements' f1 (elements' f2 base)
  | tl_cons (val k v) f2 => (k,v)::(elements' f2 base)
  | tl_nil => base
  end.

Fixpoint elements (f : treelist) : list (key * V) := elements' f [].

Fixpoint right_el (f : treelist) (base : list (key * V)) : list (key * V) :=
  match f with
  | tl_cons (node k f1) f2 => right_el f2 (right_el f1 base)
  | tl_cons (final f1) f2 => right_el f2 (right_el f1 base)
  | tl_cons (val k v) f2 => right_el f2 (base++[(k,v)])
  | tl_nil => base
  end.

Fixpoint left_el (f : treelist) (base : list (key * V)) : list (key * V) :=
  match f with
  | tl_cons (node k f1) f2 => left_el f1 (left_el f2 base)
  | tl_cons (final f1) f2 => left_el f1 (left_el f2 base)
  | tl_cons (val k v) f2 => (left_el f2 base) ++ [(k,v)]
  | tl_nil => base
  end.

Fixpoint cursor_right (cn : list nat) (cf : list treelist) (base : list (key * V)) : list (key * V) :=
  match (cn,cf) with
  | (n::cn,f::cf) =>
    (match point n f with (_,_,f') => cursor_right cn cf (right_el f' base) end)
  | (_,_) => base
  end.

Fixpoint cursor_left (cn : list nat) (cf : list treelist) (base : list (key * V)) : list (key * V) :=
  match (cn,cf) with
  | (n::cn,f::cf) =>
    (match point n f with (f',_,_) => cursor_left cn cf (left_el f' base) end)
  | (_,_) => base
  end.

Fixpoint cursor_elements' (cn : list nat) (cf : list treelist) (left : list (key * V)) (right : list (key * V))
  : (list (key * V)) * (list (key * V)) :=
  match (cn,cf) with
  | (n::cn,f::cf) =>
    (match point n f with (f1,_,f2) => cursor_elements' cn cf (left_el f1 left) (right_el f2 right) end)
  | (_,_) => (left,right)
  end.

Definition cursor_elements (c : cursor) : list (key * V) * list (key * V) :=
  match c with
  | (n::cn,f::cf) =>
    (match point n f with
     | (_,Some (val k v),_) => cursor_elements' (n::cn) (f::cf) [] [(k,v)]
     | _ => cursor_elements' (n::cn) (f::cf) [] [] end)
  | (_,_) => ([],[])
  end.

(**
  * PROOFS SECTION
  *)

(** Proofs about helper functions *)

Theorem max_nat_comm : forall (x y : nat),
  max_nat x y = max_nat y x.
Proof.
  induction x; destruct y; try reflexivity.
  simpl. rewrite IHx. reflexivity.
Qed.

Theorem max_nat_largest : forall (x y : nat),
  max_nat x y = x <-> x >= y.
Proof.
  induction x; destruct y; split; intros; try omega; try reflexivity.
  - inversion H.
  - inversion H. rewrite H1. apply IHx in H1. omega.
  - simpl. assert (H': x >= y). { omega. }
    apply IHx in H'. rewrite H'. reflexivity.
Qed.

Theorem max_nat_one : forall (x y z : nat),
  z = max_nat x y -> z = x \/ z = y.
Proof.
  induction x; destruct y; intros.
  - inversion H. left. reflexivity.
  - rewrite max_nat_comm in H. simpl in H. right. apply H.
  - simpl in H. left. apply H.
  - simpl in H. remember (max_nat x y) as z'. apply IHx in Heqz'.
    inversion Heqz'.
    + left. subst. reflexivity.
    + right. subst. reflexivity.
Qed.

Theorem zip_treelist : forall t tl1 tl2 tl,
  zip tl1 tl2 = tl <-> tl_cons t tl = zip (tl_cons t tl1) tl2.
Proof. intros. split.
  - intros. simpl. subst. reflexivity.
  - intros. simpl in H. inversion H. reflexivity.
 Qed.

Theorem depth_in_treelist : forall t tl tl1 tl2,
  tl = zip tl1 (tl_cons t tl2) -> tree_depth t <= treelist_depth tl.
Proof.
  intros t. induction tl; intros.
  - simpl. destruct tl1; inversion H.
  - destruct tl1.
    + simpl in H. inversion H. subst. simpl.
      remember (max_nat (tree_depth t) (treelist_depth tl2)) as z.
      assert (H': z = tree_depth t \/ z = treelist_depth tl2). { apply max_nat_one. apply Heqz. }
      inversion H'.
      * subst; omega.
      * subst. rewrite max_nat_comm in H0. apply max_nat_largest in H0. omega.
    + simpl in H. inversion H. simpl. rewrite <- H2.
      assert (H0: tree_depth t <= treelist_depth tl). { apply IHtl with tl1 tl2. apply H2. }
      remember (max_nat (tree_depth t1) (treelist_depth tl)) as z.
      assert (H': z = tree_depth t1 \/ z = treelist_depth tl). { apply max_nat_one. apply Heqz. }
      inversion H'.
      * rewrite H3. assert (H4: treelist_depth tl <= tree_depth t1).
        { apply max_nat_largest. subst. assumption. }
        omega.
      * omega.
Qed.

Theorem max_nat_least : forall x y,
  x <= max_nat x y.
Proof.
  intros. remember (max_nat x y) as z.
  assert (z = x \/ z = y). { apply max_nat_one in Heqz. apply Heqz. }
  inversion H.
  - omega.
  - rewrite H0 in Heqz. rewrite max_nat_comm in Heqz.
    assert (y >= x). { apply max_nat_largest. omega. }
    omega.
Qed.

Theorem point_lin_search : forall f n t l1 l2,
  point n f = (l1,Some t,l2) -> lin_search n f = Some t.
Proof.
  induction f; destruct n; simpl; intros.
  - inversion H.
  - inversion H.
  - inversion H. reflexivity.
  - destruct (point n f) eqn:e. destruct p. apply IHf with t2 t1.
    rewrite e. inversion H. reflexivity.
Qed.

Theorem lin_search_point : forall f n t,
  lin_search n f = Some t -> exists l1 l2, point n f = (l1,Some t,l2).
Proof.
  induction f; destruct n; simpl; intros.
  - inversion H.
  - inversion H.
  - inversion H. subst. exists tl_nil,f. reflexivity.
  - destruct (point n f) eqn:e. destruct p. apply IHf in H. inversion H. inversion H0.
    rewrite e in H1. inversion H1. subst.
    exists (tl_cons t x),x0. reflexivity.
Qed.

Lemma point_treelist_length : forall n f,
  n >= treelist_length f <-> exists f', point n f = (f',None,tl_nil).
Proof.
  induction n; destruct f; split; intros; simpl; try omega.
  - exists tl_nil. reflexivity.
  - simpl in H. inversion H.
  - simpl in H. inversion H. inversion H0.
  - exists tl_nil. reflexivity.
  - simpl in H. assert (n >= treelist_length f) by omega.
    apply IHn in H0. inversion H0. exists (tl_cons t x). rewrite H1. reflexivity.
  - simpl in H. destruct (point n f) eqn:e. destruct p. inversion H. inversion H0. subst.
    assert (n >= treelist_length f) by (apply IHn; exists t1; apply e). omega.
Qed.

Lemma point_none : forall n f f1 f2,
  point n f = (f1,None,f2) -> f2 = tl_nil.
Proof.
  induction n; intros.
  - simpl in H. destruct f; inversion H. reflexivity.
  - simpl in H. destruct f. inversion H. reflexivity.
    destruct (point n f) eqn:e. destruct p.
    inversion H. subst. apply IHn with f t1. apply e.
Qed.

Lemma point_prev : forall n f f1 f2 t f1' f2' o,
  point n f = (f1, Some t, f2) ->
  point (S n) f = (f1', o, f2') ->
  f1' = tl_app f1 (tl_cons t tl_nil).
Proof.
  induction n; intros.
  - destruct f.
    + simpl in H. inversion H.
    + simpl in H. inversion H. subst. simpl.
      simpl in H0. destruct f2; inversion H0; reflexivity.
  - simpl in H. remember (S n) as n'. simpl in H0. destruct f.
    + inversion H.
    + destruct (point n f) eqn:e. destruct p.
      destruct (point n' f) eqn:e2. destruct p.
      subst. inversion H. inversion H0. subst.
      assert (t4 = tl_app t2 (tl_cons t tl_nil)).
      { apply IHn with f f2 f2' o. apply e. apply e2. }
      simpl. rewrite H1. reflexivity.
Qed.

(** Correctness properties *)

(* Treelist in order property *)
Inductive treelist_sorted : key -> key -> treelist -> Prop :=
| ts_nil : forall ki kf, treelist_sorted ki kf tl_nil
| ts_node : forall (ki ki' kf k : key) (f f' : treelist),
    treelist_sorted ki' kf f -> (* forall x in f, ki' < x <= kf *)
    treelist_sorted ki k f' -> (* forall x in f', ki < x <= k *)
    lt_key ki' k = false -> (* k <= ki' *)
    lt_key ki k = true -> (* ki < k *)
    treelist_sorted ki kf (tl_cons (node k f') f)
| ts_final : forall (ki ki' kf : key) (f f' : treelist),
    treelist_sorted ki' kf f -> (* forall x in f, ki' < x <= kf *)
    treelist_sorted ki ki' f' -> (* forall x in f', ki < x <= ki' *)
    lt_key ki ki' = true -> (* ki < ki' *)
    treelist_sorted ki kf (tl_cons (final f') f)
| ts_val : forall (ki ki' kf k : key) (v : V) (f : treelist),
    treelist_sorted ki' kf f -> (* forall x in f, ki' < x <= kf *)
    lt_key ki' k = false -> (* k <= ki' *)
    lt_key ki k = true -> (* ki < k *)
    treelist_sorted ki kf (tl_cons (val k v) f).

Definition sorted (f : treelist) : Prop := exists ki kf, treelist_sorted ki kf f.

(* Balance property *)
Inductive balanced_treelist : nat -> treelist -> Prop :=
| bf_nil : balanced_treelist 1 tl_nil
| bf_val : forall k v f,
    balanced_treelist 1 f -> (* f is balanced with 1 level, i.e. f is a value treelist *)
    balanced_treelist 1 (tl_cons (val k v) f)
| bf_node : forall n k f f',
    balanced_treelist n f -> (* f is balanced with n levels *)
    balanced_treelist (S n) f' -> (* f' is balanced with n+1 levels *)
    balanced_treelist (S n) (tl_cons (node k f) f')
| bf_final : forall n f,
    balanced_treelist n f -> (* f is balanced with n levels *)
    balanced_treelist (S n) (tl_cons (final f) tl_nil).

(* Balance property on root *)
Definition balanced (f : treelist) : Prop := exists n, balanced_treelist n f.

Theorem balanced_rec : forall (t : tree) (f : treelist),
  balanced (tl_cons t f) -> balanced f.
Proof.
  induction t.
  - intros. inversion H. inversion H0. unfold balanced. exists (S n). apply H6.
  - intros. inversion H. inversion H0. unfold balanced. exists 1. apply bf_nil.
  - intros. inversion H. inversion H0. unfold balanced. exists 1. apply H3.
Qed.

(* Fanout property *)
Inductive fanout_restr : nat -> treelist -> Prop :=
| fr_nil : fanout_restr O tl_nil
| fr_val : forall n f k v,
    n < b ->
    fanout_restr n f ->
    fanout_restr (S n) (tl_cons (val k v) f)
| fr_node : forall n n' k f f',
    n' > div_two b false -> (* floor(b/2) *)
    fanout_restr n' f' ->
    n < b ->
    fanout_restr n f ->
    fanout_restr (S n) (tl_cons (node k f') f)
| fr_final : forall n f,
    n > div_two b false ->
    fanout_restr n f ->
    fanout_restr 1 (tl_cons (final f) tl_nil).

Definition fanout (f : treelist) : Prop := exists n, fanout_restr n f.

Theorem fanout_rec_node : forall (n : nat) (k : key) (f : treelist) (f' : treelist),
  fanout_restr n (tl_cons (node k f') f) ->
  exists (n' : nat), n' <= b /\ n' > div_two b false /\ fanout_restr n' f'.
Proof.
  intros. inversion H. subst.
  exists n'. split; try split.
  - inversion H5; omega.
  - apply H3.
  - apply H5.
Qed.

Theorem fanout_rec_final : forall (n : nat) (f : treelist) (f' : treelist),
  fanout_restr n (tl_cons (final f') f) ->
  exists (n' : nat), n' <= b /\ n' > div_two b false /\ fanout_restr n' f'.
Proof.
  intros. inversion H. subst.
  exists n0. split; try split.
  - inversion H4; try omega.
    * admit. (* Relies on b being at least 1 *)
  - apply H3.
  - apply H4.
Admitted.

Inductive cursor_correct_struct : cursor -> Prop :=
| cc_nil : cursor_correct_struct ([],[])
| cc_first : forall n f, cursor_correct_struct ([n],[f])
| cc_node : forall n n' k f f' ci ct,
    cursor_correct_struct (n::ci,f::ct) -> lin_search n f = Some (node k f') ->
    cursor_correct_struct (n'::n::ci,f'::f::ct)
| cc_final : forall n n' f f' ci ct,
    cursor_correct_struct (n::ci,f::ct) -> lin_search n f = Some (final f') ->
    cursor_correct_struct (n'::n::ci, f'::f::ct).

Inductive rec_prop (P : treelist -> Prop) : cursor -> Prop :=
| rp_nil : rec_prop P ([],[])
| rp_next : forall n f cn cf, P f -> rec_prop P (cn,cf) -> rec_prop P (n::cn,f::cf).

Definition cursor_correct (c : cursor) : Prop :=
  cursor_correct_struct c /\
  rec_prop balanced c /\
  rec_prop sorted c /\
  rec_prop fanout c.

Fixpoint get_root (cf : list treelist) : treelist :=
  match cf with
  | [] => tl_nil
  | [f] => f
  | f::cf => get_root cf
  end.

Fixpoint get_treelist (c : cursor) : treelist :=
  match c with (cn,cf) => get_root cf end.

Definition abs_rel (f : treelist) (c : cursor) : Prop :=
  cursor_correct_struct c /\ get_treelist c = f.

(** Abstraction of cursors as bi-directional list of key-value pairs
  * Proofs about this abstraction and the implementation
  *)

(* Lemma 1 *)
(* Proof that splitting into sides is equivalent -- now I can prove about the sides separately! *)
Lemma cursor_elements'_sides_equiv : forall cn cf l r,
  cursor_elements' cn cf l r = (cursor_left cn cf l, cursor_right cn cf r).
Proof.
  induction cn,cf; intros; simpl; try reflexivity.
  destruct (point a t) eqn:e. destruct p. apply IHcn.
Qed.

(* Cursor to list of elements : cons in both directions *)
(* get returns the next thing in that list! *)

Definition right_el_P (t : tree) : Prop := forall k f b,
  t = node k f \/ t = final f ->
  exists l', right_el f b = b++l'.

(* Lemma 2 *)
Lemma right_el_interior : forall f b,
  exists l', right_el f b = b++l'.
Proof.
  induction f using treelist_tree_rec with (P := right_el_P).
  - unfold right_el_P. intros. inversion H; inversion H0. subst. apply IHf.
  - unfold right_el_P. intros. inversion H; inversion H0. subst. apply IHf.
  - unfold right_el_P. intros. inversion H; inversion H0.
  - intros. unfold right_el. exists []. rewrite app_nil_r. reflexivity.
  - intros. destruct t eqn:e.
    + simpl. unfold right_el_P in IHf.
      assert (exists l', right_el t0 b0 = b0++l').
      { apply IHf with k. left. reflexivity. }
      inversion H. rewrite H0. destruct IHf0 with (b0 ++ x).
      exists (x++x0). rewrite H1. rewrite app_assoc. reflexivity.
    + simpl. unfold right_el_P in IHf.
      assert (exists l', right_el t0 b0 = b0++l').
      { apply IHf with zero. right. reflexivity. }
      inversion H. rewrite H0. destruct IHf0 with (b0 ++ x).
      exists (x ++ x0). rewrite H1. rewrite app_assoc. reflexivity.
    + simpl. destruct IHf0 with (b0 ++ [(k,v)]).
      exists ((k,v)::x). rewrite H. rewrite <- app_assoc. reflexivity.
Qed.

Definition left_el_P (t : tree) : Prop := forall k f b,
  t = node k f \/ t = final f ->
  exists l', left_el f b = b++l'.

(* Lemma 2 *)
Lemma left_el_interior : forall f b,
  exists l', left_el f b = b++l'.
Proof.
  induction f using treelist_tree_rec with (P := left_el_P).
  - unfold left_el_P. intros. inversion H; inversion H0. subst. apply IHf.
  - unfold left_el_P. intros. inversion H; inversion H0. subst. apply IHf.
  - unfold left_el_P. intros. inversion H; inversion H0.
  - intros. unfold left_el. exists []. rewrite app_nil_r. reflexivity.
  - intros. destruct t eqn:e.
    + simpl. unfold left_el_P in IHf.
      assert (exists l', left_el f b0 = b0++l'). { apply IHf0. }
      inversion H. rewrite H0. destruct IHf with k t0 (b0 ++ x).
      * left. reflexivity.
      * exists (x ++ x0). rewrite H1. rewrite app_assoc. reflexivity.
    + simpl. unfold left_el_P in IHf.
      assert (exists l', left_el f b0 = b0++l'). { apply IHf0. }
      inversion H. rewrite H0. destruct IHf with zero t0 (b0 ++ x).
      * right. reflexivity.
      * exists (x ++ x0). rewrite H1. rewrite app_assoc. reflexivity.
    + simpl. destruct IHf0 with b0. rewrite H.
      exists (x++[(k,v)]). rewrite <- app_assoc. reflexivity.
Qed.

(* Lemma 2 *)
Lemma left_rec_interior : forall cn cf l,
  exists l', cursor_left cn cf l = (l++l').
Proof.
  induction cn,cf.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. destruct (point a t) eqn:e. destruct p.
    destruct IHcn with cf (left_el t1 l). rewrite H.
    assert (exists l', left_el t1 l = l++l') by (apply left_el_interior).
    inversion H0. rewrite H1. exists (x0++x). rewrite app_assoc. reflexivity.
Qed.

(* Lemma 2 *)
Lemma right_rec_interior : forall cn cf r,
  exists r', cursor_right cn cf r = (r++r').
Proof.
  induction cn,cf.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. exists []. rewrite app_nil_r. reflexivity.
  - intros. simpl. destruct (point a t) eqn:e. destruct p.
    destruct IHcn with cf (right_el t0 r). rewrite H.
    assert (exists r', right_el t0 r = r++r') by (apply right_el_interior).
    inversion H0. rewrite H1. exists (x0++x). rewrite app_assoc. reflexivity.
Qed.

(* Lemma 3 *)
(* If you split a list, the result of the elements of the first with the elements of the second is the same *)
Lemma cursor_right_elements1 : forall cn1 cf1 cn2 cf2 b,
  length cn1 = length cf1 -> length cn2 = length cf2 ->
  cursor_right (cn1++cn2) (cf1++cf2) b = cursor_right cn2 cf2 (cursor_right cn1 cf1 b).
Proof.
  induction cn1,cf1; intros; simpl.
  - reflexivity.
  - inversion H.
  - inversion H.
  - inversion H. clear H.
    destruct (point a t) eqn:e. destruct p.
    apply IHcn1. apply H2. apply H0.
Qed.

(* Lemma 3 *)
Lemma cursor_left_elements1 : forall cn1 cf1 cn2 cf2 b,
  length cn1 = length cf1 -> length cn2 = length cf2 ->
  cursor_left (cn1++cn2) (cf1++cf2) b = cursor_left cn2 cf2 (cursor_left cn1 cf1 b).
Proof.
  induction cn1,cf1; intros; simpl.
  - reflexivity.
  - inversion H.
  - inversion H.
  - inversion H. clear H.
    destruct (point a t) eqn:e. destruct p.
    apply IHcn1. apply H2. apply H0.
Qed.

(* List in increasing order *)
Inductive sorted_less : Z -> list (key * V) -> Prop :=
| sl_nil : forall n, sorted_less n []
| sl_next : forall k v n l,
  lt_key k n = true -> sorted_less n l -> sorted_less k ((k,v)::l).

(* List in decreasing order *)
Inductive sorted_more : list (key * V) -> Prop :=
| sm_nil : sorted_more []
| sm_one : forall k v, sorted_more [(k,v)]
| sm_next : forall k1 v1 k2 v2 l,
  lt_key k2 k1 = true -> sorted_more ((k2,v2)::l) -> sorted_more ((k1,v1)::(k2,v2)::l).

(* Lemma 4 *)
Lemma cursor_right_el_sorted : forall cn cf n,
  cursor_correct (cn,cf) -> sorted_less n (cursor_right cn cf []).
Proof.
  induction cn,cf; intros.
  - simpl. apply sl_nil.
  - simpl. apply sl_nil.
  - simpl. apply sl_nil.
  - simpl. destruct H. destruct H0. destruct H1. inversion H1. subst.
    remember (a::cn). destruct H1 eqn:e. admit.
Admitted.

(* Lemma 4 *)
Lemma cursor_left_el_sorted : forall cn cf,
  cursor_correct (cn,cf) -> sorted_more (cursor_left cn cf []).
Proof. Admitted.

(** Theorems about next_node and prev_node *)

(* Helper for Invariants *)
Lemma point_next : forall f n f1 f1' f2 f2' o t,
  point n f = (f1, o, f2) ->
  point (S n) f = (f1', Some t, f2') ->
  f2 = tl_cons t f2'.
Proof.
  induction f.
  - intros. inversion H0.
  - intros. destruct n.
    + simpl in H. simpl in H0. destruct f.
      * inversion H0.
      * inversion H. inversion H0. reflexivity.
    + simpl in H. remember (S n) as n'. simpl in H0.
      destruct (point n f) eqn:e. destruct p. inversion H. subst. clear H.
      destruct (point (S n) f) eqn:e'. destruct p. inversion H0. subst. clear H0.
      apply IHf with n t2 t3 o. apply e. apply e'.
Qed.

Theorem cursor_right_elements4 : forall cn cf cn' cf' n f k f' t l1 l2 b k',
  cursor_correct_struct (cn,cf) ->
  next_node cn cf = Some (n::cn',f::cf',k') ->
  (* (cn,cf) <> (n::cn',f::cf') -> *)
  point n f = (l1,Some t,l2) ->
  t = node k f' \/ t = final f' ->
  cursor_right cn cf b = cursor_right (n::cn') (f::cf') (right_el f' b).
Proof.
  induction cn,cf; intros.
  - simpl in H0. inversion H0.
  - simpl in H0. inversion H0.
  - simpl in H0. inversion H0.
  - simpl in H0. destruct (point a t) eqn:e. destruct p. destruct o; try (destruct t3); destruct t1.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      * inversion H0.
      * inversion H0.
      * destruct (point n0 t1) eqn:e3. destruct p.
        destruct o. destruct t6.
        { inversion H0. subst. clear H0.
          simpl. rewrite e. destruct f. inversion H1.
          rewrite e3. simpl.
          assert (cursor_right cn cf b0 = cursor_right (n0::l) (t1::l0) (right_el (tl_cons t6 f) b0)).
          { apply IHcn with k2 (node k2 (tl_cons t6 f)) t5 t4 k'.
            inversion H. subst. apply cc_nil. apply H4. apply H4.
            apply e2.
            apply e3.
            left. reflexivity. }
          rewrite H0. simpl. rewrite e3. simpl in H1. inversion H1. subst.
          destruct H2. rewrite H2. reflexivity. rewrite H2. reflexivity. }
        { inversion H0. subst. clear H0.
          simpl. rewrite e. destruct f. inversion H1.
          rewrite e3. simpl.
          assert (cursor_right cn cf b0 = cursor_right (n0::l) (t1::l0) (right_el (tl_cons t6 f) b0)).
          { apply IHcn with k (final (tl_cons t6 f)) t5 t4 k'.
            inversion H. subst. apply cc_nil. apply H4. apply H4.
            apply e2.
            apply e3.
            right. reflexivity. }
          rewrite H0. simpl. rewrite e3. simpl in H1. inversion H1. subst.
          destruct H2. rewrite H2. reflexivity. rewrite H2. reflexivity. }
        { inversion H0. }
        { inversion H0. }
      * inversion H0.
    + destruct t1.
      * inversion H0. subst. remember (S a) as a'. simpl. rewrite e. rewrite H1.
        assert (tl_cons (node k1 t1) t4 = tl_cons t0 l2).
        { apply point_next with f a t2 l1 (Some (node k' t3)). apply e. subst. apply H1. }
        inversion H3. subst. inversion H2; inversion H4. subst.
        simpl. reflexivity.
      * inversion H0. subst. remember (S a) as a'. simpl. rewrite e. rewrite H1.
        assert (tl_cons (final t1) t4 = tl_cons t0 l2).
        { apply point_next with f a t2 l1 (Some (node k' t3)). apply e. subst. apply H1. }
        inversion H3. subst. inversion H2; inversion H4. subst.
        simpl. reflexivity.
      * admit. (* e: node and val in same treelist *)
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H0.
      inversion H0.
      destruct (point n0 t1) eqn:e3. destruct p. destruct o. destruct t6.
      { inversion H0. subst. clear H0.
        simpl. rewrite e. destruct f. inversion H1.
        rewrite e3. simpl.
        assert (cursor_right cn cf b0 = cursor_right (n0::l) (t1::l0) (right_el (tl_cons t6 f) b0)).
          { apply IHcn with k1 (node k1 (tl_cons t6 f)) t5 t4 k'.
            inversion H. subst. apply cc_nil. apply H4. apply H4.
            apply e2.
            apply e3.
            left. reflexivity. }
          rewrite H0. simpl. rewrite e3. simpl in H1. inversion H1. subst.
          destruct H2. rewrite H2. reflexivity. rewrite H2. reflexivity. }
      { inversion H0. subst. clear H0.
        simpl. rewrite e. destruct f. inversion H1.
        rewrite e3. simpl.
        assert (cursor_right cn cf b0 = cursor_right (n0::l) (t1::l0) (right_el (tl_cons t6 f) b0)).
          { apply IHcn with k (final (tl_cons t6 f)) t5 t4 k'.
            inversion H. subst. apply cc_nil. apply H4. apply H4.
            apply e2.
            apply e3.
            right. reflexivity. }
          rewrite H0. simpl. rewrite e3. simpl in H1. inversion H1. subst.
          destruct H2. rewrite H2. reflexivity. rewrite H2. reflexivity. }
      { inversion H0. }
      { inversion H0. }
      { inversion H0. }
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H0.
      inversion H0.
      destruct (point n0 t5) eqn:e3. destruct p. destruct o. destruct t8.
      { inversion H0. subst. clear H0.
        simpl. rewrite e. destruct f. inversion H1.
        rewrite e3. simpl. admit. }
      admit. admit. admit. admit.
    + admit.
    + admit.
    + admit.
    + admit.
Admitted.

(* Helper for invariant *)
Lemma left_el_app : forall f1 f2 b,
  left_el (tl_app f1 f2) b = left_el f1 (left_el f2 b).
Proof.
  induction f1; intros.
  - reflexivity.
  - simpl. rewrite IHf1. reflexivity.
Qed.

Theorem cursor_left_elements4 : forall cn cf cn' cf' n f b f1 o f2 k,
  cursor_correct_struct (n::cn,f::cf) ->
  next_node (n::cn) (f::cf) = Some (cn',cf',k) ->
  (cn',cf') <> (n::cn,f::cf) ->
  point n f = (f1,o,f2) -> exists k f',
  (o = Some (node k f') /\ cursor_left (n::cn) (f::cf) (left_el f' b) = cursor_left cn' cf' b) \/
  (o = Some (final f') /\ cursor_left (n::cn) (f::cf) (left_el f' b) = cursor_left cn' cf' b) \/
  (o = None /\ cursor_left (n::cn) (f::cf) b = cursor_left cn' cf' b).
Proof.
  induction cn,cf; intros.
  - simpl in H0. rewrite H2 in H0. destruct o. destruct t.
    + exists k0,t. left. split. reflexivity. destruct f2. 2:destruct t0.
      * inversion H0.
      * inversion H0. remember (S n) as n'. simpl.
        destruct (point n f) eqn:e1. destruct p.
        destruct (point n' f) eqn:e2. destruct p.
        assert (t4 = tl_app t2 (tl_cons (node k t) tl_nil)).
        { apply point_prev with n f t1 t3 o0. inversion H2. subst. apply e1.
          rewrite <- Heqn'. apply e2. }
        rewrite H3. rewrite left_el_app. reflexivity.
      * inversion H0. remember (S n) as n'. simpl.
        destruct (point n f) eqn:e1. destruct p.
        destruct (point n' f) eqn:e2. destruct p.
        assert (t4 = tl_app t2 (tl_cons (node k t) tl_nil)).
        { apply point_prev with n f t1 t3 o0. inversion H2. subst. apply e1.
          rewrite <- Heqn'. apply e2. }
        rewrite H3. rewrite left_el_app. reflexivity.
      * inversion H0.
    + inversion H0.
    + inversion H0. subst. destruct H1. reflexivity.
    + inversion H0.
  - inversion H.
  - inversion H.
  - remember (a::cn) as cn1. remember (t::cf) as cf1.
    simpl in H0. rewrite H2 in H0.
    destruct (next_node cn1 cf1) eqn:e1; try (destruct p; destruct c);
    destruct o eqn:e2; destruct f2.
    + destruct l. 2:destruct l0.
      destruct t0. inversion H0. inversion H0. inversion H0. subst. destruct H1. reflexivity.
      destruct t0. inversion H0. inversion H0. inversion H0. subst. destruct H1. reflexivity.
      destruct t0. destruct (point n0 t1) eqn:e3. destruct p.
      destruct o0. destruct t4.
      { exists k1,t0. left. split. reflexivity.
        inversion H0. remember (n0::l) as cn2. remember (t1::l0) as cf2.
        simpl. rewrite H2. destruct t4. admit. (* shouldn't be possible, because it would be a whole nil treelist *)
        simpl. admit. }
      admit.
      admit.
      admit.
      admit.
      admit.
    + admit.
    + admit.
    + admit.
    + admit.
    + admit.
    + admit.
    + admit.
Admitted.

(* Lemma 5 *)
Theorem next_correct_struct : forall cn cf c k,
  cursor_correct_struct (cn,cf) -> next_node cn cf = Some (c,k) -> cursor_correct_struct c.
Proof.
  induction cn,cf.
  - intros; simpl. simpl in H0. inversion H0.
  - intros; simpl. inversion H.
  - intros; simpl. inversion H.
  - intros. inversion H.
    + subst. simpl in H0. destruct (point a t) eqn:e. destruct p.
      destruct o. destruct t2; destruct t0; try (inversion H0).
      destruct t0; inversion H0; apply cc_first.
      apply H.
      apply cc_first.
      inversion H0.
    + subst. remember (n::ci) as cn'. remember (f::ct) as cf'.
      simpl in H0. destruct (point a t) eqn:e. destruct p.
      destruct o; destruct t0.
      * destruct t2. destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t2) eqn:e3. destruct p. destruct o. destruct t5.
        { inversion H0. apply cc_node with k3. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t2) eqn:e3. destruct p. destruct o. destruct t5.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        inversion H0. apply H.
      * destruct t2; destruct t0.
        { inversion H0. inversion H. apply cc_first. apply cc_node with k3.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k2.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t6.
        { inversion H0. apply cc_node with k4. apply IHcn with cf' k3. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k3. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t4) eqn:e3. destruct p. destruct o. destruct t7.
        { inversion H0. apply cc_node with k3. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t4) eqn:e3. destruct p. destruct o. destruct t7.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t6.
        { inversion H0. apply cc_node with k3. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k3.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k2.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k3.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
      * destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t4.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t3 t2. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t3 t2. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
      * apply point_none in e. inversion e.
    + subst. remember (n::ci) as cn'. remember (f::ct) as cf'.
      simpl in H0. destruct (point a t) eqn:e. destruct p.
      destruct o; destruct t0.
      * destruct t2. destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t2) eqn:e3. destruct p. destruct o. destruct t5.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t2) eqn:e3. destruct p. destruct o. destruct t5.
        { inversion H0. apply cc_node with k1. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t4 t3. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        inversion H0. apply H.
      * destruct t2; destruct t0.
        { inversion H0. inversion H. apply cc_first. apply cc_node with k2.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k1.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t6.
        { inversion H0. apply cc_node with k3. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k2. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t4) eqn:e3. destruct p. destruct o. destruct t7.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t4) eqn:e3. destruct p. destruct o. destruct t7.
        { inversion H0. apply cc_node with k1. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t6 t5. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t6.
        { inversion H0. apply cc_node with k2. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k1. apply H3. apply e2.
          apply point_lin_search with t5 t4. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k2.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k1.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
        { inversion H0. inversion H. apply cc_first. apply cc_node with k2.
          apply H7. apply H10. apply cc_final. apply H7. apply H10. }
      * destruct (next_node cn' cf') eqn:e2. destruct p. destruct c0.
        destruct l. inversion H0. destruct l0. inversion H0.
        destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t4.
        { inversion H0. apply cc_node with k1. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t3 t2. apply e3. }
        { inversion H0. apply cc_final. apply IHcn with cf' k0. apply H3. apply e2.
          apply point_lin_search with t3 t2. apply e3. }
        { inversion H0. }
        { inversion H0. }
        { inversion H0. }
      * apply point_none in e. inversion e.
Qed.

(* Helper for Lemma 5 *)
Lemma balance_carries_one : forall n f k f',
  balanced f ->
  (lin_search n f = Some (node k f') \/ lin_search n f = Some (final f')) ->
  balanced f'.
Proof.
  induction n; intros; destruct f.
  - inversion H0; inversion H1.
  - inversion H0; inversion H1; rewrite H3 in H; inversion H; inversion H2; subst.
    unfold balanced. exists n. apply H7.
    unfold balanced. exists n. apply H6.
  - inversion H0; inversion H1.
  - simpl in H0. apply IHn with f k.
    + inversion H. inversion H1; subst.
      exists 1. apply H4.
      exists (S n0). apply H6.
      exists 1. apply bf_nil.
    + apply H0.
Qed.

(* Helper for Lemma 5 *)
Lemma balance_carries : forall cn cf n f,
  cursor_correct_struct (n::cn,f::cf) ->
  rec_prop balanced (cn,cf) ->
  cn <> [] ->
  rec_prop balanced (n::cn,f::cf).
Proof.
  intros. inversion H0. destruct H1. auto.
  subst. apply rp_next. 2:apply H0.
  inversion H4. inversion H.
  - subst. apply balance_carries_one with n0 f0 k. apply H4. left. apply H12.
  - subst. apply balance_carries_one with n0 f0 Z0. apply H4. right. apply H12.
Qed.

(* Lemma 5 *)
Lemma next_node_balanced : forall cn cf c k,
  cursor_correct_struct (cn,cf) -> rec_prop balanced (cn,cf) ->
  next_node cn cf = Some (c,k) -> rec_prop balanced c.
Proof.
  induction cn,cf; intros.
  - inversion H1.
  - inversion H1.
  - inversion H1.
  - inversion H0. subst.
    assert (cursor_correct_struct (cn,cf)).
    { inversion H; subst. apply cc_nil. apply H5. apply H5. }
    assert (IHpart: forall c k, next_node cn cf = Some (c,k) -> rec_prop balanced c).
    { intros. apply IHcn with cf k0. apply H2. apply H7. apply H3. }
    assert (cursor_correct_struct c).
    { apply next_correct_struct with (a::cn) (t::cf) k. apply H. apply H1. }
    inversion H1. destruct (point a t) eqn:e1. destruct p.
    destruct o; try (destruct t2); destruct t0.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. destruct (point n t0). destruct p.
      2:inversion H6. destruct o. 2:inversion H6. destruct t5. 3:inversion H6.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k1. reflexivity.
        intros Hcontra. inversion Hcontra.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k1. reflexivity.
        intros Hcontra. inversion Hcontra.
    + destruct t0.
      { inversion H6. apply rp_next. apply H4. apply H7. }
      { inversion H6. apply rp_next. apply H4. apply H7. }
      destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. 2:inversion H6.
      destruct (point n t0) eqn:e3. destruct p. destruct o. destruct t6.
      { inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k2. reflexivity.
        intros Hcontra. inversion Hcontra. }
      { inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k2. reflexivity.
        intros Hcontra. inversion Hcontra. }
      inversion H6. inversion H6.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. destruct (point n t0). destruct p.
      2:inversion H6. destruct o. 2:inversion H6. destruct t5. 3:inversion H6.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. destruct (point n t4). destruct p.
      2:inversion H6. destruct o. 2:inversion H6. destruct t7. 3:inversion H6.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
    + inversion H6. apply H0.
    + inversion H6. apply H0.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. destruct (point n t0). destruct p.
      2:inversion H6. destruct o. 2:inversion H6. destruct t4. 3:inversion H6.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
    + destruct (next_node cn cf) eqn:e2. destruct p. destruct c0. destruct l. 2:destruct l0.
      inversion H6. inversion H6. destruct (point n t3). destruct p.
      2:inversion H6. destruct o. 2:inversion H6. destruct t6. 3:inversion H6.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
      * inversion H6. apply balance_carries.
        rewrite H8. apply H3.
        apply IHpart with k0. reflexivity.
        intros Hcontra. inversion Hcontra.
Qed.

(* Lemma 5 *)
Lemma next_node_sorted : forall cn cf c k,
  cursor_correct_struct (cn,cf) -> rec_prop sorted (cn,cf) ->
  next_node cn cf = Some (c,k) -> rec_prop sorted c.
Proof. Admitted.

(* Lemma 5 *)
Lemma next_node_fanout : forall cn cf c k,
  cursor_correct_struct (cn,cf) -> rec_prop fanout (cn,cf) ->
  next_node cn cf = Some (c,k) -> rec_prop fanout c.
Proof. Admitted.

(* Lemma 5 *)
Lemma next_node_correct : forall cn cf c k,
  cursor_correct (cn,cf) -> next_node cn cf = Some (c,k) -> cursor_correct c.
Proof.
  intros. destruct H. destruct H1. destruct H2.
  unfold cursor_correct. split. 2:split. 3:split.
  - apply next_correct_struct with cn cf k. apply H. apply H0.
  - apply next_node_balanced with cn cf k. apply H. apply H1. apply H0.
  - apply next_node_sorted with cn cf k. apply H. apply H2. apply H0.
  - apply next_node_fanout with cn cf k. apply H. apply H3. apply H0.
Qed.

Lemma next_node_none : forall cn cf cn' cf' k,
  next_node cn cf = Some (cn',cf',k) ->
  cn' <> [] /\ cf' <> [].
Proof.
  induction cn,cf; intros.
  - simpl in H. inversion H.
  - simpl in H. inversion H.
  - simpl in H. inversion H.
  - simpl in H. destruct (point a t) eqn:e. destruct p.
    destruct t0; destruct o. destruct t0.
    * destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t2) eqn:e3. destruct p.
      destruct o; try (destruct t5); inversion H; split; intros Hcontra; inversion Hcontra.
      inversion H.
    * destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t2) eqn:e3. destruct p.
      destruct o; try (destruct t5); inversion H; split; intros Hcontra; inversion Hcontra.
      inversion H.
    * inversion H. split; intros Hcontra; inversion Hcontra.
    * destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t0) eqn:e3. destruct p.
      destruct o; try (destruct t4); inversion H; split; intros Hcontra; inversion Hcontra.
      inversion H.
    * destruct t3; destruct t0.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t0) eqn:e3. destruct p. destruct o. destruct t6.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. inversion H. inversion H.
      destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t4) eqn:e3. destruct p. destruct o. destruct t7.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. inversion H. inversion H.
      destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t4) eqn:e3. destruct p. destruct o. destruct t7.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. inversion H. inversion H.
      destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t0) eqn:e3. destruct p. destruct o. destruct t6.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. inversion H. inversion H.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
    * destruct (next_node cn cf) eqn:e2. destruct p. destruct c; destruct l. 2:destruct l0.
      inversion H. inversion H.
      destruct (point n t3) eqn:e3. destruct p. destruct o. destruct t6.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. split; intros Hcontra; inversion Hcontra.
      inversion H. inversion H. inversion H.
Qed.

(* Lemma 6 *)
Lemma prev_node_correct : forall cn cf c k,
  cursor_correct (cn,cf) -> prev_node cn cf = Some (c,k) -> cursor_correct c.
Proof. Admitted.

Lemma prev_node_none : forall cn cf cn' cf' k,
  prev_node cn cf = Some (cn',cf',k) ->
  cn' <> [] /\ cf' <> [].
Proof. Admitted.

(* Lemma 7 *)
Lemma cursor_elements_next : forall cn cf c k,
  cursor_correct_struct (cn,cf) ->
  next_node cn cf = Some (c,k) ->
  cursor_elements (cn,cf) = cursor_elements c.
Proof.
  intros. destruct cn,cf.
  - inversion H0.
  - inversion H0.
  - inversion H0.
  - simpl in H0. destruct (point n t) eqn:e. destruct p.
    destruct o. destruct t2.
    + admit. (* e should only have vals *)
    + admit. (* ditto *)
    + destruct t0. inversion H0. reflexivity.
      destruct t0. admit. admit. (* ditto *) inversion H0. reflexivity.
    + destruct t0. destruct (next_node cn cf) eqn:e2. destruct p. destruct c0.
      destruct l. 2:destruct l0. inversion H0. inversion H0.
      destruct (point n0 t0) eqn:e3. destruct p. destruct o. destruct t4.
      admit. admit. admit. admit. admit. admit.
Admitted.

(* Lemma 7 *)
Lemma cursor_elements_prev : forall cn cf c k,
  cursor_correct_struct (cn,cf) ->
  prev_node cn cf = Some (c,k) ->
  cursor_elements (cn,cf) = cursor_elements c.
Proof. Admitted.

(** Proofs about make_cursor *)

Fixpoint dec (n : nat) (f : treelist) : treelist :=
  match n with
  | O => f
  | S n' =>
    (match f with
     | tl_cons t f' => dec n' f'
     | tl_nil => tl_nil
     end)
  end.

Definition mc_correct_P (x : key) (t : tree) : Prop := forall k f n ci ct,
  t = node k f \/ t = final f ->
  cursor_correct_struct (n::ci,f::ct) ->
  cursor_correct_struct (make_cursor_rec x f ci (f::ct) O).

Lemma dec_nil : forall n,
  dec n tl_nil = tl_nil.
Proof. destruct n; reflexivity. Qed.

Lemma dec_cont : forall f n,
  dec (S n) f = dec 1 (dec n f).
Proof.
  induction f; intros.
  - simpl. destruct n; reflexivity.
  - induction n.
    + reflexivity.
    + replace (dec (S (S n)) (tl_cons t f)) with (dec (S n) f).
      replace (dec (S n) (tl_cons t f)) with (dec n f).
      apply IHf. reflexivity. reflexivity.
Qed.

Lemma dec_lin_search : forall n f t f'',
  dec n f = tl_cons t f'' -> lin_search n f = Some t.
Proof.
  induction n; intros.
  - simpl in H. rewrite H. reflexivity.
  - simpl in H. destruct f. inversion H. simpl.
    apply IHn with f''. apply H.
Qed.

(* Lemma 8 *)
Lemma make_cursor_rec_correct : forall x f' n ci ct n' f,
  cursor_correct_struct (n::ci,f::ct) ->
  dec n' f = f' ->
  cursor_correct_struct (make_cursor_rec x f' ci (f::ct) n').
Proof.
  intros x. induction f' using treelist_tree_rec with (P := mc_correct_P x); try unfold mc_correct_P; intros.
  - inversion H; inversion H1. subst.
    apply IHf' with O. inversion H0.
    + apply cc_first.
    + apply cc_node with k. apply H4. apply H7.
    + apply cc_final. apply H4. apply H7.
    + reflexivity.
  - inversion H; inversion H1. subst.
    apply IHf' with O. inversion H0.
    + apply cc_first.
    + apply cc_node with k0. apply H4. apply H7.
    + apply cc_final. apply H4. apply H7.
    + reflexivity.
  - inversion H; inversion H1.
  - simpl. inversion H.
    + apply cc_first.
    + apply cc_node with k. apply H3. apply H6.
    + apply cc_final. apply H3. apply H6.
  - unfold mc_correct_P in IHf'. simpl. destruct t eqn:e. destruct (lt_key k x). 4:destruct (lt_key k x).
    + apply IHf'0 with n. apply H. rewrite dec_cont. rewrite H0. reflexivity.
    + apply IHf' with k O. left. reflexivity.
      * inversion H; subst.
        { apply cc_node with k. apply cc_first. apply dec_lin_search with f'. apply H0. }
        { apply cc_node with k. apply cc_node with k0. apply H3. apply H6. apply dec_lin_search with f'. apply H0. }
        { apply cc_node with k. apply cc_final. apply H3. apply H6. apply dec_lin_search with f'. apply H0. }
    + destruct f'. 2:apply cc_nil. apply IHf' with x O. right. reflexivity.
      * inversion H; subst.
        { apply cc_final. apply cc_first. apply dec_lin_search with tl_nil. apply H0. }
        { apply cc_final. apply cc_node with k. apply H3. apply H6. apply dec_lin_search with tl_nil. apply H0. }
        { apply cc_final. apply cc_final. apply H3. apply H6. apply dec_lin_search with tl_nil. apply H0. }
    + apply IHf'0 with n. apply H. rewrite dec_cont. rewrite H0. reflexivity.
    + inversion H; subst.
      * apply cc_first.
      * apply cc_node with k0. apply H3. apply H6.
      * apply cc_final. apply H3. apply H6.
Qed.

(* Lemma 8 *)
Lemma make_cursor_correct : forall x f,
  cursor_correct_struct (make_cursor x f).
Proof.
  intros. unfold make_cursor. apply make_cursor_rec_correct with O.
  - apply cc_first.
  - reflexivity.
Qed.

(* Lemma 9 *)
Lemma make_cursor_right : forall cn cf x f k v l,
  make_cursor x f = (cn,cf) ->
  cursor_right cn cf [] = (k,v)::l ->
  lt_key k x <> true.
Proof. Admitted.

(* Lemma 9 *)
Lemma make_cursor_left : forall cn cf x f k v l,
  make_cursor x f = (cn,cf) ->
  cursor_left cn cf [] = (k,v)::l ->
  lt_key k x = true.
Proof. Admitted.

(** Proofs about move_to_next and move_to_prev *)

(* Lemma 10 *)
Lemma move_to_next_correct : forall c,
  cursor_correct c ->
  cursor_correct (move_to_next c).
Proof.
  intros. destruct c. simpl. destruct (next_node l l0) eqn:e.
  destruct p. destruct c. destruct l1.
  - apply H.
  - assert (cursor_correct (n::l1,l2)).
    { apply next_node_correct with l l0 k. apply H. apply e. }
    destruct H0. destruct H1. destruct H2.
    split. 2:split. 3:split.
    + inversion H0. apply cc_first.
      apply cc_node with k0. apply H6. apply H8.
      apply cc_final. apply H6. apply H8.
    + inversion H1. apply rp_next. apply H6. apply H8.
    + inversion H2. apply rp_next. apply H6. apply H8.
    + inversion H3. apply rp_next. apply H6. apply H8.
  - apply H.
Qed.

(* Lemma 10 *)
Lemma move_to_prev_correct : forall c,
  cursor_correct c ->
  cursor_correct (move_to_prev c).
Proof. Admitted.

(* Lemma 11 *)
Lemma move_to_next_el : forall c l r k v,
  cursor_correct c ->
  cursor_elements c = (l,(k,v)::r) ->
  cursor_elements (move_to_next c) = ((k,v)::l,r).
Proof. Admitted.

(* Lemma 12 *)
Lemma move_to_prev_el : forall c l r k v,
  cursor_correct c ->
  cursor_elements c = ((k,v)::l,r) ->
  cursor_elements (move_to_next c) = (l,(k,v)::r).
Proof. Admitted.

(* Lemma 13 *)
Lemma move_to_next_none : forall cn cf,
  cursor_correct (cn,cf) ->
  (cursor_right cn cf [] = [] <-> move_to_next (cn,cf) = (cn,cf)).
Proof. Admitted.

(* Lemma 13 *)
Lemma move_to_prev_none : forall cn cf,
  cursor_correct (cn,cf) ->
  (cursor_left cn cf [] = [] <-> move_to_prev (cn,cf) = (cn,cf)).
Proof. Admitted.

(** Proofs about GET *)

(* Lemma 14 *)
Lemma get_correct : forall cn cf k v l,
  cursor_correct (cn,cf) ->
  cursor_right cn cf [] = (k,v)::l ->
  get_tree (cn,cf) = Some (val k v).
Proof. Admitted.

(** Proofs about INSERT *)

Definition key_rel (k : key) (c : cursor) : bool :=
  match get_key c with
  | Some k1 =>
    (match get_key (move_to_prev c) with
     | Some k2 => if andb (lt_key k2 k) (negb (lt_key k1 k)) then true else false
     | None => if negb (lt_key k1 k) then true else false
     end)
  | None =>
    (match get_key (move_to_prev c) with
     | Some k2 => if lt_key k2 k then true else false
     | None => true
     end)
  end.

(* Lemma 15 *)
Lemma bad_cursor_insert_same : forall c k v,
  key_rel k c <> true -> insert k v c = c.
Proof. Admitted.

(* Lemma 16 *)
Lemma insert_correct : forall c k v,
  cursor_correct c -> cursor_correct (insert k v c).
Proof. Admitted.

(* Lemma 17 *)
Lemma insert_eq_elements : forall c k v' v l r,
  cursor_elements c = (l,(k,v')::r) -> cursor_elements (insert k v c) = (l,(k,v)::r).
Proof. Admitted.

(* Theorem 18 *)
Lemma insert_neq_elements : forall c k v l r,
  get_key c <> Some k -> cursor_elements c = (l,r) -> cursor_elements (insert k v c) = ((k,v)::l,r).
Proof. Admitted.

(** Tests *)

Compute (treelist_depth ex_treelist).

Compute (treelist_depth ex_treelist').

Compute (treelist_depth ex_treelist'').

Example b1: balanced ex_treelist.
Proof.
  unfold balanced. exists 2%nat.
  unfold ex_treelist.
  apply bf_node.
  - apply bf_val. apply bf_val. apply bf_nil.
  - apply bf_final. apply bf_val. apply bf_nil.
Qed.

End BTREES.