Hint Constructors interp.
Tactic Notation "do_hyp" hyp(H) :=
match type of H with ?a -> _ =>
let H1 := fresh in (assert (H1: a); [ |generalize (H H1); clear H H1; intro H]) end.
Ltac jax :=
repeat
match goal with
| H: interp EE _ |- _ => inv H
| |- interp match ?c with Red => _ | Black => _ end _ => destruct c
| |- interp match ?t with EE => _ | T _ _ _ _ => _ end _ =>
match t with balance' _ _ _ => fail 1 | append _ => fail 1 | _ =>  destruct t end
| H: interp (balance' _ _ _) _ |- _ =>
apply interp_balance' in H; destruct H as [?|[?|?]]
| |- interp (balance' _ _ _) _ =>
apply interp_balance'
| H: interp match ?c with Red => _ | Black => _ end _ |- _ => destruct c
| H: interp match ?t with EE => _ | T _ _ _ _ => _ end _ |- _  =>
match t with balance' _ _ _ => fail 1 | append _ => fail 1 | _ =>  destruct t end
| H: interp (T _ _ _ _) _ |- _ => inv H
| H: interp _ _ <-> interp _ _ \/ interp _ _ |- _ =>
solve [destruct H  as [H _]; destruct H; auto]
| |- _ => solve [auto 50]
| H: interp _ _ -> _ \/ _ |- _ \/ _ => solve [destruct H; auto]
| H: interp ?JJ  _, IHsz: forall _ _, _ -> _ |- _ =>
match JJ with context [append(?a,?b)] =>
let H99 := fresh in
destruct (IHsz a b) as [H99 _];  [simpl in *; omega | ];
destruct (append(a,b));
try  (destruct (H99 H); [ solve [auto] | | ])
end
|  IHsz: forall _ _, _ -> _ |- interp ?JJ _ =>
match JJ with context [append(?a,?b)] =>
let H99 := fresh in
destruct (IHsz a b) as [HA HB];  [simpl in *; omega | ];
destruct (append(a,b));
try (do_hyp HA; [solve [auto] | ]);
try (do_hyp HB; [solve [auto] | ])
end
end.

Lemma singleton_valid: forall k, valid (T Black EE k EE).
Fixpoint gopher (s: tree) : tree :=
match s with
| EE => EE
| T _ sl k sr => match gopher sl with
| T _ sll j slr => T Red sll j (T Red slr k sr)
| EE => s
end
end.