[Camomile-commits] camomile/internal orderd.ml,NONE,1.1

[<yo...@us...>]

Update of /cvsroot/camomile/camomile/internal
In directory usw-pr-cvs1:/tmp/cvs-serv27645

Added Files:
	orderd.ml 
Log Message:
Replace a splay tree to a btree.  First try.


--- NEW FILE: orderd.ml ---
(* $Id: orderd.ml,v 1.1 2002/08/06 11:17:51 yori Exp $ *)
(* Copyright 2002 Yamagata Yoriyuki *)

module type Type =
  sig
    type t
    val compare : t -> t -> int
  end

module Map (Key : Type) :
    sig
      type 'a t
      val empty : 'a t
      val add : Key.t -> 'a -> 'a t -> 'a t
      val find : Key.t -> 'a t -> 'a
      val remove : Key.t -> 'a t -> 'a t
      val mem : Key.t -> 'a t -> bool
      val max_elt : 'a t -> Key.t
      val min_elt : 'a t -> Key.t
	(* after a s : (a, inf) \cap s *)
      val after : Key.t -> 'a t -> 'a t
	(* before a s : (-inf, a) \cap s *)
      val before : Key.t -> 'a t -> 'a t
      val join : 'a t -> 'a t -> 'a t
	(* floor a s : greatest element x with x <= a *)
      val floor : Key.t -> 'a t -> Key.t
	(* prev a s : greatest element x with x < a *)
      val prev : Key.t -> 'a t -> Key.t
	(* ceil a s : smallest element x with x >= a *)
      val ceil : Key.t -> 'a t -> Key.t
	(* prev a s : smallest element x with x > a *)
      val next : Key.t -> 'a t -> Key.t
      val iter : (Key.t -> 'a -> unit) -> 'a t -> unit
      val map : ('a -> 'b) -> 'a t -> 'b t
      val mapi : (Key.t -> 'a -> 'b) -> 'a t -> 'b t
      val fold : (Key.t -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
      val filter : (Key.t -> bool) -> 'a t -> 'a t
    end =
  struct

    type 'a t = Empty | Node of 'a t * Key.t * 'a * 'a t * int

    let empty = Empty

    let height = function
	Empty -> 0
      |	Node (_, _, _, _, h) -> h

    let rec bal l k v r =
      let hl = height l in
      let hr = height r in
      if hl - hr >= 2 then
	match l with
	  Empty -> assert false
	| Node (ll, lk, lv, lr, _) ->
	    if height ll >= height lr then
	      let r' = bal lr k v r in
	      Node (ll, lk, lv, r', 1 + max (height ll) (height r'))
	    else
	      match lr with
		Empty -> assert false
	      |	Node (lrl, lrk, lrv, lrr, hlr) ->
		  let l' = bal ll lk lv lrl in
		  let r' = bal lrr k v r in
		  let h = 1 + max (height l') (height r') in
		  Node (l', lrk, lrv, r', h)
      else if hr - hl >= 2 then
	match r with
	  Empty -> assert false
	| Node (rl, rk, rv, rr, _) ->
	    if height rl <= height rr then
	      let l' = bal l k v rl in
	      Node (l', rk, rv, rr, 1 + max (height l') (height rr))
	    else
	      match rl with
		Empty -> assert false
	      |	Node (rll, rlk, rlv, rlr, hrl) ->
		  let l' = bal l k v rll in
		  let r' = bal rlr rk rv rr in
		  let h = 1 + max (height l') (height r') in
		  Node (l', rlk, rlv, r', h)
      else
	Node (l, k, v, r, 1 + max hl hr)

    let rec concat l r =
      let hl = height l in
      let hr = height r in
      if hl = 0 then r else
      if hr = 0 then l else
      if hl >= hr then
	match l with
	  Empty -> Empty
	| Node (ll, lk, lv, lr, hl) ->
	    if height ll >= height lr then
	      let r' = concat lr r in
	      Node (ll, lk, lv, r', 1 + max (height r') (height ll))
	    else
	      match lr with
		Empty -> Node (ll, lk, lv, r, 1 + hr)
	      |	Node (lrl, lrk, lrv, lrr, hlr) ->
		  let l' = bal ll lk lv lrl in
		  let r' = concat lrr r in
		  let h = 1 + max (height l') (height r') in
		  Node (l', lrk, lrv, r', h)
      else
	match r with
	  Empty -> Empty
	| Node (rl, rk, rv, rr, hr) ->
	    if height rl <= height rr then
	      let l' = concat l rl in
	      Node (l', rk, rv, rr, 1 + max (height l') (height rr))
	    else
	      match rl with
		Empty -> Node (l, rk, rv, rr, 1 + hl)
	      |	Node (rll, rlk, rlv, rlr, hrl) ->
		  let l' = concat l rll in
		  let r' = bal rlr rk rv rr in
		  let h = 1 + max (height l') (height r') in
		  Node (l', rlk, rlv, r', h)

    let rec add k v = function
	Empty -> Node (Empty, k, v, Empty, 1)
      |	Node (l, k', v', r, h) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then bal (add k v l) k' v' r else 
	  if sgn = 0 then Node (l, k, v, r, h) else
	  bal l k' v' (add k v r)

    let rec find k = function
	Empty -> raise Not_found
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then find k l else
	  if sgn = 0 then v' else
	  find k r

    let rec mem k = function
	Empty -> false
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then mem k l else
	  if sgn = 0 then true else
	  mem k r

    let rec remove k = function
	Empty -> Empty
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then bal (remove k l) k' v' r else
	  if sgn = 0 then concat l r else
	  bal l k' v' (remove k r)

    let rec max_elt = function
	Empty -> raise Not_found
      |	Node (l, k, v, r, _) ->
	  if r = Empty then k else max_elt r

    let rec min_elt = function
	Empty -> raise Not_found
      |	Node (l, k, v, r, _) ->
	  if l = Empty then k else min_elt l

    let rec after k = function
	Empty -> Empty
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then bal (after k l) k' v' r else
	  if sgn = 0 then r else
	  after k r
	    
    let rec before k = function
	Empty -> Empty
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then before k l else
	  if sgn = 0 then l else
	  bal l k' v' (before k r)

    let rec join s1 s2 =
      let s1, s2 = if height s1 >= height s2 then (s1, s2) else (s2, s1) in
      match s1, s2 with
	Empty, _ -> s2
      |	_, Empty -> s1
      |	Node (l1, k1, v1, r1, _), Node (l2, k2, v2, r2, _) ->
	  let sgn = Key.compare k1 k2 in
	  if sgn < 0 then begin
	    (try 
	      if find k1 l2 <> v1 then failwith "Linear_order.join" else () 
	    with Not_found -> ());
	      let l2_l = before k1 l2 in
	      let l2_r = after k1 l2 in
	      bal (join l1 l2_l) k1 v1 (join r1 (concat l2_r r2)) end
	  else if sgn = 0 then
	    if v1 <> v2 then failwith "Linear_order.join" else
	    bal (join l1 l2) k1 v1 (join r1 r2)
	  else begin
	    (try 
	      if find k1 r2 <> v1 then failwith "Linear_order.join" else () 
	    with Not_found -> ());
	      let r2_l = before k1 r2 in
	      let r2_r = after k1 r2 in
	      bal (join l1 (concat l2 r2_r)) k1 v1 (join r1 r2_l) end
		
    let rec floor k = function 
	Empty -> raise Not_found
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn < 0 then floor k l else
	  if sgn = 0 || r = Empty then k' else
	  floor k r

    let rec prev k = function 
	Empty -> raise Not_found
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn <= 0 then prev k l else
	  if r = Empty then k' else
	  prev k r

    let rec ceil k = function 
	Empty -> raise Not_found
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn > 0 then ceil k r else
	  if sgn = 0 || l = Empty then k' else
	  ceil k l

    let rec next k = function 
	Empty -> raise Not_found
      |	Node (l, k', v', r, _) ->
	  let sgn = Key.compare k k' in
	  if sgn >= 0 then next k r else
	  if l = Empty then k' else
	  next k l

    let rec iter proc = function
	Empty -> ()
      |	Node (l, k, v, r, _) ->
	  iter proc l;
	  proc k v;
	  iter proc r

    let rec mapi f  = function
	Empty -> Empty
      |	Node (l, k, v, r, h) ->
	  let l' = mapi f l in
	  let v' = f k v in
	  let r' = mapi f r in
	  Node (l', k, v', r', h)
	    
    let map f = mapi (fun _ v -> f v)

    let rec fold f s init =
      match s with
	Empty -> init
      |	Node (l, k, v, r, _) ->
	  let x = fold f l init in
	  let x' = f k v x in
	  fold f r x'

    let rec filter sieve = function 
	Empty -> Empty
      |	Node (l, k, v, r, _) ->
	  let l' = filter sieve l in
	  if sieve k then
	    bal l' k v (filter sieve r)
	  else
	    concat l' (filter sieve r)
  end

module Set (Elt : Type) :
    sig
      type t
      val empty : t
      val add : Elt.t -> t -> t
      val remove : Elt.t -> t -> t
      val mem : Elt.t -> t -> bool
      val max : t -> Elt.t
      val min : t -> Elt.t
	(* after a s : (a, inf) \cap s *)
      val after : Elt.t -> t -> t
	(* before a s : (-inf, a) \cap s *)
      val before : Elt.t -> t -> t
      val join : t -> t -> t
	(* floor a s : greatest element x with x <= a *)
      val floor : Elt.t -> t -> Elt.t
	(* prev a s : greatest element x with x < a *)
      val prev : Elt.t -> t -> Elt.t
	(* ceil a s : smallest element x with x >= a *)
      val ceil : Elt.t -> t -> Elt.t
	(* prev a s : smallest element x with x > a *)
      val next : Elt.t -> t -> Elt.t
      val iter : (Elt.t-> unit) -> t -> unit
      val fold : (Elt.t -> 'a -> 'a) -> t -> 'a -> 'a
      val filter : (Elt.t -> bool) -> t -> t
    end =
  struct
    module M = Map (Elt)

    type t = unit M.t
    let empty = M.empty
    let add e s = M.add e () s
    let remove = M.remove
    let mem = M.mem
    let max = M.max_elt
    let min = M.min_elt
    let after = M.after
    let before = M.before
    let join = M.join
    let floor = M.floor
    let prev = M.prev
    let ceil = M.ceil
    let next = M.next
    let iter proc s = M.iter (fun k _ -> proc k) s
    let fold proc s init = M.fold (fun k _ a -> proc k a) s init
    let filter = M.filter
  end