(** The module of maps over positive keys *)
Module E:=PositiveOrderedTypeBits.
Module ME:=KeyOrderedType E.
Definition key := positive : Type.
#[universes(template)]
Inductive tree (A : Type) :=
| Leaf : tree A
| Node : tree A -> option A -> tree A -> tree A.
Scheme tree_ind := Induction for tree Sort Prop.
Definition t := tree.
Section A.
Variable A:Type.
Arguments Leaf {A}.
Definition empty : t A := Leaf.
Fixpoint is_empty (m : t A) : bool :=
match m with
| Leaf => true
| Node l None r => (is_empty l) && (is_empty r)
| _ => false
end.
Fixpoint find (i : key) (m : t A) : option A :=
match m with
| Leaf => None
| Node l o r =>
match i with
| xH => o
| xO ii => find ii l
| xI ii => find ii r
end
end.
Fixpoint mem (i : key) (m : t A) : bool :=
match m with
| Leaf => false
| Node l o r =>
match i with
| xH => match o with None => false | _ => true end
| xO ii => mem ii l
| xI ii => mem ii r
end
end.
Fixpoint add (i : key) (v : A) (m : t A) : t A :=
match m with
| Leaf =>
match i with
| xH => Node Leaf (Some v) Leaf
| xO ii => Node (add ii v Leaf) None Leaf
| xI ii => Node Leaf None (add ii v Leaf)
end
| Node l o r =>
match i with
| xH => Node l (Some v) r
| xO ii => Node (add ii v l) o r
| xI ii => Node l o (add ii v r)
end
end.
Fixpoint remove (i : key) (m : t A) : t A :=
match i with
| xH =>
match m with
| Leaf => Leaf
| Node Leaf _ Leaf => Leaf
| Node l _ r => Node l None r
end
| xO ii =>
match m with
| Leaf => Leaf
| Node l None Leaf =>
match remove ii l with
| Leaf => Leaf
| mm => Node mm None Leaf
end
| Node l o r => Node (remove ii l) o r
end
| xI ii =>
match m with
| Leaf => Leaf
| Node Leaf None r =>
match remove ii r with
| Leaf => Leaf
| mm => Node Leaf None mm
end
| Node l o r => Node l o (remove ii r)
end
end.
(** [elements] *)
Fixpoint xelements (m : t A) (i : key) : list (key * A) :=
match m with
| Leaf => nil
| Node l None r =>
(xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
| Node l (Some x) r =>
(xelements l (append i (xO xH)))
++ ((i, x) :: xelements r (append i (xI xH)))
end.
(* Note: function [xelements] above is inefficient.  We should apply deforestation to it, but that makes the proofs even harder. *)
Definition elements (m : t A) := xelements m xH.
(** [cardinal] *)
Fixpoint cardinal (m : t A) : nat :=
match m with
| Leaf => 0%nat
| Node l None r => (cardinal l + cardinal r)%nat
| Node l (Some _) r => S (cardinal l + cardinal r)
end.
Section CompcertSpec.

(* Specifications: *)
Theorem gempty:
forall (i: key), find i empty = None.
Theorem gss:
forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x.
Lemma gleaf : forall (i : key), find i (Leaf : t A) = None.
Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
Theorem gro:
forall (i j: key) (m: t A),
i <> j -> find i (remove j m) = find i m.
Lemma xelements_correct:
forall (m: t A) (i j : key) (v: A),
find i m = Some v -> List.In (append j i, v) (xelements m j).
Theorem elements_correct:
forall (m: t A) (i: key) (v: A),
find i m = Some v -> List.In (i, v) (elements m).