Module E := K.
Inductive color := Red | Black.
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.
Require Recdef Omega.
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.
Definition ltopt (x y : option key) :=
match x, y with
| Some x', Some y' => K.lt x' y'
| _, _ => True
end.
Inductive searchtree: option key -> option key -> tree -> Prop :=
| STE: forall lo hi, ltopt lo hi -> searchtree lo hi EE
| STT: forall c tl k tr lo hi,
searchtree lo (Some k)  tl ->
searchtree (Some k) hi tr ->
searchtree lo hi (T c tl k tr) .
Ltac do_searchtree :=
assumption ||
constructor ||
match goal with
|  |- searchtree _ _ (match ?C with Red => _ | Black => _ end) => destruct C
|  |- searchtree _ _ (match ?C with EE => _ | T _ _ _ _ => _ end) => destruct C
| H: searchtree _ _ EE |- _ => inv H
| H: searchtree _ _ (T _ _ _ _) |- _ => inv H
| |- ltopt _ _ => unfold ltopt in *; auto
| |- match ?A with Some _ => _ | None => _ end => destruct A
| H: K.lt ?A ?B  |- K.lt ?A ?C  =>
try solve [apply lt_trans with B; assumption]; clear H
end.

Lemma searchtree_balance:
forall c  s1 t s2 lo hi,
ltopt lo (Some t) -> ltopt (Some t) hi ->
searchtree lo (Some t)  s1-> searchtree (Some t) hi s2 ->
searchtree lo hi (balance c s1 t s2).