Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.Local Notation int := I.t.Definition key := X.t.(** * Trees *)

(** * Trees

   The fifth field of [Node] is the height of the tree *)

#[universes(template)]
Inductive tree {elt : Type} :=
  | Leaf : tree
  | Node : tree -> key -> elt -> tree -> int -> tree.(** * Trees *)

(** * Trees

   The fifth field of [Node] is the height of the tree *)

#[universes(template)]
Inductive tree {elt : Type} :=
  | Leaf : tree
  | Node : tree -> key -> elt -> tree -> int -> tree.(** * Trees *)

(** * Trees

   The fifth field of [Node] is the height of the tree *)

#[universes(template)]
Inductive tree {elt : Type} :=
  | Leaf : tree
  | Node : tree -> key -> elt -> tree -> int -> tree.Notation t := tree.Implicit Types m : t.(** * Basic functions on trees: height and cardinal *)

Definition height (m : t) : int :=
  match m with
  | Leaf => 0
  | Node _ _ _ _ h => h
  end.Fixpoint cardinal (m : t) : nat :=
  match m with
   | Leaf => 0%nat
   | Node l _ _ r _ => S (cardinal l + cardinal r)
  end.(** * Empty Map *)

Definition empty : t := Leaf.(** * Emptyness test *)

Definition is_empty m := match m with Leaf => true | _ => false end.(** * Membership *)

(** The [mem] function is deciding membership. It exploits the [bst] property
    to achieve logarithmic complexity. *)

Fixpoint mem x m : bool :=
   match m with
     |  Leaf => false
     |  Node l y _ r _ => match X.compare x y with
             | LT _ => mem x l
             | EQ _ => true
             | GT _ => mem x r
         end
   end.Fixpoint find x m : option elt :=
   match m with
     |  Leaf => None
     |  Node l y d r _ => match X.compare x y with
             | LT _ => find x l
             | EQ _ => Some d
             | GT _ => find x r
         end
   end.(** * Helper functions *)

(** [create l x r] creates a node, assuming [l] and [r]
    to be balanced and [|height l - height r| <= 2]. *)

Definition create l x e r :=
   Node l x e r (max (height l) (height r) + 1).(** [bal l x e r] acts as [create], but performs one step of
    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)

Definition assert_false := create.Definition bal l x d r :=
  let hl := height l in
  let hr := height r in
  if gt_le_dec hl (hr+2) then
    match l with
     | Leaf => assert_false l x d r
     | Node ll lx ld lr _ =>
       if ge_lt_dec (height ll) (height lr) then
         create ll lx ld (create lr x d r)
       else
         match lr with
          | Leaf => assert_false l x d r
          | Node lrl lrx lrd lrr _ =>
              create (create ll lx ld lrl) lrx lrd (create lrr x d r)
         end
    end
  else
    if gt_le_dec hr (hl+2) then
      match r with
       | Leaf => assert_false l x d r
       | Node rl rx rd rr _ =>
         if ge_lt_dec (height rr) (height rl) then
            create (create l x d rl) rx rd rr
         else
           match rl with
            | Leaf => assert_false l x d r
            | Node rll rlx rld rlr _ =>
                create (create l x d rll) rlx rld (create rlr rx rd rr)
           end
      end
    else
      create l x d r.(** * Insertion *)

Fixpoint add x d m :=
  match m with
   | Leaf => Node Leaf x d Leaf 1
   | Node l y d' r h =>
      match X.compare x y with
         | LT _ => bal (add x d l) y d' r
         | EQ _ => Node l y d r h
         | GT _ => bal l y d' (add x d r)
      end
  end.(** * Extraction of minimum binding

  Morally, [remove_min] is to be applied to a non-empty tree
  [t = Node l x e r h]. Since we can't deal here with [assert false]
  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
*)

Fixpoint remove_min l x d r : t*(key*elt) :=
  match l with
    | Leaf => (r,(x,d))
    | Node ll lx ld lr lh =>
       let (l',m) := remove_min ll lx ld lr in
       (bal l' x d r, m)
  end.(** * Merging two trees

  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
  of [t1] to be smaller than all elements of [t2], and
  [|height t1 - height t2| <= 2].
*)

Definition merge s1 s2 :=  match s1,s2 with
  | Leaf, _ => s2
  | _, Leaf => s1
  | _, Node l2 x2 d2 r2 h2 =>
    match remove_min l2 x2 d2 r2 with
      (s2',(x,d)) => bal s1 x d s2'
    end
end.(** * Deletion *)

Fixpoint remove x m := match m with
  | Leaf => Leaf
  | Node l y d r h =>
      match X.compare x y with
         | LT _ => bal (remove x l) y d r
         | EQ _ => merge l r
         | GT _ => bal l y d (remove x r)
      end
   end.(** * join

    Same as [bal] but does not assume anything regarding heights of [l]
    and [r].
*)

Fixpoint join l : key -> elt -> t -> t :=
  match l with
    | Leaf => add
    | Node ll lx ld lr lh => fun x d =>
       fix join_aux (r:t) : t := match r with
          | Leaf =>  add x d l
          | Node rl rx rd rr rh =>
               if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r)
               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr
               else create l x d r
          end
  end.(** * Splitting

    [split x m] returns a triple [(l, o, r)] where
    - [l] is the set of elements of [m] that are [< x]
    - [r] is the set of elements of [m] that are [> x]
    - [o] is the result of [find x m].
*)

Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.(** * Splitting

    [split x m] returns a triple [(l, o, r)] where
    - [l] is the set of elements of [m] that are [< x]
    - [r] is the set of elements of [m] that are [> x]
    - [o] is the result of [find x m].
*)

Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.(** * Splitting

    [split x m] returns a triple [(l, o, r)] where
    - [l] is the set of elements of [m] that are [< x]
    - [r] is the set of elements of [m] that are [> x]
    - [o] is the result of [find x m].
*)

Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.(** * Splitting

    [split x m] returns a triple [(l, o, r)] where
    - [l] is the set of elements of [m] that are [< x]
    - [r] is the set of elements of [m] that are [> x]
    - [o] is the result of [find x m].
*)

Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.(** * Splitting

    [split x m] returns a triple [(l, o, r)] where
    - [l] is the set of elements of [m] that are [< x]
    - [r] is the set of elements of [m] that are [> x]
    - [o] is the result of [find x m].
*)

Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).Fixpoint split x m : triple := match m with
  | Leaf => << Leaf, None, Leaf >>
  | Node l y d r h =>
     match X.compare x y with
      | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >>
      | EQ _ => << l, Some d, r >>
      | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >>
     end
 end.(** * Concatenation

   Same as [merge] but does not assume anything about heights.
*)

Definition concat m1 m2 :=
   match m1, m2 with
      | Leaf, _ => m2
      | _ , Leaf => m1
      | _, Node l2 x2 d2 r2 _ =>
            let (m2',xd) := remove_min l2 x2 d2 r2 in
            join m1 xd#1 xd#2 m2'
   end.(** * Elements *)

(** [elements_tree_aux acc t] catenates the elements of [t] in infix
    order to the list [acc] *)

Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) :=
  match m with
   | Leaf => acc
   | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l
  end.(** then [elements] is an instantiation with an empty [acc] *)

Definition elements := elements_aux nil.(** * Fold *)

Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A :=
 fun a => match m with
  | Leaf => a
  | Node l x d r _ => fold f r (f x d (fold f l a))
 end.(** ** Enumeration of the elements of a tree *)

Inductive enumeration :=
 | End : enumeration
 | More : key -> elt -> t -> enumeration -> enumeration.(** ** Enumeration of the elements of a tree *)

Inductive enumeration :=
 | End : enumeration
 | More : key -> elt -> t -> enumeration -> enumeration.(** ** Enumeration of the elements of a tree *)

Inductive enumeration :=
 | End : enumeration
 | More : key -> elt -> t -> enumeration -> enumeration.(** [cons m e] adds the elements of tree [m] on the head of
    enumeration [e]. *)

Fixpoint cons m e : enumeration :=
 match m with
  | Leaf => e
  | Node l x d r h => cons l (More x d r e)
 end.(** One step of comparison of elements *)

Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
 match e2 with
 | End => false
 | More x2 d2 r2 e2 =>
     match X.compare x1 x2 with
      | EQ _ => cmp d1 d2 &&& cont (cons r2 e2)
      | _ => false
     end
 end.(** Comparison of left tree, middle element, then right tree *)

Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
 match m1 with
  | Leaf => cont e2
  | Node l1 x1 d1 r1 _ =>
     equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2
  end.(** Initial continuation *)

Definition equal_end e2 := match e2 with End => true | _ => false end.(** The complete comparison *)

Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).Notation "t #l" := (t_left t) (at level 9, format "t '#l'").Notation "t #o" := (t_opt t) (at level 9, format "t '#o'").Notation "t #r" := (t_right t) (at level 9, format "t '#r'").(** * Map *)

Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _   => Leaf _
   | Node l x d r h => Node (map f l) x (f d) (map f r) h
  end.(* * Mapi *)

Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
  match m with
   | Leaf _ => Leaf _
   | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
  end.(** * Map with removal *)

Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
  : t elt' :=
  match m with
   | Leaf _ => Leaf _
   | Node l x d r h =>
      match f x d with
       | Some d' => join (map_option f l) x d' (map_option f r)
       | None => concat (map_option f l) (map_option f r)
      end
  end.Fixpoint map2_opt m1 m2 :=
 match m1, m2 with
  | Leaf _, _ => mapr m2
  | _, Leaf _ => mapl m1
  | Node l1 x1 d1 r1 h1, _ =>
     let (l2',o2,r2') := split x1 m2 in
     match f x1 d1 o2 with
      | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2')
      | None => concat (map2_opt l1 l2') (map2_opt r1 r2')
     end
 end.Definition map2 : t elt -> t elt' -> t elt'' :=
 map2_opt
   (fun _ d o => f (Some d) o)
   (map_option (fun _ d => f (Some d) None))
   (map_option (fun _ d' => f None (Some d'))).(** ** Occurrence in a tree *)

Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
  | MapsRoot : forall l r h y,
      X.eq x y -> MapsTo x e (Node l y e r h)
  | MapsLeft : forall l r h y e',
      MapsTo x e l -> MapsTo x e (Node l y e' r h)
  | MapsRight : forall l r h y e',
      MapsTo x e r -> MapsTo x e (Node l y e' r h).(** ** Occurrence in a tree *)

Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
  | MapsRoot : forall l r h y,
      X.eq x y -> MapsTo x e (Node l y e r h)
  | MapsLeft : forall l r h y e',
      MapsTo x e l -> MapsTo x e (Node l y e' r h)
  | MapsRight : forall l r h y e',
      MapsTo x e r -> MapsTo x e (Node l y e' r h).(** ** Occurrence in a tree *)

Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
  | MapsRoot : forall l r h y,
      X.eq x y -> MapsTo x e (Node l y e r h)
  | MapsLeft : forall l r h y e',
      MapsTo x e l -> MapsTo x e (Node l y e' r h)
  | MapsRight : forall l r h y e',
      MapsTo x e r -> MapsTo x e (Node l y e' r h).(** ** Occurrence in a tree *)

Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
  | MapsRoot : forall l r h y,
      X.eq x y -> MapsTo x e (Node l y e r h)
  | MapsLeft : forall l r h y e',
      MapsTo x e l -> MapsTo x e (Node l y e' r h)
  | MapsRight : forall l r h y e',
      MapsTo x e r -> MapsTo x e (Node l y e' r h).Inductive In (x : key) : t elt -> Prop :=
  | InRoot : forall l r h y e,
      X.eq x y -> In x (Node l y e r h)
  | InLeft : forall l r h y e',
      In x l -> In x (Node l y e' r h)
  | InRight : forall l r h y e',
      In x r -> In x (Node l y e' r h).Inductive In (x : key) : t elt -> Prop :=
  | InRoot : forall l r h y e,
      X.eq x y -> In x (Node l y e r h)
  | InLeft : forall l r h y e',
      In x l -> In x (Node l y e' r h)
  | InRight : forall l r h y e',
      In x r -> In x (Node l y e' r h).Inductive In (x : key) : t elt -> Prop :=
  | InRoot : forall l r h y e,
      X.eq x y -> In x (Node l y e r h)
  | InLeft : forall l r h y e',
      In x l -> In x (Node l y e' r h)
  | InRight : forall l r h y e',
      In x r -> In x (Node l y e' r h).Inductive In (x : key) : t elt -> Prop :=
  | InRoot : forall l r h y e,
      X.eq x y -> In x (Node l y e r h)
  | InLeft : forall l r h y e',
      In x l -> In x (Node l y e' r h)
  | InRight : forall l r h y e',
      In x r -> In x (Node l y e' r h).Definition In0 k m := exists e:elt, MapsTo k e m.(** ** Binary search trees *)

(** [lt_tree x s]: all elements in [s] are smaller than [x]
   (resp. greater for [gt_tree]) *)

Definition lt_tree x m := forall y, In y m -> X.lt y x.Definition gt_tree x m := forall y, In y m -> X.lt x y.(** [bst t] : [t] is a binary search tree *)

Inductive bst : t elt -> Prop :=
  | BSLeaf : bst (Leaf _)
  | BSNode : forall x e l r h, bst l -> bst r ->
     lt_tree x l -> gt_tree x r -> bst (Node l x e r h).(** [bst t] : [t] is a binary search tree *)

Inductive bst : t elt -> Prop :=
  | BSLeaf : bst (Leaf _)
  | BSNode : forall x e l r h, bst l -> bst r ->
     lt_tree x l -> gt_tree x r -> bst (Node l x e r h).(** [bst t] : [t] is a binary search tree *)

Inductive bst : t elt -> Prop :=
  | BSLeaf : bst (Leaf _)
  | BSNode : forall x e l r h, bst l -> bst r ->
     lt_tree x l -> gt_tree x r -> bst (Node l x e r h).Module MX := OrderedTypeFacts X.Module PX := KeyOrderedType X.Module L := FMapList.Raw X.#[local] Ltac caseq :=
match goal with [ |- context [match ?t with _ => _ end] ] =>
  let cmp := fresh in
  let H := fresh in
  remember t as cmp eqn:H; symmetry in H; destruct cmp
end.

Lemma bal_ind [elt : Type] [P : t elt -> key -> elt -> t elt -> t elt -> Prop] : (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl > hr + 2, gt_le_dec hl (hr + 2) = left _x -> l = Leaf elt -> P (Leaf elt) x d r (assert_false l x d r)) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl > hr + 2, gt_le_dec hl (hr + 2) = left _x -> forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), l = Node ll lx ld lr _x0 -> forall _x1 : height ll >= height lr, ge_lt_dec (height ll) (height lr) = left _x1 -> P (Node ll lx ld lr _x0) x d r (create ll lx ld (create lr x d r))) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl > hr + 2, gt_le_dec hl (hr + 2) = left _x -> forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), l = Node ll lx ld lr _x0 -> forall _x1 : height ll < height lr, ge_lt_dec (height ll) (height lr) = right _x1 -> lr = Leaf elt -> P (Node ll lx ld (Leaf elt) _x0) x d r (assert_false l x d r)) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl > hr + 2, gt_le_dec hl (hr + 2) = left _x -> forall (ll : t elt) (lx : key) (ld : elt) (lr : t elt) (_x0 : int), l = Node ll lx ld lr _x0 -> forall _x1 : height ll < height lr, ge_lt_dec (height ll) (height lr) = right _x1 -> forall (lrl : t elt) (lrx : key) (lrd : elt) (lrr : t elt) (_x2 : int), lr = Node lrl lrx lrd lrr _x2 -> P (Node ll lx ld (Node lrl lrx lrd lrr _x2) _x0) x d r (create (create ll lx ld lrl) lrx lrd (create lrr x d r))) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl <= hr + 2, gt_le_dec hl (hr + 2) = right _x -> forall _x0 : hr > hl + 2, gt_le_dec hr (hl + 2) = left _x0 -> r = Leaf elt -> P l x d (Leaf elt) (assert_false l x d r)) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl <= hr + 2, gt_le_dec hl (hr + 2) = right _x -> forall _x0 : hr > hl + 2, gt_le_dec hr (hl + 2) = left _x0 -> forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), r = Node rl rx rd rr _x1 -> forall _x2 : height rr >= height rl, ge_lt_dec (height rr) (height rl) = left _x2 -> P l x d (Node rl rx rd rr _x1) (create (create l x d rl) rx rd rr)) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl <= hr + 2, gt_le_dec hl (hr + 2) = right _x -> forall _x0 : hr > hl + 2, gt_le_dec hr (hl + 2) = left _x0 -> forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), r = Node rl rx rd rr _x1 -> forall _x2 : height rr < height rl, ge_lt_dec (height rr) (height rl) = right _x2 -> rl = Leaf elt -> P l x d (Node (Leaf elt) rx rd rr _x1) (assert_false l x d r)) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl <= hr + 2, gt_le_dec hl (hr + 2) = right _x -> forall _x0 : hr > hl + 2, gt_le_dec hr (hl + 2) = left _x0 -> forall (rl : t elt) (rx : key) (rd : elt) (rr : t elt) (_x1 : int), r = Node rl rx rd rr _x1 -> forall _x2 : height rr < height rl, ge_lt_dec (height rr) (height rl) = right _x2 -> forall (rll : t elt) (rlx : key) (rld : elt) (rlr : t elt) (_x3 : int), rl = Node rll rlx rld rlr _x3 -> P l x d (Node (Node rll rlx rld rlr _x3) rx rd rr _x1) (create (create l x d rll) rlx rld (create rlr rx rd rr))) -> (forall (l : t elt) (x : key) (d : elt) (r : t elt), let hl := height l in let hr := height r in forall _x : hl <= hr + 2, gt_le_dec hl (hr + 2) = right _x -> forall _x0 : hr <= hl + 2, gt_le_dec hr (hl + 2) = right _x0 -> P l x d r (create l x d r)) -> forall (l : t elt) (x : key) (d : elt) (r : t elt), P l x d r (bal l x d r).