(* * Functional splay sets. * * ---------------------------------------------------------------- * * @begin[license] * Copyright (C) 2000 Jason Hickey, Caltech * * This program is free software; you can redistribute it and/or * modify it 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 program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. * * Author: Jason Hickey * @email{jyh@cs.caltech.edu} * @end[license] *) (* * Signature for the module that defines * the elements in the set. The elements * are totally ordered by the compare function. *) module type EltSig = sig type elt val compare : elt -> elt -> int end (* * Finite sets, and operations on those sets. *) module type SetSig = sig type t type elt val empty : t val mem : elt -> t -> bool val insert : elt -> t -> t val delete : elt -> t -> t end (* * Build a set over a totally ordered type. *) module Make (Ord : EltSig) = struct (************************************************************************ * TYPES * ************************************************************************) type elt = Ord.elt (* * Table is a binary tree. * Each node has four fields: * 1. a key * 2. a left child * 3. a right child * 4. the total number of elements in the tree *) type tree = Leaf | Node of elt * tree * tree * int (* * The tree is mutable * so that we can rearrange the tree in place. * However, we all splay operations are functional, * and we assume that the rearranged tree can be * assigned atomically to this field. *) type t = { mutable splay_tree : tree } (* * Directions are used to define * paths in the tree. *) type direction = Left of tree | Right of tree (* * Result of a splay operation. *) type splay_result = SplayFound of tree | SplayNotFound of tree (************************************************************************ * IMPLEMENTATION * ************************************************************************) (* * Size of a table. *) let cardinality = function Node (_, _, _, size) -> size | Leaf -> 0 let cardinal s1 = cardinality s1.splay_tree (* * Add two nodes. *) let new_node key left right = Node (key, left, right, cardinality left + cardinality right + 1) (* * This function performs the action of moving an entry * to the root. The argument is the path to the entry. *) let rec lift key left right = function [] -> new_node key left right | [Left (Node (key', _, right', _))] -> new_node key left (new_node key' right right') | [Right (Node (key', left', _, _))] -> new_node key (new_node key' left' left) right | Left (Node (key_left, _, left_right, _)) :: Left (Node (key', _, right', _)) :: ancestors -> lift key left (new_node key_left right (new_node key' left_right right')) ancestors | Right (Node (key_right, right_left, _, _)) :: Right (Node (key', left', _, _)) :: ancestors -> lift key (new_node key_right (new_node key' left' right_left) left) right ancestors | Left (Node (key_right, _, right_right, _)) :: Right (Node (key', left', _, _)) :: ancestors -> lift key (new_node key' left' left) (new_node key_right right right_right) ancestors | Right (Node (key_left, left_left, _, _)) :: Left (Node (key', _, right', _)) :: ancestors -> lift key (new_node key_left left_left left) (new_node key' right right') ancestors | _ -> raise (Invalid_argument "lift") (* * Find an entry in the tree. * Returns true iff the entry is found. * Transforms the tree so that either the * entry becomes the root, or an adjacent entry * becomes the root if the entry is not found. *) let rec splay compare key0 path = function Node (key, left, right, _) as node -> let comp = compare key0 key in if comp = 0 then SplayFound (lift key left right path) else if comp < 0 then if left = Leaf then SplayNotFound (lift key left right path) else splay compare key0 (Left node :: path) left else if right = Leaf then SplayNotFound (lift key left right path) else splay compare key0 (Right node :: path) right | Leaf -> SplayNotFound Leaf (* * An empty tree is just a leaf. *) let empty = { splay_tree = Leaf } (* * check if a key is listed in the table. *) let mem key t = match splay Ord.compare key [] t.splay_tree with SplayFound tree -> t.splay_tree <- tree; true | SplayNotFound tree -> t.splay_tree <- tree; false (* * Add an entry to the tree. *) let insert key t = match splay Ord.compare key [] t.splay_tree with SplayFound tree -> t.splay_tree <- tree; t | SplayNotFound tree -> let tree = match tree with Node (key', left, right, size) -> if Ord.compare key key' < 0 then new_node key left (new_node key' Leaf right) else new_node key (new_node key' left Leaf) right | Leaf -> (* Tree is empty, so make a new root *) new_node key Leaf Leaf in { splay_tree = tree } (* * Remove the first entry from the hashtable. * If the value list becomes empty, remove the * entire entry from the tree. *) let delete key t = match splay Ord.compare key [] t.splay_tree with SplayFound tree -> begin match tree with Node (_, Leaf, right, _) -> { splay_tree = right } | Node (_, left, Leaf, _) -> { splay_tree = left } | Node (_, left, right, _) -> begin match splay (fun _ _ -> -1) key [] left with SplayNotFound (Node (key, left_left, Leaf, _)) -> { splay_tree = new_node key left_left right } | _ -> raise (Failure "Fun_splay_set.remove") end | Leaf -> raise (Failure "Fun_splay_set.remove") end | SplayNotFound tree -> t.splay_tree <- tree; t end (*! * @docoff * * -*- * Local Variables: * Caml-master: "compile" * End: * -*- *)