Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import SquiggleEq.export.
Require Import SquiggleEq.UsefulTypes.
Require Import SquiggleEq.list.
Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.AssociationList.

Section VarSort.

Variable V:Set.

Set Implicit Arguments.

Section MaxUniv.

(* max universe. 0 denotes [Set] *)
Variable n : nat.

Set Implicit Arguments.

Inductive Opid : Set :=
(* x, which is var, we get for free *)
 | pSort : forall m, (PeanoNat.Nat.leb m n = true) -> Opid
 | pLam
 | pPi
 | pSig
 | pApp
 | pProjSig : bool (* true := fst, false := snd *) -> Opid
 | pPair : bool (* true := fst, false := snd *) -> Opid
(* pNat *)
(* p0 *)
(* pS *)
(* pPrimRec *).

Definition OpBindings (c : Opid)
    : list nat :=
  match c with
  | pSort _ _ => [0]
  | pLam => [0,1] (* contains type as well  *)
  | pPi => [0,1]
  | pSig => [0,1]
  | pProjSig _ => [0]
  | pPair _ => [0;0]
  | pApp => [0;0]
  end.

End MaxUniv.
Let Term : nat -> Set := (fun n => (@NTerm V (Opid n))).

(* We can define the semantics of Term 1, by going as TermplateCoq.Term.
Then, one would have to manually reflect it using the "Make Definition" command.
Else, we can also just pretty print as a string, and dump the contents to a .v file. *)

(*
There is no way to give semantics where t:Term i is mapped to {T:Type | T}.
Think about (oterm (pLam) (bterm [x] (vterm x))). We want it to map it to
fun x => x. Suppose V:=string. There is no way to convert the string "x" to the binder x in fun x => x.
There is not even a way to get a fresh binders. the "fresh" function is only available in Ltac.
If there were such a function in Coq, we could cook up well-typed open terms, which is impossible.

Perhaps thats why the "Make Definition" command of template-Coq is external
*)

(*
Because there is no internal semantics function, we cannot use it to reduce the typehood of codes
to the typehood of the semantics. It may be best to formalize the typehood.
*)

(* v' in the translation on paper *)
Variable vprime : V -> V.
(* v_R in the translation on paper *)
Variable vrel : V -> V.
(* later, axiomatize that the output of vprime and the outputs of vrel and the inputs to these functions
are in (3) disctinct classes *)

Definition mkLam {n:nat} (x: V) (A b: Term n) : Term n :=
  oterm (pLam _) [bterm [] A; bterm [x] b].

Definition mkPi {n:nat} (x: V) (A b: Term n) : Term n :=
  oterm (pLam _) [bterm [] A; bterm [x] b].

Definition mkSig {n:nat} (x: V) (A b: Term n) : Term n :=
  oterm (pSig _) [bterm [] A; bterm [x] b].

Definition mkApp {n:nat}  (A B: Term n) : Term n :=
  oterm (pApp _) [bterm [] A; bterm [] B].

(* use fold_left. *)
Fixpoint mkAppL {n:nat}  (f : Term n) (args : list (Term n)) : Term n :=
match args with
| nil => f
| a::tl => mkAppL (mkApp f a) tl
end.

Inductive VClass := vOrig | vPrim | vRel.

Context `{VarType V VClass}.

(* Move to Squiggle *)

Definition mkFun {n:nat} (A B: Term n) : Term n :=
  mkPi (freshVar vOrig (free_vars B)) A B.

Definition mkProd {n:nat} (A B: Term n) : Term n :=
  mkSig (freshVar vOrig (free_vars B)) A B.

Fixpoint mkLamL {n:nat} (lb: list (V*Term n)) (b: Term n)
  : Term n :=
match lb with
| nil => b
| a::tl =>  mkLam (fst a) (snd a )(mkLamL tl b)
end.

Fixpoint mkPiL {n:nat} (lb: list (V*Term n)) (b: Term n)
  : Term n :=
match lb with
| nil => b
| a::tl =>  mkPi (fst a) (snd a )(mkPiL tl b)
end.

Notation "x → y" := (mkFun x y)
  (at level 99, y at level 200, right associativity).

Let dvar := (freshVar vOrig []).

Definition mkTR {n:nat} (A B s: Term n): Term n :=
  let lv := (freshVars 3 (Some vOrig) (free_vars B ++ free_vars A) []) in
  let R := nth 0 lv dvar in
  let a := nth 1 lv dvar in
  let b := nth 2 lv dvar in
 mkSig R (A → B → s)
    (mkProd
      (mkPi a A (mkSig b B (mkAppL (vterm R) [vterm a; vterm b])))
      (mkPi b B (mkSig a A (mkAppL (vterm R) [vterm a; vterm b])))
      ).

Definition pfst {n:nat} (T: Term n): Term n :=
oterm (pProjSig _ true) [bterm [] T].

Fixpoint translate {n:nat} (t:Term n) : Term n :=
match t with
| vterm v => vterm (vrel v)
| oterm (pSort _ _ n) [] =>
  let x:= dvar in
  mkLamL [(x,t);(vprime x, t)] (mkTR (vterm x) (vterm (vprime x)) t)
| oterm (pPi _) [bterm [] A; bterm [x] B] =>
  let f:= (freshVar vOrig (free_vars A ++ free_vars B)) in
  let A':= tvmap vprime A in
  let B':= tvmap vprime B in
  let t' := oterm (pPi _) [bterm [] A'; bterm [x] B'] in
  let tA := translate A in
  let tB := translate B in
(* fix : make a sigma type, with proof of totality of the relation below *)
 mkLamL
  [(f,t);(vprime f,t')]
  (mkPiL
   [(x,A);(vprime x, A');(vrel x, mkAppL (pfst tA) [vterm x; vterm (vprime x)])]
    (mkAppL (pfst tB) [mkApp (vterm f) (vterm x);
                    mkApp (vterm (vprime f)) (vterm (vprime x))]))
| _ => oterm (pApp _) nil
end.

(*
because any type can be provided for instantiating an existential, as in RProp rforall,all type constructors must preserve
  the property required by such instantiations.
E.g., because we have (nat->nat) : Type,
we have [[nat->nat]]: [[Type]] (nat -> nat) (nat -> nat),
which computes to saying that [[nat->nat]] is a total relation.
*)

Print VarType.
End VarSort.

(*delete. import common.*)
Definition TotalHeteroRel {T1 T2 : Type} (R: T1 -> T2 -> Type) : Type :=
(forall (t1:T1), @sigT T2 (R t1))*
(forall (t2:T2), @sigT _ (fun t1:T1 => R t1 t2)).
(*delete. import common.*)

Definition R_Pi {A1 A2 :Type} {A_R: A1 -> A2 -> Type}
  {B1: A1 -> Type}
  {B2: A2 -> Type}
  (B_R: forall {a1 a2}, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (f1: forall a, B1 a) (f2: forall a, B2 a) : Type
  :=
  forall a1 a2 (p: A_R a1 a2), B_R p (f1 a1) (f2 a2).

Lemma totalPi (A1 A2 :Type) (A_R: A1 -> A2 -> Type)
  (trp : TotalHeteroRel A_R)
  (B1: A1 -> Type)
  (B2: A2 -> Type)
  (B_R: forall a1 a2, A_R a1 a2 -> (B1 a1) -> (B2 a2) -> Type)
  (trb: forall a1 a2 (p:A_R a1 a2), TotalHeteroRel (B_R _ _ p))
:
  TotalHeteroRel (R_Pi B_R).
Proof.
  split.
- intros f1. apply snd in trp.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. specialize (trp a2). destruct trp as [a11 ar].
    specialize (trb _ _ ar).
    apply fst in trb.
    specialize (trb (f1 a11)). exact (projT1 trb).
  simpl.
  intros ? ? ?.
  destruct (trp a2) as [a1r ar].
  destruct (trb a1r a2 ar) as [b2 br].
  simpl.
  destruct (b2 (f1 a1r)). simpl.
  specialize (br x). destruct br.
  specialize (b2 x0). destruct b2.
Abort.

Lemma totalImpl (A1 A2 B1 B2 :Type)
  (A_R: A1 -> A2 -> Type)
  (B_R: B1 -> B2 -> Type)
  (arp : TotalHeteroRel A_R)
  (brp : TotalHeteroRel B_R) :
  let RImpl := fun f1 f2 =>
(forall a1 a1r a2,
      A_R a1 a2
      -> A_R a1r a2
      -> B_R (f1 a1r) (f2 a2)
      -> B_R (f1 a1) (f2 a2))
  ->
    (forall a1 a2, A_R a1 a2 -> B_R (f1 a1) (f2 a2))
     in
  TotalHeteroRel RImpl.
Proof.
  split.
- intros f1.
  eexists.
  Unshelve.
    Focus 2.
    intros a2. apply snd in arp.
    specialize (arp a2). destruct arp as [a11 ar].
    apply fst in brp.
    specialize (brp (f1 a11)). exact (projT1 brp).
  simpl.
  intros ? ? ? ?.
  specialize (fun ar => X _ ar _ X0).
(* we can certainly cook up bad functions *)
  destruct (snd arp a2) as [a1r ar]. simpl in *.
  specialize (X _ ar).
  destruct (fst brp (f1 a1r)) as [b2 br]. simpl in *.
 eauto; fail.
Abort.

Definition ftransport {A1 A2 B1 B2 :Type}
  (A_R: A1 -> A2 -> Type)
  (B_R: B1 -> B2 -> Type)
  (arp : TotalHeteroRel A_R)
  (brp : TotalHeteroRel B_R)
  (f1: A1 -> B1) : A2 -> B2.
    intros a2. apply snd in arp.
    specialize (arp a2). destruct arp as [a11 ar].
    apply fst in brp.
    specialize (brp (f1 a11)). exact (projT1 brp).
Defined.

Lemma totalImpl (A1 A2 B1 B2 :Type)
  (A_R: A1 -> A2 -> Type)
  (B_R: B1 -> B2 -> Type)
  (arp : TotalHeteroRel A_R)
  (brp : TotalHeteroRel B_R) :
  let RImpl := fun f1 f2 =>
    (forall a1 a2, A_R a1 a2 -> B_R (f1 a1) (f2 a2))
     in
  TotalHeteroRel RImpl.
Proof.
  split.
- intros f1.
  exists (ftransport arp brp f1).
  simpl.
  intros ? ? ?. unfold ftransport.
(* we can certainly cook up bad functions *)
  destruct (snd arp a2) as [a1r ar]. simpl in *.
  destruct (fst brp (f1 a1r)) as [b2 br]. simpl in *.
  (* there is no way to use the A_Rs to bet B_Rs about f1.
  because there is only 1 B_R hypothesis, zig-zagness wont help.
    We cannot assume that f1 behaves
    parametrically.*)
Abort.

Definition totalRelPiClosed := forall (A1 A2 B1 B2 :Type)
  (A_R: A1 -> A2 -> Type)
  (B_R: B1 -> B2 -> Type)
  (arp : TotalHeteroRel A_R)
  (brp : TotalHeteroRel B_R),
  let RImpl := fun f1 f2 =>
    (forall a1 a2, A_R a1 a2 -> B_R (f1 a1) (f2 a2))
     in
  TotalHeteroRel RImpl.

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

Lemma counterEx : totalRelPiClosed -> False.
Proof.
  intros Hc. set (R:= fun x y => even x = even y).
  evar (T: TotalHeteroRel R).
  Unshelve.
    Focus 2.
     (split; intros x; exists x; reflexivity).
  specialize (Hc nat nat nat nat R R T T).
  simpl in *.
  apply fst in Hc.
  set (bad := fun n =>
  match n with
  | O => 1
  | _ => 0
  end).
  specialize (Hc bad).
  simpl in Hc.
  destruct Hc as [f2 p].
  assert (f2 = ftransport T T bad) by admit.
    (* true by parametricity. if A1=A2, B1=B2, and have HeterRels pick indentical
       elements, the only way to construct a B from an A is to use f1 exactly once.
https://onedrive.live.com/edit.aspx/Documents/Postdoc?cid=946e75b47b19a3b5&id=documents&wd=target%28parametricity%2Ftheory.one%7CB23D752F-C19A-4F84-BCA5-B8772CAB76D4%2FTotal%20hetero%20rel%20not%20closed%20under%20function%20types%7C1EE46CCF-C669-4157-8495-84454400EB7C%2F%29
*)
  subst.
  specialize (p 0 2 eq_refl). unfold ftransport in p.
  simpl in p. unfold R in p. simpl in p. inversion p; fail.
  Fail idtac. (* done, except the above admit *)
Abort.

Lemma totalConj (A1 A2 B1 B2 :Type)
  (A_R: A1 -> A2 -> Type)
  (B_R: B1 -> B2 -> Type)
  (arp : TotalHeteroRel A_R)
  (brp : TotalHeteroRel B_R) :
  let RImpl := fun f1 f2 =>
  prod (A_R (fst f1) (fst f2)) (B_R (snd f1) (snd f2))
     in
  TotalHeteroRel RImpl.
Proof.
  intros. unfold RImpl. clear RImpl.
  split.
- intros. apply fst in arp. apply fst in brp.
  destruct t1 as [a1 b1].
  specialize (arp a1).
  specialize (brp b1).
  destruct arp as [a2 pa].
  destruct brp as [b2 pb].
  exists (a2,b2). simpl. tauto.
- (*similar*)
Abort.

(* perhaps contra variant type constructors are the only problem *)


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

- Stephane Le Roux, 2007-02-20

excluded middle and decidability for relations.
*)

Require Import Relations LogicUtil.

Set Implicit Arguments.

Section S.

  Variables (A : Type) (R : relation A).

  Definition rel_midex := forall x y : A, R x y \/ ~R x y.

  Definition rel_dec := forall x y, {R x y} + {~R x y}.

  Lemma rel_dec_midex : rel_dec -> rel_midex.

  Proof. do 3 intro. destruct (X x y); tauto. Qed.

  Definition fun_rel_dec (f : A->A->bool) :=
    forall x y, if f x y then R x y else ~R x y.

  Lemma bool_rel_dec : {f : A->A->bool | fun_rel_dec f} -> rel_dec.

  Proof. intros (f,H) x y. gen (H x y). case (f x y); intros; tauto. Qed.

  Lemma rel_dec_bool : rel_dec -> {f : A->A->bool | fun_rel_dec f}.

  Proof.
    intro H. exists (fun x y : A => if H x y then true else false).
    intros x y. destruct (H x y); trivial.
  Qed.

  Lemma fun_rel_dec_true : forall f x y, fun_rel_dec f -> f x y = true -> R x y.

  Proof. intros. set (w := H x y). rewrite H0 in w. hyp. Qed.

  Lemma fun_rel_dec_false : forall f x y,
    fun_rel_dec f -> f x y = false -> ~R x y.

  Proof. intros. set (w := H x y). rewrite H0 in w. hyp. Qed.

(***********************************************************************)
(** Leibniz equality relation *)

  Definition eq_midex := forall x y : A, x=y \/ x<>y.

  Definition eq_dec := forall x y : A, {x=y}+{x<>y}.

  Lemma eq_dec_midex : eq_dec -> eq_midex.

  Proof. do 3 intro. destruct (X x y); tauto. Qed.

End S.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Definition key := Z.

(* Why3 assumption *)
Definition value := Z.

(* Why3 assumption *)
Inductive color :=
  | Red : color
  | Black : color.
Axiom color_WhyType : WhyType color.
Existing Instance color_WhyType.

(* Why3 assumption *)
Inductive tree :=
  | Leaf : tree
  | Node : color -> tree -> Z -> Z -> tree -> tree.
Axiom tree_WhyType : WhyType tree.
Existing Instance tree_WhyType.

(* Why3 assumption *)
Fixpoint memt (t:tree) (k:Z) (v:Z) {struct t}: Prop :=
  match t with
  | Leaf => False
  | (Node _ l k' v' r) => ((k = k') /\ (v = v')) \/ ((memt l k v) \/ (memt r
      k v))
  end.

Axiom memt_color : forall (l:tree) (r:tree) (k:Z) (k':Z) (v:Z) (v':Z)
  (c:color) (c':color), (memt (Node c l k v r) k' v') -> (memt (Node c' l k v
  r) k' v').

(* Why3 assumption *)
Definition lt_tree (x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt
  t k v) -> (k < x)%Z.

(* Why3 assumption *)
Definition gt_tree (x:Z) (t:tree): Prop := forall (k:Z), forall (v:Z), (memt
  t k v) -> (x < k)%Z.

Axiom lt_leaf : forall (x:Z), (lt_tree x Leaf).

Axiom gt_leaf : forall (x:Z), (gt_tree x Leaf).

Axiom lt_tree_node : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x l) -> ((lt_tree x r) -> ((y < x)%Z -> (lt_tree x (Node c l y v
  r)))).

Axiom gt_tree_node : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x l) -> ((gt_tree x r) -> ((x < y)%Z -> (gt_tree x (Node c l y v
  r)))).

Axiom lt_node_lt : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (y < x)%Z.

Axiom gt_node_gt : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (x < y)%Z.

Axiom lt_left : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (lt_tree x l).

Axiom lt_right : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (lt_tree x (Node c l y v r)) -> (lt_tree x r).

Axiom gt_left : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (gt_tree x l).

Axiom gt_right : forall (x:Z) (y:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (gt_tree x (Node c l y v r)) -> (gt_tree x r).

Axiom lt_tree_not_in : forall (x:Z) (t:tree), (lt_tree x t) -> forall (v:Z),
  ~ (memt t x v).

Axiom lt_tree_trans : forall (x:Z) (y:Z), (x < y)%Z -> forall (t:tree),
  (lt_tree x t) -> (lt_tree y t).

Axiom gt_tree_not_in : forall (x:Z) (t:tree), (gt_tree x t) -> forall (v:Z),
  ~ (memt t x v).

Axiom gt_tree_trans : forall (x:Z) (y:Z), (y < x)%Z -> forall (t:tree),
  (gt_tree x t) -> (gt_tree y t).

(* Why3 assumption *)
Fixpoint bst (t:tree) {struct t}: Prop :=
  match t with
  | Leaf => True
  | (Node _ l k _ r) => (bst l) /\ ((bst r) /\ ((lt_tree k l) /\ (gt_tree k
      r)))
  end.

Axiom bst_Leaf : (bst Leaf).

Axiom bst_left : forall (k:Z) (v:Z) (l:tree) (r:tree) (c:color), (bst (Node c
  l k v r)) -> (bst l).

Axiom bst_right : forall (k:Z) (v:Z) (l:tree) (r:tree) (c:color), (bst
  (Node c l k v r)) -> (bst r).

Axiom bst_color : forall (c:color) (c':color) (k:Z) (v:Z) (l:tree) (r:tree),
  (bst (Node c l k v r)) -> (bst (Node c' l k v r)).

Axiom rotate_left : forall (kx:Z) (ky:Z) (vx:Z) (vy:Z) (a:tree) (b:tree)
  (c:tree) (c1:color) (c2:color) (c3:color) (c4:color), (bst (Node c1 a kx vx
  (Node c2 b ky vy c))) -> (bst (Node c3 (Node c4 a kx vx b) ky vy c)).

Axiom rotate_right : forall (kx:Z) (ky:Z) (vx:Z) (vy:Z) (a:tree) (b:tree)
  (c:tree) (c1:color) (c2:color) (c3:color) (c4:color), (bst (Node c3
  (Node c4 a kx vx b) ky vy c)) -> (bst (Node c1 a kx vx (Node c2 b ky vy
  c))).

(* Why3 assumption *)
Definition is_not_red (t:tree): Prop :=
  match t with
  | (Node Red _ _ _ _) => False
  | (Leaf|(Node Black _ _ _ _)) => True
  end.

(* Why3 assumption *)
Fixpoint rbtree (n:Z) (t:tree) {struct t}: Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ ((rbtree n r) /\ ((is_not_red l) /\
      (is_not_red r)))
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.

Axiom rbtree_Leaf : (rbtree 0%Z Leaf).

Axiom rbtree_Node1 : forall (k:Z) (v:Z), (rbtree 0%Z (Node Red Leaf k v
  Leaf)).

Axiom rbtree_left : forall (x:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (exists n:Z, (rbtree n (Node c l x v r))) -> exists n:Z, (rbtree n l).

Axiom rbtree_right : forall (x:Z) (v:Z) (l:tree) (r:tree) (c:color),
  (exists n:Z, (rbtree n (Node c l x v r))) -> exists n:Z, (rbtree n r).

(* Why3 assumption *)
Definition almost_rbtree (n:Z) (t:tree): Prop :=
  match t with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ (rbtree n r)
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end.

Axiom rbtree_almost_rbtree : forall (n:Z) (t:tree), (rbtree n t) ->
  (almost_rbtree n t).

Axiom rbtree_almost_rbtree_ex : forall (s:tree), (exists n:Z, (rbtree n
  s)) -> exists n:Z, (almost_rbtree n s).

Axiom almost_rbtree_rbtree_black : forall (x:Z) (v:Z) (l:tree) (r:tree)
  (n:Z), (almost_rbtree n (Node Black l x v r)) -> (rbtree n (Node Black l x
  v r)).

(* Why3 goal *)
Theorem WP_parameter_add : forall (t:tree) (k:Z) (v:Z), ((bst t) /\
  exists n:Z, (rbtree n t)) -> (((bst t) /\ exists n:Z, (rbtree n t)) ->
  forall (result:tree), ((bst result) /\ ((forall (n:Z), (rbtree n t) ->
  (match result with
  | Leaf => (n = 0%Z)
  | (Node Red l _ _ r) => (rbtree n l) /\ (rbtree n r)
  | (Node Black l _ _ r) => (rbtree (n - 1%Z)%Z l) /\ (rbtree (n - 1%Z)%Z r)
  end /\
  (match t with
  | (Node Red _ _ _ _) => False
  | (Leaf|(Node Black _ _ _ _)) => True
  end -> (rbtree n result)))) /\ ((memt result k v) /\ forall (k':Z) (v':Z),
  ((memt result k' v') \/ (((k' = k) -> (v' = v)) /\ ((~ (k' = k)) -> (memt t
  k' v')))) -> ((memt result k' v') /\ (((k' = k) /\ (v' = v)) \/
  ((~ (k' = k)) /\ (memt t k' v'))))))) -> forall (x:color) (x1:tree) (x2:Z)
  (x3:Z) (x4:tree), (result = (Node x x1 x2 x3 x4)) -> exists n:Z, (rbtree n
  (Node Black x1 x2 x3 x4))).
intros t k v (h1,(n,h2)) _ result (h5,(h6,(h7,h8))) c x1 x2
        x3 x4 h9.
subst.
intuition.
generalize (h6 n h2); clear h6.
intros.
destruct c; intuition.
(* c = Red *)
exists (n+1)%Z; intuition.
simpl rbtree. replace (n+1-1)%Z with n by omega.
intuition.
(* c = Black *)
exists n; intuition.
simpl rbtree.
intuition.
Qed.


(** * Redblack: Red-Black Trees *)

(** Red-black trees are a kind of _balanced_ binary search tree (BST).
    Keeping the tree balanced ensures that the worst-case running
    time of operations is logarithmic rather than linear. *)

(** This chapter uses Okasaki's algorithms for red-black trees.
    If you don't recall those or haven't seem them in a while, read one
    of the following:

    - Red-Black Trees in a Functional Setting, by Chris Okasaki.
      _Journal of Functional Programming_, 9(4):471-477, July 1999.
      Available from {https://doi.org/10.1017/S0956796899003494}.
      Archived at
      {https://web.archive.org/web/20070926220746/http://www.eecs.usma.edu/webs/people/okasaki/jfp99.ps}.

    - _Purely Functional Data Structures_, by Chris Okasaki. Section
      3.3.  Cambridge University Press, 1998.

    You can also consult Wikipedia or other standard textbooks, though
    they are likely to use different, imperative implementations. *)

(** This chapter is based on the Coq standard library module
    [MSetRBT], which can be found at
    [https://coq.inria.fr/distrib/current/stdlib/Coq.MSets.MSetRBT.html].
    The design decisions for that module are described in the
    following paper:

    - Efficient Verified Red-Black Trees, by Andrew W. Appel,
      September 2011.  Available from
      {http://www.cs.princeton.edu/~appel/papers/redblack.pdf}.  *)

From Coq Require Import String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import ZArith.
From VFA Require Import Perm.
From VFA Require Import Extract.
Open Scope Z_scope.

(* ################################################################# *)
(** * Implementation *)

(** A [Section] enables declaration of some [Variable]s, which are in
    scope throughout. That saves us from having to write [V] and
    [default] as arguments to most of the definitions in the
    chapter. The variables do get inserted by Coq as arguments after
    the section is closed. *)

Section ValueType.

  Variable V : Type.
  Variable default : V.

  (** We use the [int] type axiomatized in [Extract] as the key
      type. *)
  Definition key := int.

  Inductive color := Red | Black.

  Inductive tree : Type :=
  | E : tree
  | T : color -> tree -> key -> V -> tree -> tree.

  Definition empty_tree : tree :=
    E.

  (** The [lookup] implementation for red-black trees is exactly the same
      as the [lookup] for BSTs, except that the [T] constructor
      carries a [color] component that is ignored. *)

  Fixpoint lookup (x: key) (t : tree) : V :=
    match t with
    | E => default
    | T _ tl k v tr => if ltb x k then lookup x tl
                      else if ltb k x then lookup x tr
                           else v
    end.

  (** We won't explain the [insert] algorithm here; read Okasaki's
      work if you want to understand it.  In fact, you'll need very
      little understanding of it to follow along with the verification
      below. It uses [balance] and [ins] as helpers:

      - [ins] recurses down the tree to find where to insert, and is
        mostly the same as the BST [insert] algorithm.

      - [balance] takes care of rebalancing the tree on the way back
        up. *)

  Definition balance (rb : color) (t1 : tree) (k : key) (vk : V) (t2 : tree) : tree :=
    match rb with
    | Red => T Red t1 k vk t2
    | _ => match t1 with
          | T Red (T Red a x vx b) y vy c =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
          | T Red a x vx (T Red b y vy c) =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
          | a => match t2 with
                | T Red (T Red b y vy c) z vz d =>
	          T Red (T Black t1 k vk b) y vy (T Black c z vz d)
                | T Red b y vy (T Red c z vz d)  =>
	          T Red (T Black t1 k vk b) y vy (T Black c z vz d)
                | _ => T Black t1 k vk t2
                end
          end
    end.

  Fixpoint ins (x : key) (vx : V) (t : tree) : tree :=
    match t with
    | E => T Red E x vx E
    | T c a y vy b => if ltb x y then balance c (ins x vx a) y vy b
                      else if ltb y x then balance c a y vy (ins x vx b)
                           else T c a x vx b
    end.

  Definition make_black (t : tree) : tree :=
    match t with
    | E => E
    | T _ a x vx b => T Black a x vx b
    end.

  Definition insert (x : key) (vx : V) (t : tree) :=
    make_black (ins x vx t).

  (** The [elements] implementation is the same as for BSTs, except that it
      ignores colors. *)

  Fixpoint elements_tr (t : tree) (acc: list (key * V)) : list (key * V) :=
    match t with
    | E => acc
    | T _ l k v r => elements_tr l ((k, v) :: elements_tr r acc)
    end.

  Definition elements (t : tree) : list (key * V) :=
    elements_tr t [].

  (* ###################################################################### *)
  (** * Case-Analysis Automation *)

  (** Before verifying the correctness of our red-black tree
      implementation, let's warm up by proving that the result of any
      [insert] is a nonempty tree. *)

  Lemma ins_not_E : forall (x : key) (vx : V) (t : tree),
      ins x vx t <> E.
  Proof.
    intros. destruct t; simpl.
    discriminate.

    (* Let's [destruct] on the topmost case, [ltb x k]. We can use
       [destruct] instead of [bdestruct] because we don't need to know
       whether [x < k] or [x >= k]. *)

    destruct (ltb x k).
    unfold balance.

    (* A huge goal!  The proof of this goal begins by matching
       against a color. *)

    destruct c.
    discriminate.

    (* Another [match], this time against a tree. *)

    destruct (ins x vx t1).

    (* Another [match] against a tree. *)

    destruct t2.
    discriminate.

    (* Yet another [match]. This pattern deserves automation.  The
       following tactic applies [destruct] whenever the current goal
       is a [match] against a color or a tree. *)

    match goal with
    | |- match ?c with Red => _ | Black => _  end <> _ => destruct c
    | |- match ?t with E => _ | T _ _ _ _ _ => _ end  <> _=> destruct t
    end.

    (* Let's apply that tactic repeatedly. *)

    repeat
      match goal with
      | |- match ?c with Red => _ | Black => _  end <> _ => destruct c
      | |- match ?t with E => _ | T _ _ _ _ _ => _ end  <> _=> destruct t
      end.

    (* Now we're down to a base case. *)

    discriminate.

    (* And another base case. We could match against those, too. *)

    match goal with
    | |- T _ _ _ _ _ <> E => discriminate
    end.

    (* Let's restart the proof to incorporate this automation. *)

  Abort.

  Lemma ins_not_E : forall (x : key) (vx : V) (t : tree),
      ins x vx t <> E.
  Proof.
    intros. destruct t; simpl.
    - discriminate.
    - unfold balance.
      repeat
        match goal with
        | |- (if ?x then _ else _) <> _ => destruct x
        | |- match ?c with Red => _ | Black => _  end <> _=> destruct c
        | |- match ?t with E => _ | T _ _ _ _ _ => _ end  <> _=> destruct t
        | |- T _ _ _ _ _ <> E => discriminate
        end.
  Qed.

  (** This automation of case analysis will be quite useful in the rest
      of our development. *)

  (* ###################################################################### *)
  (** * The BST Invariant *)

  (** The BST invariant is mostly the same for red-black trees as it
      was for ordinary BSTs as defined in [SearchTree].  We adapt
      it by ignoring the color of each node, and changing from [nat]
      keys to [int]. *)

  (** [ForallT P t] holds if [P k v] holds for every [(k, v)] node of
      tree [t]. *)

  Fixpoint ForallT (P: int -> V -> Prop) (t: tree) : Prop :=
    match t with
    | E => True
    | T c l k v r => P k v /\ ForallT P l /\ ForallT P r
    end.

  Inductive BST : tree -> Prop :=
  | ST_E : BST E
  | ST_T : forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (T c l k v r).

  Lemma empty_tree_BST:  BST empty_tree.
  Proof.
    unfold empty_tree. constructor.
  Qed.

  (** Let's show that [insert] preserves the BST invariant, that is: *)

  Theorem insert_BST : forall t v k,
      BST t ->
      BST (insert k v t).
  Abort.

  (** It will take quite a bit of work, but automation will help. *)

  (** First, we show that if a non-empty tree would be a BST, then the
      balanced version of it is also a BST: *)

  Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros c l k v r PL PR BL BR. unfold balance.

    repeat
      match goal with
      | |- BST (match ?c with Red => _ | Black => _ end)  => destruct c
      | |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end)  => destruct t
      end.

    (* 58 cases remaining. *)

    - constructor. assumption. assumption. assumption. assumption.
    - constructor; auto.
    - constructor; auto.
    - (* Now the tree gets bigger, and the proof gets more complicated. *)
      constructor; auto.

      + simpl in *. repeat split.
        (* The intro pattern [?] means to let Coq choose the name. *)
        destruct PR as [? _]. lia.

      + simpl in *. repeat split.
        * inv BR. simpl in *. destruct H5 as [? _]. lia.
        * inv BR. simpl in *. destruct H5 as [_ [? _]]. auto.
        * inv BR. simpl in *. destruct H5 as [_ [_ ?]]. auto.

      + constructor; auto.

      + inv BR. inv H7. constructor; auto.

    - constructor; auto.

    - (* 53 cases remain. This could go on for a while... *)

  Abort.

  (** Let's use some of what we discovered above to automate.
      Whenever we have a subgoal of the form

        ForallT _ (T _ _ _ _ _)

      we can split it.  Whenever we have a hypothesis of the form

        BST (T _ _ _ _ _)

      we can invert it.  And with a hypothesis

        ForallT _ (T _ _ _ _ _)

      we can simplify then destruct it.  Actually, the simplification
      is optional -- Coq will do the destruct without needing the
      simplification.  Anything else seems able to be finished with
      [constructor], [auto], and [lia].  Let's see how far that can
      take us...
   *)

  Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros. unfold balance.

    repeat
      (match goal with
       |  |- BST (match ?c with Red => _ | Black => _ end)  => destruct c
       |  |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end)  => destruct t
       |  |- ForallT _ (T _ _ _ _ _) => repeat split
       |  H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       |  H: BST (T _ _ _ _ _) |- _ => inv H
       end;
       (try constructor; auto; try lia)).

  (** 41 cases remain.  It's a little disappointing that we didn't clear
      more of them.  Let's look at why are we stuck.

      All the remaining subgoals appear to be about proving an inequality
      over all the nodes of a subtree.  For example, the first subgoal
      follows from the hypotheses

        ForallT (fun (k' : int) (_ : V) => Abs k' > Abs k0) r2
        Abs k1 < Abs k0

      The other goals look similar. *)

  Abort.

  (** To make progress, we can set up some helper lemmas. *)

  Lemma ForallT_imp : forall (P Q : int -> V -> Prop) t,
      ForallT P t ->
      (forall k v, P k v -> Q k v) ->
      ForallT Q t.
  Proof.
    induction t; intros.
    - auto.
    - destruct H as [? [? ?]]. repeat split; auto.
  Qed.

  Lemma ForallT_greater : forall t k k0,
      ForallT (fun k' _ => Abs k' > Abs k) t  ->
      Abs k > Abs k0 ->
      ForallT (fun k' _ => Abs k' > Abs k0) t.
  Proof.
    intros. eapply ForallT_imp; eauto.
    intros. simpl in H1. lia.
  Qed.

  Lemma ForallT_less : forall t k k0,
      ForallT (fun k' _ => Abs k' < Abs k) t  ->
      Abs k < Abs k0 ->
      ForallT (fun k' _ => Abs k' < Abs k0) t.
  Proof.
    intros; eapply ForallT_imp; eauto.
    intros. simpl in H1. lia.
  Qed.

  (** Now we can return to automating the proof. *)

  Lemma balance_BST: forall (c : color) (l : tree) (k : key) (v : V) (r : tree),
      ForallT (fun k' _ => (Abs k') < (Abs k)) l ->
      ForallT (fun k' _ => (Abs k') > (Abs k)) r ->
      BST l ->
      BST r ->
      BST (balance c l k v r).
  Proof.
    intros. unfold balance.

    repeat
      (match goal with
       |  |- BST  (match ?c with Red => _ | Black => _ end)  => destruct c
       |  |- BST  (match ?s with E => _ | T _ _ _ _ _ => _ end)  => destruct s
       |  |- ForallT _ (T _ _ _ _ _) => repeat split
       |  H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
       |  H: BST (T _ _ _ _ _) |- _ => inv H
       end;
       (try constructor; auto; try lia)).

    (* [all: t] applies [t] to every subgoal. *)
    all: try eapply ForallT_greater; try eapply ForallT_less; eauto; try lia.
  Qed.

    (** **** Exercise: 2 stars, standard (balanceP) *)

  (** Prove that [balance] preserves [ForallT P]. Use proof automation
      with [match goal] and/or [all:].*)

  Lemma balanceP : forall (P : key -> V -> Prop) (c : color) (l r : tree) (k : key) (v : V),
      ForallT P l ->
      ForallT P r ->
      P k v ->
      ForallT P (balance c l k v r).
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 2 stars, standard (insP) *)

  (** Prove that [ins] preserves [ForallT P]. Hint: proceed by induction on [t].
      Use the previous lemma. There's no need for automated case analysis. *)

  Lemma insP : forall (P : key -> V -> Prop) (t : tree) (k : key) (v : V),
      ForallT P t ->
      P k v ->
      ForallT P (ins k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 3 stars, standard (ins_BST) *)

  (** Prove that [ins] maintains [BST].  Proceed by induction on the evidence
      that [t] is a BST.  You don't need any automated case analysis. *)

  Lemma ins_BST : forall (t : tree) (k : key) (v : V),
      BST t ->
      BST (ins k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 2 stars, standard (insert_BST) *)

  (** Prove the main theorem: [insert] preserves [BST]. *)

  Theorem insert_BST : forall t v k,
      BST t ->
      BST (insert k v t).
  Proof.
    (* FILL IN HERE *) Admitted.
  (** [] *)

  (* ###################################################################### *)
  (** * Verification *)

  (** We now verify that the equational specification of maps holds for
      red-black trees:

        lookup k empty_tree = default
        lookup k (insert k v t) = v
        lookup k' (insert k v t) = lookup k' t       if k <> k'

      The first equation is trivial to verify. *)

  Lemma lookup_empty : forall k, lookup k empty_tree = default.
  Proof. auto. Qed.

  (** The next two equations are more challenging because of [balance]. *)

    (** **** Exercise: 4 stars, standard (balance_lookup) *)

  (** Prove that [balance] preserves the result of [lookup] on
      non-empty trees. Hint: automate the case analysis similarly to
      [balance_BST]. *)

  Lemma balance_lookup: forall (c : color) (k k' : key) (v : V) (l r : tree),
      BST l ->
      BST r ->
      ForallT (fun k' _ => Abs k' < Abs k) l ->
      ForallT (fun k' _ => Abs k' > Abs k) r ->
      lookup k' (balance c l k v r) =
      if Abs k' <? Abs k
      then lookup k' l
      else if Abs k' >? Abs k
           then lookup k' r
           else v.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 3 stars, standard (lookup_ins_eq) *)

  (** Verify the second equation, though for [ins] rather than
      [insert].  Proceed by induction on the evidence that [t] is a
      [BST].  Note that precondition [BST t] will be essential in your
      proof, unlike the ordinary BST's we saw in [SearchTree].

      Hint: no automation of case analysis is needed; rely on the
      lemmas we've already proved above about [balance] and [ins]. *)

  Lemma lookup_ins_eq: forall (t : tree) (k : key) (v : V),
      BST t ->
      lookup k (ins k v t) = v.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 3 stars, standard (lookup_ins_neq) *)

  (** Verify the third equation, again for [ins] instead of [insert].
      The same hints as for the second equation hold.  *)

  Theorem lookup_ins_neq: forall (t : tree) (k k' : key) (v : V),
      BST t ->
      k <> k' ->
      lookup k' (ins k v t) = lookup k' t.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** Finally, finish verify the second and third equations.  The
      proofs are almost identical.  *)

  (** **** Exercise: 3 stars, standard (lookup_insert) *)

  Theorem lookup_insert_eq : forall (t : tree) (k : key) (v : V),
      BST t ->
      lookup k (insert k v t) = v.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem lookup_insert_neq: forall (t : tree) (k k' : key) (v : V),
      BST t ->
      k <> k' ->
      lookup k' (insert k v t) = lookup k' t.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

    (** That concludes the verification of the map equations for red-black trees.
      We have proved these main theorems: *)

  Check empty_tree_BST : BST empty_tree.

  Check insert_BST :
    forall (t : tree) (v : V) (k : key),
      BST t -> BST (insert k v t).

  Check lookup_empty :
    forall k : key,
      lookup k empty_tree = default.

  Check lookup_insert_eq :
    forall (t : tree) (k : key) (v : V),
      BST t -> lookup k (insert k v t) = v.

  Check lookup_insert_neq :
    forall (t : tree) (k k' : key) (v : V),
      BST t ->
      k <> k' ->
      lookup k' (insert k v t) = lookup k' t.

  (** We could now proceed to reprove all the facts about [elements]
      that we developed in [SearchTree].  But since [elements]
      does not not pay attention to colors, and does not rebalance the
      tree, these proofs should be a simple copy-paste from that
      chapter, with only minor edits.  This would be an uninteresting
      exercise, so we don't pursue it here. *)

  (* ###################################################################### *)
  (** * Efficiency *)

  (** Red-black trees are more efficient than ordinary search trees,
      because red-black trees stay balanced.  The [insert] operation
      ensures that these _red-black invariants_ hold: *)

  (** - Local Invariant: No red node has a red child.

      - Global Invariant: Every path from the root to a leaf has the
        same number of black nodes. *)

  (** Together these invariants guarantee that no leaf is more
      than twice as deep as another leaf, a property that we will here
      call _approximately balanced_.  The maximum depth of a node is
      therefore [2 log N], so the running-time of [insert] and
      [lookup] is [O(log N)], where [N] is the number of nodes in the
      tree.

      Coq does not have a formal time--cost model for its execution,
      so we cannot verify that logarithmic running time in Coq.  But
      we can prove that the trees are approximately balanced. *)

  (** These ensure that the tree remains approximately balanced. *)

  (** Relation [RB], below, formalizes the red-black
      invariants. Proposition [RB t c n] holds when [t] satisfies the
      red-black invariants, assuming that [c] is the color of [t]'s
      parent, and [n] is the black height that [t] is supposed to
      have.

      If [t] happens to have no parent (i.e., it is the entire tree),
      then it will be colored black by [insert], so it won't actually
      matter what color its (non-existent) parent might purportedly
      have: whether red or black, it can't violate the local
      invariant.

      If [t] is a leaf, then it likewise won't matter what its parent
      color is, and its black height must be zero. *)

  Inductive RB : tree -> color -> nat -> Prop :=
  | RB_leaf: forall (c : color), RB E c 0
  | RB_r: forall (l r : tree) (k : key) (v : V) (n : nat),
      RB l Red n ->
      RB r Red n ->
      RB (T Red l k v r) Black n
  | RB_b: forall (c : color) (l r : tree) (k : key) (v : V) (n : nat),
      RB l Black n ->
      RB r Black n ->
      RB (T Black l k v r) c (S n).

    (** **** Exercise: 2 stars, standard (RB_blacken_parent) *)

  (** Prove that blackening a parent would preserve the red-black
      invariants. *)

  Lemma RB_blacken_parent : forall (t : tree) (n : nat),
      RB t Red n -> RB t Black n.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** **** Exercise: 2 stars, standard (RB_blacken_root) *)

  (** Prove that blackening a subtree root (whose hypothetical parent
      is black) would preserve the red-black invariants, though the
      black height of the subtree might change (and the color of the
      parent would need to become red). *)

  Lemma RB_blacken_root : forall (t : tree) (n : nat),
      RB t Black n ->
      exists (n' : nat), RB (make_black t) Red n'.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

  (** Relation [NearlyRB] expresses, "the tree is a red-black tree,
      except that it's nonempty and it is permitted to have two
      consecutive red nodes at the root only."  *)

  Inductive NearlyRB : tree -> nat -> Prop :=
  | NearlyRB_r : forall (l r : tree) (k : key) (v : V) (n : nat),
      RB l Black n ->
      RB r Black n ->
      NearlyRB (T Red l k v r) n
  | NearlyRB_b : forall (l r : tree) (k : key) (v : V) (n : nat),
      RB l Black n ->
      RB r Black n ->
      NearlyRB (T Black l k v r) (S n).

  (** **** Exercise: 5 stars, standard (ins_RB) *)

  (** Prove that [ins] creates a tree that is either red-black or
      nearly so, depending on what the parent's color was.  You will
      need significant case-analysis automation in a similar style to
      the proofs of [ins_not_E] and [balance_lookup]. *)

  Lemma ins_RB : forall (k : key) (v : V) (t : tree) (n : nat),
      (RB t Black n -> NearlyRB (ins k v t) n) /\
      (RB t Red n -> RB (ins k v t) Black n).
  Proof.
    induction t; intro n; simpl; split; intros; inv H; repeat constructor; auto.
    * destruct (IHt1 n); clear IHt1.
      destruct (IHt2 n); clear IHt2.
      specialize (H0 H6).
      specialize (H2 H7).
      clear H H1.
      unfold balance.

      (* FILL IN HERE *) Admitted.

  (** [] *)

  (** Therefore, [ins] produces a red-black tree when given one as
      input -- though the parent color changes. *)
  Corollary ins_red : forall (t : tree) (k : key) (v : V) (n : nat),
      (RB t Red n -> RB (ins k v t) Black n).
  Proof.
    intros. apply ins_RB. assumption.
  Qed.

  (** **** Exercise: 2 stars, standard (insert_RB) *)

  (** Prove that [insert] produces a red-black tree when given one as
      input.  This can be done entirely with lemmas already proved. *)

  Lemma insert_RB : forall (t : tree) (k : key) (v : V) (n : nat),
      RB t Red n ->
      exists (n' : nat), RB (insert k v t) Red n'.
  Proof.
    (* FILL IN HERE *) Admitted.

  (** [] *)

    (** **** Exercise: 4 stars, advanced (redblack_bound) *)

  (** To confirm that red-black trees are approximately balanced,
      define functions to compute the height (i.e., maximum depth) and
      minimum depth of a red-black tree, and prove that the height is
      bounded by twice the minimum depth, possibly plus 1.  Hints:

      - Prove two auxiliary lemmas, one about height and the other
        about mindepth, and then combine them to get the result.  The
        lemma about height will need a slightly complicated induction
        hypothesis for the proof to go through. *)

  Fixpoint height (t : tree) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Fixpoint mindepth (t : tree) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Lemma redblack_balanced : forall t c n,
      RB t c n ->
      (height t <= 2 * mindepth t + 1)%nat.
  Proof.
    (* FILL IN HERE *) Admitted.

  (* Do not modify the following line: *)
Definition manual_grade_for_redblack_bound : option (nat*string) := None.

  (** [] *)

End ValueType.

(* ################################################################# *)
(** * Performance of Extracted Code *)

(** We can extract the red-black tree implementation: *)

Extraction "redblack.ml" empty_tree insert lookup elements.

(** Run it in the OCaml top level with these commands:

      #use "redblack.ml";;
      #use "test_searchtree.ml";;

    On a recent machine with a 2.9 GHz Intel Core i9 that prints:

      Insert and lookup 1000000 random integers in 0.860663 seconds.
      Insert and lookup 20000 random integers in 0.007908 seconds.
      Insert and lookup 20000 consecutive integers in 0.004668 seconds.

    That execution uses the bytecode interpreter.  The native compiler
    will have better performance:

      $ ocamlopt -c redblack.mli redblack.ml
      $ ocamlopt redblack.cmx -open Redblack test_searchtree.ml -o test_redblack
      $ ./test_redblack

On the same machine that prints,

      Insert and lookup 1000000 random integers in 0.475669 seconds.
      Insert and lookup 20000 random integers in 0.00312 seconds.
      Insert and lookup 20000 consecutive integers in 0.001183 seconds.
*)

(** The benchmark measurements above (and in [Extract])
    demonstrate the following:

    - On random insertions, red-black trees are about the same as
      ordinary BSTs.

    - On consecutive insertions, red-black trees are _much_ faster
      than ordinary BSTs.

    - Red-black trees are about as fast on consecutive insertions as
      on random. *)

(* 2021-08-11 15:15 *)


Require Export CatSem.CAT.CatFunct.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** horizontal composition of natural transformations *)

Section hcomp.

Variables obA obB obC: Type.
Variable morA : obA -> obA -> Type.
Variable morB : obB -> obB -> Type.
Variable morC : obC -> obC -> Type.

Variable A: Cat_struct morA.
Variable B: Cat_struct morB.
Variable C: Cat_struct morC.

Variables (F F': Functor A B) (G G': Functor B C).
Variables (alpha: F ---> F') (beta: G ---> G').

(** no choice in the definition of horizontal composition *)
Lemma no_choice (a: obA):
       beta (F a) ;; #G' (alpha a) ==
          #G  (alpha a) ;; beta (F' a).
Proof.
  intro a.
  rewrite (NTcomm beta).
  cat.
Qed.

(**  definition of the composite and proof of NT axiom *)

Definition hcompNT1 (a:obA) := #G (alpha a) ;; (beta (F' a)).

Lemma hcompNT_ax: trafo_comm (F:= CompF F G)
                             (G:= CompF F' G') hcompNT1.
Proof.
  unfold trafo_comm.
  intros a b f. simpl.
  unfold hcompNT1.
  simpl.
  repeat rewrite <- assoc.
  setoid_rewrite <- (FComp G (#F f)).
  rewrite <- (NTcomm beta).
  rewrite <- (NTcomm beta ((#F f) ;; alpha b)).
  rewrite <- (NTcomm alpha).
  rewrite  FComp.
  repeat rewrite assoc.
  apply hom_refl.
Qed.

Definition hcompNT : NT (CompF F G) (CompF F' G') := Build_NT
   (Build_NT_struct hcompNT_ax).

End hcomp.

(** horizontal composition has an identity NT *)
Section hidNT.

Variable obC: Type.
Variable morC : obC -> obC -> Type.
Variable C : Cat_struct morC.

Definition hidNT1 := fun c:obC => id (Id C c).

Lemma hidNT_ax : trafo_comm hidNT1.
Proof.
  unfold trafo_comm.
  intros c d f.
  unfold hidNT1.
  simpl.
  cat.
Qed.

Definition hidNT: NT (Id C) (Id C) := Build_NT
     (trafo := hidNT1)
     (Build_NT_struct hidNT_ax).

End hidNT.

(** equality of NT, heterogeneous version eq_NTh,
         using Equal_hom instead of == *)
Section EXT_NT_HET.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variables F G F' G' : Functor C D.
Variable alpha : NT F G.
Variable beta : NT F' G'.

Definition EXT_NT_HET := forall c:obC, alpha c ===  beta c.
End EXT_NT_HET.

(** the heterogeneous equality is also a setoid *)

Section EXT_NT_HET_lemmata.
(* Variables C D: Category. *)

Notation "a =h= b" := (EXT_NT_HET a b) (at level 60).

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variables F G: Functor C D.
Variable alpha: NT F G.

Lemma eq_NTh_refl:  alpha =h= alpha.
Proof.
  intro c.
  apply Build_Equal_hom.
  apply hom_refl.
Qed.

Variable F' G': Functor C D.
Variable beta: F' ---> G'.

Lemma eq_NTh_sym: alpha =h= beta -> beta =h= alpha.
Proof.
  intros H c.
  apply Equal_hom_sym.
  auto.
Qed.

Variable F'' G'' : Functor C D.
Variable gamma: F'' ---> G''.

Lemma eq_NTh_trans: alpha =h= beta -> beta =h= gamma ->
                            alpha =h= gamma.
Proof.
  intros H H' c.
  apply (Equal_hom_trans (H c) (H' c)).
Qed.

End EXT_NT_HET_lemmata.

(**  Properties of horizontal composition with
       respect to heterogeneous equality *)

Section hor_comp_properties.

Notation "a 'OO' b" := (hcompNT  a b)(at level 60).

(** hor comp of NT is post-neutral *)

Section hor_comp.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variables F G: Functor C D.
Variable alpha : F ---> G.

(** we have
      - [alpha : F ---> G]
      - [alpha o (idNT D) : F ---> G o Id]

     in order to compare those we need heterogeneous equality on
     natural transformations

*)

Lemma hid_L: EXT_NT_HET (alpha OO (hidNT D)) alpha.
Proof.
  unfold EXT_NT_HET,hidNT,
         hcompNT,
         hcompNT1.
  simpl; unfold hidNT1.
  simpl.
  intro c.
  apply Build_Equal_hom.
  cat.
Qed.

End hor_comp.

(** we want to have a type where we can build a relation EXT_NT_HET *)
(** an element of NTlarge is a triple (F,G,alpha)  *)

Section NTlarge.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Record NTlarge := {
  SrcF : Functor C D;
  TgtF : Functor C D;
  NT_l : SrcF ---> TgtF
}.

Definition NT_from_NTl (alpha: NTlarge) : forall c:obC,
                    morD (SrcF alpha c) (TgtF alpha c) :=
                 fun c => NT_l alpha c.

(**   equality in the type of elements (F,G,alpha)
      - [alpha : F ---> G]
      - [beta: F' ---> G' ]
    are  equal if they are extensionally equal
      - this is a setoid   *)

Definition EXT_NTh : relation NTlarge :=
   fun alpha beta: NTlarge =>
     forall c:obC, NT_l alpha c === NT_l beta c.

End NTlarge.

Section EXT_NTh_lemmata.

(* Variables C D: Category. *)

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Notation "=NT=" := (@EXT_NTh _ _ _ _ C D ).

Lemma Equal_NT_refl: @Reflexive _ =NT=.
Proof.
  unfold Reflexive.
  intros x c.
  apply Equal_hom_refl.
Qed.

Lemma Equal_NT_sym: @Symmetric _ =NT=.
Proof.
  unfold Symmetric.
  intros x y H c.
  apply Equal_hom_sym.
  apply (H c).
Qed.

Lemma Equal_NT_trans: @Transitive _ =NT=.
Proof.
  unfold Transitive.
  intros x y z H H' c.
  apply (Equal_hom_trans (H c) (H' c)).
Qed.

Lemma Equal_NT_equiv: Equivalence =NT=.
Proof.
  split.
  apply Equal_NT_refl.
  apply Equal_NT_sym.
  apply Equal_NT_trans.
Qed.

Definition Equal_NT := Build_Setoid Equal_NT_equiv.

(** the horizontal identity NT hidNT is indeed neutral *)

(* Variables C D : Category. *)

Variables F G: Functor C D.
Variable alpha: F ---> G.

(** proof only for post-composition *)

Lemma hid_l:  EXT_NTh (Build_NTlarge  (alpha OO hidNT D))
                     (Build_NTlarge alpha  ).
Proof.
  assert (H:=hid_L).
  unfold EXT_NT_HET in H.
  intro c.
  simpl in *.
  unfold hcompNT1 in *.
  simpl in *.
  auto.
Qed.

End EXT_NTh_lemmata.

End hor_comp_properties.