home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / util / intmapf.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  6.4 KB  |  216 lines
  1. signature INTMAPF =
  2. sig
  3.   type 'a intmap
  4.   val empty : 'a intmap
  5.   val singleton : int * 'a  -> 'a intmap
  6.   val overlay : 'a intmap * 'a intmap -> 'a intmap
  7.   val add : 'a intmap * int * 'a  -> 'a intmap
  8.   exception IntmapF
  9.   val lookup : 'a intmap -> int -> 'a
  10.   val members : 'a intmap -> (int * 'a) list
  11.   val cardinality : 'a intmap -> int
  12.   val difference : 'a intmap * 'b intmap -> 'a intmap
  13.   val delete : int * 'a intmap -> 'a intmap
  14. end
  15.  
  16. (*
  17.     Copyright 1992 Stephen Adams.
  18.  
  19.     ALTERED FROM THE ORIGINAL by Andrew Appel
  20.  
  21.     This software may be used freely provided that:
  22.       1. This copyright notice is attached to any copy, derived work,
  23.          or work including all or part of this software.
  24.       2. Any derived work must contain a prominent notice stating that
  25.          it has been altered from the original.
  26.  
  27. *)
  28.  
  29. (* Name(s): Stephen Adams.
  30.    Department, Institution: Electronics & Computer Science,
  31.       University of Southampton
  32.    Address:  Electronics & Computer Science
  33.              University of Southampton
  34.          Southampton  SO9 5NH
  35.          Great Britian
  36.    E-mail:   sra@ecs.soton.ac.uk
  37.  
  38.    Comments:
  39.  
  40.      1.  The implementation is based on Binary search trees of Bounded
  41.          Balance, similar to Nievergelt & Reingold, SIAM J. Computing
  42.          2(1), March 1973.  The main advantage of these trees is that
  43.          they keep the size of the tree in the node, giving a constant
  44.          time size operation.
  45.  
  46.      2.  The bounded balance criterion is simpler than N&R's alpha.
  47.          Simply, one subtree must not have more than `weight' times as
  48.          many elements as the opposite subtree.  Rebalancing is
  49.          guaranteed to reinstate the criterion for weight>2.23, but
  50.          the occasional incorrect behaviour for weight=2 is not
  51.          detrimental to performance.
  52.  
  53. *)
  54.  
  55. abstraction IntmapF : INTMAPF =
  56.     struct
  57.  
  58.     local
  59.  
  60.         val weight = 3
  61.  
  62.         datatype 'a Map = E | T of int * 'a * int * 'a Map * 'a Map
  63.  
  64.         fun size E = 0
  65.           | size (T(_,_,n,_,_)) = n
  66.         
  67.         (*fun N(v,a,l,r) = T(v,a,1+size(l)+size(r),l,r)*)
  68.         fun N(v,a,E,              E)               = T(v,a,1,E,E)
  69.           | N(v,a,E,              r as T(_,_,n,_,_)) = T(v,a,n+1,E,r)
  70.           | N(v,a,l as T(_,_,n,_,_),E)               = T(v,a,n+1,l,E)
  71.           | N(v,a,l as T(_,_,n,_,_),r as T(_,_,m,_,_)) = T(v,a,n+m+1,l,r)
  72.  
  73.         fun single_L (a,a',x,T(b,b',_,y,z)) = N(b,b',N(a,a',x,y),z)
  74.           | single_L _ = raise Match
  75.         fun single_R (b,b',T(a,a',_,x,y),z) = N(a,a',x,N(b,b',y,z))
  76.           | single_R _ = raise Match
  77.         fun double_L (a,a',w,T(c,c',_,T(b,b',_,x,y),z)) = N(b,b',N(a,a',w,x),N(c,c',y,z))
  78.           | double_L _ = raise Match
  79.         fun double_R (c,c',T(a,a',_,w,T(b,b',_,x,y)),z) = N(b,b',N(a,a',w,x),N(c,c',y,z))
  80.           | double_R _ = raise Match
  81.  
  82.         fun T' (v,v',E,E) = T(v,v',1,E,E)
  83.           | T' (v,v',E,r as T(_,_,_,E,E))     = T(v,v',2,E,r)
  84.           | T' (v,v',l as T(_,_,_,E,E),E)     = T(v,v',2,l,E)
  85.  
  86.           | T' (p as (_,_,E,T(_,_,_,T(_,_,_,_,_),E))) = double_L p
  87.           | T' (p as (_,_,T(_,_,_,E,T(_,_,_,_,_)),E)) = double_R p
  88.  
  89.           (* these cases almost never happen with small weight*)
  90.           | T' (p as (_,_,E,T(_,_,_,T(_,_,ln,_,_),T(_,_,rn,_,_)))) =
  91.         if ln<rn then single_L p else double_L p
  92.           | T' (p as (_,_,T(_,_,_,T(_,_,ln,_,_),T(_,_,rn,_,_)),E)) =
  93.         if ln>rn then single_R p else double_R p
  94.  
  95.           | T' (p as (_,_,E,T(_,_,_,E,_)))  = single_L p
  96.           | T' (p as (_,_,T(_,_,_,_,E),E))  = single_R p
  97.  
  98.           | T' (p as (v,v',l as T(lv,lv',ln,ll,lr),r as T(rv,rv',rn,rl,rr))) =
  99.         if rn>=weight*ln then (*right is too big*)
  100.             let val rln = size rl
  101.             val rrn = size rr
  102.             in
  103.             if rln < rrn then  single_L p  else  double_L p
  104.             end
  105.             
  106.         else if ln>=weight*rn then  (*left is too big*)
  107.             let val lln = size ll
  108.             val lrn = size lr
  109.             in
  110.             if lrn < lln then  single_R p  else  double_R p
  111.             end
  112.  
  113.         else
  114.                  T(v,v',ln+rn+1,l,r)
  115.  
  116.         fun add (E,x,x') = T(x,x',1,E,E)
  117.           | add (set as T(v,v',_,l,r),x,x') =
  118.             if x<v then T'(v,v',add(l,x,x'),r)
  119.         else if x>v then T'(v,v',l,add(r,x,x'))
  120.              else set
  121.  
  122.         fun concat3 (E,v,v',r) = add(r,v,v')
  123.           | concat3 (l,v,v',E) = add(l,v,v')
  124.           | concat3 (l as T(v1,v1',n1,l1,r1), v, v', r as T(v2,v2',n2,l2,r2)) =
  125.         if weight*n1 < n2 then T'(v2,v2',concat3(l,v,v',l2),r2)
  126.         else if weight*n2 < n1 then T'(v1,v1',l1,concat3(r1,v,v',r))
  127.              else N(v,v',l,r)
  128.  
  129.         fun split_lt (E,x) = E
  130.           | split_lt (t as T(v,v',_,l,r),x) =
  131.         if v>x then split_lt(l,x)
  132.         else if v<x then concat3(l,v,v',split_lt(r,x))
  133.              else l
  134.  
  135.         fun split_gt (E,x) = E
  136.           | split_gt (t as T(v,v',_,l,r),x) =
  137.         if v<x then split_gt(r,x)
  138.         else if v>x then concat3(split_gt(l,x),v,v',r)
  139.              else r
  140.  
  141.         and delmin (T(v,v',_,E,r)) = (v,v',r)
  142.           | delmin (T(v,v',_,l,r)) = let val (x,x',l') = delmin l
  143.                                   in (x,x',T'(v,v',l',r))
  144.                      end
  145.           | delmin _ = raise Match
  146.  
  147.         and cat2 (E,r) = r
  148.           | cat2 (l,E) = l
  149.           | cat2 (l,r) = let val (x,x',r') = delmin r
  150.                          in T'(x,x',l,r')
  151.                                 end
  152.  
  153.         fun concat (E,  s2) = s2
  154.           | concat (s1, E)  = s1
  155.           | concat (t1 as T(v1,v1',n1,l1,r1), t2 as T(v2,v2',n2,l2,r2)) =
  156.         if weight*n1 < n2 then T'(v2,v2',concat(t1,l2),r2)
  157.         else if weight*n2 < n1 then T'(v1,v1',l1,concat(r1,t2))
  158.              else cat2(t1,t2)
  159.  
  160.         fun fold(f,base,set) =
  161.         let fun fold'(base,E) = base
  162.               | fold'(base,T(v,v',_,l,r)) = fold'(f((v,v'),fold'(base,r)),l)
  163.         in 
  164.             fold'(base,set)
  165.         end
  166.  
  167.     in
  168.  
  169.         type  'a intmap = 'a Map
  170.  
  171.         val empty = E
  172.         
  173.         fun singleton (x,x') = T(x,x',1,E,E)
  174.  
  175.         fun overlay (E,s2)  = s2
  176.           | overlay (s1,E)  = s1
  177.           | overlay (s1 as T(v,v',_,l,r),s2) = 
  178.         let val l2 = split_lt(s2,v)
  179.             val r2 = split_gt(s2,v)
  180.         in
  181.             concat3(overlay(l,l2),v,v',overlay(r,r2))
  182.         end
  183.  
  184.         val add = add
  185.  
  186.         fun difference (E,s)  = E
  187.           | difference (s,E)  = s
  188.           | difference (s, T(v,_,_,l,r)) =
  189.         let val l2 = split_lt(s,v)
  190.             val r2 = split_gt(s,v)
  191.         in
  192.             concat(difference(l2,l),difference(r2,r))
  193.         end
  194.  
  195.             exception IntmapF
  196.  
  197.         fun lookup set x =
  198.         let fun mem E = raise IntmapF
  199.               | mem (T(v,v',_,l,r)) = 
  200.             if x<v then mem l else if x>v then mem r else v'
  201.         in mem set end
  202.  
  203.         fun members set = fold(op::,[],set)
  204.  
  205.         fun cardinality E = 0
  206.           | cardinality (T(_,_,n,_,_)) = n
  207.         
  208.         fun delete (x,E) = E
  209.           | delete (x,set as T(v,v',_,l,r)) =
  210.         if x<v then T'(v,v',delete(x,l),r)
  211.         else if x>v then T'(v,v',l,delete(x,r))
  212.              else cat2(l,r)
  213.  
  214.     end
  215.     end
  216.