(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)
(** A heap data structure. *)
(** The implementation uses splay heaps, following C. Okasaki, "Purely functional data structures", section 5.4. One difference: we eliminate duplicate elements. (If an element is already in a heap, inserting it again does nothing.) *)
(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.
Module SplayHeapSet(E: OrderedType).
(** "Raw" implementation.  The "is a binary search tree" invariant is proved separately. *)
Module R.
Inductive heap: Type :=
| Empty
| Node (l: heap) (x: E.t) (r: heap).
Fixpoint partition (pivot: E.t) (h: heap) { struct h } : heap * heap :=
match h with
| Empty => (Empty, Empty)
| Node a x b =>
match E.compare x pivot with
| EQ _ => (a, b)
| LT _ =>
match b with
| Empty => (h, Empty)
| Node b1 y b2 =>
match E.compare y pivot with
| EQ _ => (Node a x b1, b2)
| LT _ =>
let (small, big) := partition pivot b2
in (Node (Node a x b1) y small, big)
| GT _ =>
let (small, big) := partition pivot b1
in (Node a x small, Node big y b2)
end
end
| GT _ =>
match a with
| Empty => (Empty, h)
| Node a1 y a2 =>
match E.compare y pivot with
| EQ _ => (a1, Node a2 x b)
| LT _ =>
let (small, big) := partition pivot a2
in (Node a1 y small, Node big x b)
| GT _ =>
let (small, big) := partition pivot a1
in (small, Node big y (Node a2 x b))
end
end
end
end.
Definition insert (x: E.t) (h: heap) : heap :=
let (a, b) := partition x h in Node a x b.
Fixpoint findMin (h: heap) : option E.t :=
match h with
| Empty => None
| Node Empty x b => Some x
| Node a x b => findMin a
end.
Fixpoint deleteMin (h: heap) : heap :=
match h with
| Empty => Empty
| Node Empty x b => b
| Node (Node Empty x b) y c => Node b y c
| Node (Node a x b) y c => Node (deleteMin a) x (Node b y c)
end.
Fixpoint findMax (h: heap) : option E.t :=
match h with
| Empty => None
| Node a x Empty => Some x
| Node a x b => findMax b
end.
Fixpoint deleteMax (h: heap) : heap :=
match h with
| Empty => Empty
| Node b x Empty => b
| Node b x (Node c y Empty) => Node b x c
| Node a x (Node b y c) => Node (Node a x b) y (deleteMax c)
end.
(** Induction principles for some of the operators. *)
Scheme heap_ind := Induction for heap Sort Prop.
Functional Scheme partition_ind := Induction for partition Sort Prop.
Functional Scheme deleteMin_ind := Induction for deleteMin Sort Prop.
Functional Scheme deleteMax_ind := Induction for deleteMax Sort Prop.
(** Specification *)
Fixpoint In (x: E.t) (h: heap) : Prop :=
match h with
| Empty => False
| Node a y b => In x a \/ E.eq x y \/ In x b
end.
(** Invariants *)
Fixpoint lt_heap (h: heap) (x: E.t) : Prop :=
match h with
| Empty => True
| Node a y b => lt_heap a x /\ E.lt y x /\ lt_heap b x
end.
Fixpoint gt_heap (h: heap) (x: E.t) : Prop :=
match h with
| Empty => True
| Node a y b => gt_heap a x /\ E.lt x y /\ gt_heap b x
end.
Fixpoint bst (h: heap) : Prop :=
match h with
| Empty => True
| Node a x b => bst a /\ bst b /\ lt_heap a x /\ gt_heap b x
end.
Definition le (x y: E.t) := E.eq x y \/ E.lt x y.

Lemma lt_heap_trans:
forall x y, le x y ->
forall h, lt_heap h x -> lt_heap h y.