Module OTT := OrdersFacts.OrderedTypeTest K.Local Notation "'key'" := K.t.Module E := K.Inductive color := Red | Black.Inductive color := Red | Black.Inductive color := Red | Black.Inductive tree  : Type :=
 | EE : tree
 | T: color -> tree -> key -> tree -> tree.Inductive tree  : Type :=
 | EE : tree
 | T: color -> tree -> key -> tree -> tree.Inductive tree  : Type :=
 | EE : tree
 | T: color -> tree -> key -> tree -> tree.Fixpoint member (x: key) (t : tree) : bool :=
  match t with
  | EE => false
  | T _ tl k tr => match K.compare x k with
                          | Lt => member x tl
                          | Eq => true
                          | Gt => member x tr
                          end
  end.Definition balance color t1 k t2 :=
 match color with Red => T Red t1 k t2
 | _ =>
 match t1, t2 with
 | T Red (T Red a x b) y c, d => T Red (T Black a x b) y (T Black c k d)
 | T Red a x (T Red b y c), d => T Red (T Black a x b) y (T Black c k d)
 | a, T Red (T Red b y c) z d => T Red (T Black a k b) y (T Black c z d)
 | a, T Red b y (T Red c z d) => T Red (T Black a k b) y (T Black c z d)
 | _, _ => T Black t1 k t2
  end
 end.Fixpoint ins x s :=
 match s with
 | EE => T Red EE x EE
 | T c a y b => match K.compare x y with
                       | Lt => balance c (ins x a) y b
                       | Eq => T c a x b
                       | Gt => balance c a y (ins x b)
                       end
 end.Definition makeBlack t :=
  match t with
  | EE => EE
  | T _ a x b => T Black a x b
  end.Definition insert x s := makeBlack (ins x s).Fixpoint ins' x s :=
 match s with
 | EE => Some (T Red EE x EE)
 | T c a y b => match K.compare x y with
                       | Lt => match ins' x a with
                                   | None => None
                                   | Some s' => Some (balance c s' y b)
                                   end
                       | Eq => None
                       | Gt => match ins' x b with
                                   | None => None
                                   | Some s' => Some (balance c a y s')
                                   end
                       end
 end.Definition mem_add' x s :=
    match ins' x s with
    | None => None
    | Some s' => Some (makeBlack s')
    end.(* The next several definitions are to handle deletion, which is quite complex! *)

Definition balance' tl k tr :=
    match tl , tr with
    | T Red (T Red a x b) y c, d => T Red (T Black a x b) y (T Black c k d)
    | T Red a x (T Red b y c), d => T Red (T Black a x b) y (T Black c k d)
    | a, T Red b y (T Red c z d) => T Red (T Black a k b) y (T Black c z d)
    | a, T Red (T Red b y c) z d => T Red (T Black a k b) y (T Black c z d)
    | _ , _ => T Black tl k tr
    end.Definition sub1 t :=
  match t with
  | EE => EE
  | T _ a x b => T Red a x b
  end.Definition balleft tl k tr :=
  match tl with
  | T Red a x b => T Red (T Black a x b) k tr
  | _ => match tr with
             | T Black a y b => balance' tl k (T Red a y b)
             | T Red (T Black a y b) z c => T Red (T Black tl k a) y (balance' b z (sub1 c))
             | _ => T Red tl k tr (* impossible *)
            end
  end.Definition balright tl k tr :=
  match tr with
  | T Red b y c => T Red tl k (T Black b y c)
  | _ => match tl with
             | T Black a x b => balance' (T Red a x b) k tr
             | T Red a x (T Black b y c) => T Red (balance' (sub1 a) x b) y (T Black c k tr)
             | _ => T Red tl k tr (* impossible *)
            end
  end.Fixpoint size t := match t with EE => 0 | T _ tl _ tr => 1 + size tl + size tr end.Function append (tlr: tree*tree) {measure (fun tlr => size (fst tlr) + size (snd tlr)) tlr} : tree :=
 match tlr with
 | (EE, x) => x
 | (x, EE) => x
 | (T Red a x b, T Red c y d) =>
   match append (b,c) with
   | T Red b' z c' => T Red (T Red a x b') z (T Red c' y d)
   | bc => T Red a x (T Red bc y d)
   end
 | (T Black a x b, T Black c y d) =>
   match append (b,c) with
   | T Red b' z c' => T Red (T Black a x b') z (T Black c' y d)
   | bc => balleft a x (T Black bc y d)
   end
 | (a, T Red b x c) => T Red (append(a,b)) x c
 | (T Red a x b, c) => T Red a x (append(b,c))
 end.Fixpoint del x t :=
 match t with
 | EE => EE
 | T _ a y b =>
   match K.compare x y with
   | Lt => match a with
               | T Black _ _ _ => balleft (del x a) y b
               | _ => T Red (del x a) y b
               end
   | Gt => match b with
               | T Black _ _ _ => balright a y (del x b)
               | _ => T Red a y (del x b)
               end
   | Eq => append(a,b)
   end
  end.Definition delete x t :=
   match del x t with
   | T _ a y b => T Black a y b
   | EE => EE
   end.Fixpoint choose' (t : tree) : option key :=
  match t with
  | EE => None
  | T _ EE k tr => Some k
  | T _ tl k tr => choose' tl
  end.Fixpoint max_elt' (t : tree) : option key :=
  match t with
  | EE => None
  | T _ tl k EE => Some k
  | T _ tl k tr => max_elt' tr
  end.Fixpoint delmin a y b : (key * tree) :=
   match a with
   | EE => (y,b)
   | T Black aa ya ba =>
              match delmin aa ya ba with
                                 (k, a') => (k,balleft a' y b)
              end
   | T Red aa ya ba =>
              match delmin aa ya ba with
               (k,a') =>  (k, T Red a' y b)
              end
 end.Definition delete'_min t : option (key * tree) :=
 match t with
 | EE => None
 | T _ a y b =>
  match delmin a y b with
   | (k, T _ a y b) => Some (k, T Black a y b)
   | (k, EE) => Some (k,EE)
   end
 end.Definition bogus : tree * list key := (EE, nil).Fixpoint treeify_f (n: positive) (l: list key) : tree * list key:=
 match n with
 | xH => match l with x::l1 => (T Red EE x EE, l1) | _ => bogus end
 | xO n' => match treeify_f n' l with
                   | (t1, x::l2) => let (t2,l3) := treeify_g n' l2 in (T Black t1 x t2, l3)
                   | _ => bogus
                  end
 | xI n' => match treeify_f n' l with
                   | (t1, x::l2) => let (t2,l3) := treeify_f n' l2 in (T Black t1 x t2, l3)
                   | _ => bogus
                  end
 end
 with treeify_g (n: positive) (l: list key) : tree * list key :=
 match n with
 | xH => (EE,l)
 | xO n' => match treeify_g n' l with
                   | (t1, x::l2) => let (t2,l3) := treeify_g n' l2 in (T Black t1 x t2, l3)
                   | _ => bogus
                  end
 | xI n' => match treeify_f n' l with
                   | (t1, x::l2) => let (t2,l3) := treeify_g n' l2 in (T Black t1 x t2, l3)
                   | _ => bogus
                  end
 end.Fixpoint poslength {A} (l: list A) :=
 match l with nil => 1%positive | _::tl => Psucc (poslength tl) end.Definition treeify (l: list key) : tree := fst (treeify_g (poslength l) l).(* Now that the program has been defined, it's time to prove its properties.
   A red-black tree has two kinds of properties:
  [searchtree]: the keys in each left subtree are all less than the node's key,
                      and the keys in each right subtree are greater
  [redblack]:  there is the same number of black nodes on any path from
               the root to each leaf; and there are never two red nodes in a row.
  First, we'll treat the [searchtree] property.
*)

Ltac inv H := inversion H; clear H; subst.Ltac do_compare x y :=  destruct (CompSpec2Type (K.compare_spec x y)).Ltac do_ins_not_EE :=
  repeat match goal with
    | |- match ?A with Red => _ | Black => _ end  <> _=> destruct A
    | |- match ?A with EE => _ | T _ _ _ _ => _ end  <> _=>destruct A
  end; intro Hx; inversion Hx.

(* Specifications: *)
Lemma ins_not_EE: forall x s, ins x s <> EE.