home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / BURKS / LANGUAGE / ML / GIML / BIN-DICT.SML < prev    next >
Text File  |  1996-12-09  |  7KB  |  225 lines
  1. (* binary-dict.sml
  2.  *
  3.  * COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  See COPYRIGHT file for details.
  4.  *
  5.  * This code was adapted from Stephen Adams' binary tree implementation
  6.  * of applicative integer sets.
  7.  *
  8.  *   Copyright 1992 Stephen Adams.
  9.  *
  10.  *    This software may be used freely provided that:
  11.  *      1. This copyright notice is attached to any copy, derived work,
  12.  *         or work including all or part of this software.
  13.  *      2. Any derived work must contain a prominent notice stating that
  14.  *         it has been altered from the original.
  15.  *
  16.  *
  17.  *   Name(s): Stephen Adams.
  18.  *   Department, Institution: Electronics & Computer Science,
  19.  *      University of Southampton
  20.  *   Address:  Electronics & Computer Science
  21.  *             University of Southampton
  22.  *         Southampton  SO9 5NH
  23.  *         Great Britian
  24.  *   E-mail:   sra@ecs.soton.ac.uk
  25.  *
  26.  *   Comments:
  27.  *
  28.  *     1.  The implementation is based on Binary search trees of Bounded
  29.  *         Balance, similar to Nievergelt & Reingold, SIAM J. Computing
  30.  *         2(1), March 1973.  The main advantage of these trees is that
  31.  *         they keep the size of the tree in the node, giving a constant
  32.  *         time size operation.
  33.  *
  34.  *     2.  The bounded balance criterion is simpler than N&R's alpha.
  35.  *         Simply, one subtree must not have more than `weight' times as
  36.  *         many elements as the opposite subtree.  Rebalancing is
  37.  *         guaranteed to reinstate the criterion for weight>2.23, but
  38.  *         the occasional incorrect behaviour for weight=2 is not
  39.  *         detrimental to performance.
  40.  *
  41.  *)
  42.  
  43. functor BinaryDict (K : ORD_KEY) : DICT =
  44.   struct
  45.  
  46.     structure Key = K
  47.     open LibBase K
  48.  
  49.     exception NotFound
  50.  
  51.     (*
  52.     **  val weight = 3
  53.     **  fun wt i = weight * i
  54.     *)
  55.     fun wt (i : int) = i + i + i
  56.  
  57.     datatype 'a dict = 
  58.       E 
  59.     | T of {
  60.         key : ord_key, 
  61.         value : 'a, 
  62.         cnt : int, 
  63.         left : 'a dict, 
  64.         right : 'a dict
  65.     }
  66.  
  67.     fun numItems E = 0
  68.       | numItems (T{cnt,...}) = cnt
  69. local
  70.     fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  71.       | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r}
  72.       | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E}
  73.       | N(k,v,l as T n,r as T n') = 
  74.           T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r}
  75.  
  76.     fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = 
  77.           N(b,bv,N(a,av,x,y),z)
  78.       | single_L _ = raise Match
  79.     fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = 
  80.           N(a,av,x,N(b,bv,y,z))
  81.       | single_R _ = raise Match
  82.     fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) =
  83.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  84.       | double_L _ = raise Match
  85.     fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = 
  86.           N(b,bv,N(a,av,w,x),N(c,cv,y,z))
  87.       | double_R _ = raise Match
  88.  
  89.     fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E}
  90.       | T' (k,v,E,r as T{right=E,left=E,...}) =
  91.           T{key=k,value=v,cnt=2,left=E,right=r}
  92.       | T' (k,v,l as T{right=E,left=E,...},E) =
  93.           T{key=k,value=v,cnt=2,left=l,right=E}
  94.  
  95.       | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p
  96.       | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p
  97.  
  98.         (* these cases almost never happen with small weight*)
  99.       | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) =
  100.           if ln < rn then single_L p else double_L p
  101.       | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) =
  102.           if ln > rn then single_R p else double_R p
  103.  
  104.       | T' (p as (_,_,E,T{left=E,...})) = single_L p
  105.       | T' (p as (_,_,T{right=E,...},E)) = single_R p
  106.  
  107.       | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...},
  108.                       r as T{cnt=rn,left=rl,right=rr,...})) =
  109.           if rn >= wt ln then (*right is too big*)
  110.             let val rln = numItems rl
  111.                 val rrn = numItems rr
  112.             in
  113.               if rln < rrn then  single_L p  else  double_L p
  114.             end
  115.         
  116.           else if ln >= wt rn then  (*left is too big*)
  117.             let val lln = numItems ll
  118.                 val lrn = numItems lr
  119.             in
  120.               if lrn < lln then  single_R p  else  double_R p
  121.             end
  122.     
  123.           else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r}
  124.  
  125.     local
  126.       fun min (T{left=E,key,value,...}) = (key,value)
  127.         | min (T{left,...}) = min left
  128.         | min _ = raise Match
  129.   
  130.       fun delmin (T{left=E,right,...}) = right
  131.         | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right)
  132.         | delmin _ = raise Match
  133.     in
  134.       fun delete' (E,r) = r
  135.         | delete' (l,E) = l
  136.         | delete' (l,r) = let val (mink,minv) = min r in
  137.             T'(mink,minv,l,delmin r)
  138.           end
  139.     end
  140. in
  141.     fun mkDict () = E
  142.     
  143.     fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
  144.       | insert (T(set as {key,left,right,value,...}),x,v) =
  145.           case cmpKey (key,x) of
  146.             Greater => T'(key,value,insert(left,x,v),right)
  147.           | Less => T'(key,value,left,insert(right,x,v))
  148.           | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set}
  149.  
  150.     fun find (set, x) = let 
  151.       fun mem E = raise NotFound
  152.         | mem (T(n as {key,left,right,...})) =
  153.             case cmpKey (x,key) of
  154.               Greater => mem right
  155.             | Less => mem left
  156.             | _ => #value n
  157.       in mem set end
  158.  
  159.     fun peek arg = (SOME(find arg)) handle NotFound => NONE
  160.  
  161.     fun remove (E,x) = raise NotFound
  162.       | remove (set as T{key,left,right,value,...},x) = (
  163.           case cmpKey (key,x)
  164.        of Greater => let
  165.         val (left', v) = remove(left, x)
  166.         in
  167.           (T'(key, value, left', right), v)
  168.         end
  169.             | Less => let
  170.         val (right', v) = remove (right, x)
  171.         in
  172.           (T'(key, value, left, right'), v)
  173.         end
  174.             | _ => (delete'(left,right),value)
  175.       (* end case *))
  176.  
  177.     fun listItems d = let
  178.       fun d2l (E, l) = l
  179.         | d2l (T{key,value,left,right,...}, l) =
  180.             d2l(left,(key,value)::(d2l(right,l)))
  181.       in d2l (d,[]) end
  182.  
  183.     fun revapp f d = let
  184.       fun a E = ()
  185.         | a (T{key,value,left,right,...}) = (a right; f(key,value); a left)
  186.       in a d end
  187.  
  188.     fun app f d = let
  189.       fun a E = ()
  190.         | a (T{key,value,left,right,...}) = (a left; f(key,value); a right)
  191.       in a d end
  192.  
  193.     fun fold f d init = let
  194.       fun a (E,v) = v
  195.         | a (T{key,value,left,right,...},v) = a(left,f(key,value,a(right,v)))
  196.       in a (d, init) end
  197.  
  198.     fun revfold f d init = let
  199.       fun a (E,v) = v
  200.         | a (T{key,value,left,right,...},v) = a(right,f(key,value,a(left,v)))
  201.       in a (d, init) end
  202.  
  203.     fun map f d = let
  204.       fun a E = E
  205.         | a (T{key,value,left,right,cnt}) = let
  206.             val left' = a left
  207.             val value' = f(key,value)
  208.             in
  209.               T{cnt=cnt, key=key,value=value',left = left', right = a right}
  210.             end
  211.       in a d end
  212.  
  213.     fun transform f d = let
  214.       fun a E = E
  215.         | a (T{key,value,left,right,cnt}) = let
  216.             val left' = a left
  217.             val value' = f value
  218.             in
  219.               T{cnt=cnt, key=key,value=value',left = left', right = a right}
  220.             end
  221.       in a d end
  222.  
  223. end
  224.   end
  225.