# HG changeset patch # User Chris Cannam # Date 1645009284 0 # Wed Feb 16 11:01:24 2022 +0000 # Node ID 4af7b3dd9d46ac6e2b2f71391fe84d86a4aaabaa # Parent 7746b5e77368f2edc76c7726e954eb0b2711291f Updated versions of containers from more recent upstream diff --git a/hash-key-sig.sml b/hash-key-sig.sml --- a/hash-key-sig.sml +++ b/hash-key-sig.sml @@ -1,14 +1,14 @@ (* hash-key-sig.sml * - * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * Abstract hash table keys. This is the argument signature for the hash table * functor (see hash-table-sig.sml and hash-table.sml). * * AUTHOR: John Reppy - * AT&T Bell Laboratories - * Murray Hill, NJ 07974 - * jhr@research.att.com + * University of Chicago + * https://cs.uchicago.edu/~jhr *) signature HASH_KEY = diff --git a/hash-table-fn.sml b/hash-table-fn.sml --- a/hash-table-fn.sml +++ b/hash-table-fn.sml @@ -1,14 +1,14 @@ (* hash-table-fn.sml * - * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. + * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * A hash table functor. It takes a key type with two operations: sameKey and * hashVal as arguments (see hash-key-sig.sml). * * AUTHOR: John Reppy - * AT&T Bell Laboratories - * Murray Hill, NJ 07974 - * jhr@research.att.com + * University of Chicago + * https://cs.uchicago.edu/~jhr *) functor HashTableFn (Key : HASH_KEY) : MONO_HASH_TABLE = @@ -71,7 +71,7 @@ val hash = hashVal key val indx = index (hash, Array.length arr) fun look HTRep.NIL = false - | look (HTRep.B(h, k, v, r)) = + | look (HTRep.B(h, k, v, r)) = ((hash = h) andalso sameKey(key, k)) orelse look r in look (Array.sub (arr, indx)) @@ -161,7 +161,7 @@ *) fun filteri pred (HT{table, n_items, ...}) = n_items := HTRep.filteri pred (! table) - fun filter pred (HT{table, n_items, ...}) = + fun filter pred (HT{table, n_items, ...}) = n_items := HTRep.filter pred (! table) (* Create a copy of a hash table *) diff --git a/hash-table-rep.sml b/hash-table-rep.sml --- a/hash-table-rep.sml +++ b/hash-table-rep.sml @@ -1,16 +1,15 @@ (* hash-table-rep.sml * - * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. - * COPYRIGHT (c) 1996 AT&T Research. + * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * This is the internal representation of hash tables, along with some * utility functions. It is used in both the polymorphic and functor * hash table implementations. * * AUTHOR: John Reppy - * AT&T Bell Laboratories - * Murray Hill, NJ 07974 - * jhr@research.att.com + * University of Chicago + * https://cs.uchicago.edu/~jhr *) structure HashTableRep : sig @@ -67,13 +66,29 @@ fun index (i, sz) = Word.toIntX(Word.andb(i, Word.fromInt sz - 0w1)) - (* find smallest power of 2 (<= 32) that is >= n *) - fun roundUp n = let - fun f i = if (i >= n) then i else f(i * 2) + (* minimum and maximum hash table sizes. We use powers of two for hash table + * sizes, since that give efficient indexing, and assume a minimum size of 32. + *) + val minSize = 32 + val maxSize = let + fun f i = let + val i' = i+i + in + if i' < Array.maxLen then f i' else i + end handle Overflow => i in - f 32 + f 0x10000 end + (* round up `n` to the next hash-table size *) + fun roundUp n = if (n >= maxSize) + then maxSize + else let + fun f i = if (i >= n) then i else f(i + i) + in + f minSize + end + (* Create a new table; the int is a size hint and the exception * is to be raised by find. *) diff --git a/int-hash-table.sml b/int-hash-table.sml --- a/int-hash-table.sml +++ b/int-hash-table.sml @@ -1,13 +1,13 @@ (* int-hash-table.sml * - * COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies. + * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * A specialization of the hash table functor to integer keys. * * AUTHOR: John Reppy - * Bell Labs - * Murray Hill, NJ 07974 - * jhr@research.bell-labs.com + * University of Chicago + * https://cs.uchicago.edu/~jhr *) structure IntHashTable :> MONO_HASH_TABLE where type Key.hash_key = int = @@ -76,7 +76,7 @@ val hash = hashVal key val indx = index (hash, Array.length arr) fun look HTRep.NIL = false - | look (HTRep.B(h, k, v, r)) = + | look (HTRep.B(h, k, v, r)) = ((hash = h) andalso sameKey(key, k)) orelse look r in look (Array.sub (arr, indx)) @@ -166,7 +166,7 @@ *) fun filteri pred (HT{table, n_items, ...}) = n_items := HTRep.filteri pred (! table) - fun filter pred (HT{table, n_items, ...}) = + fun filter pred (HT{table, n_items, ...}) = n_items := HTRep.filter pred (! table) (* Create a copy of a hash table *) diff --git a/int-redblack-map.sml b/int-redblack-map.sml --- a/int-redblack-map.sml +++ b/int-redblack-map.sml @@ -84,13 +84,57 @@ (* end case *)) | _ => T(B, a, yk, y, ins b) (* end case *)) - in - case ins m - of E => raise Fail "cannot be empty here" - | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) - end + in + case ins m of + E => raise Fail "cannot be empty here" + | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) + end fun insert' ((xk, x), m) = insert (m, xk, x) + fun insertWithi comb (MAP(nItems, m), xk, x) = let + val nItems' = ref nItems + fun ins E = (nItems' := nItems+1; T(R, E, xk, x, E)) + | ins (s as T(color, a, yk, y, b)) = + if (xk < yk) + then (case a + of T(R, c, zk, z, d) => + if (xk < zk) + then (case ins c + of T(R, e, wk, w, f) => T(R, T(B,e,wk,w,f), zk, z, T(B,d,yk,y,b)) + | c => T(B, T(R,c,zk,z,d), yk, y, b) + (* end case *)) + else if (xk = zk) + then T(color, T(R, c, xk, comb(xk, z, x), d), yk, y, b) + else (case ins d + of T(R, e, wk, w, f) => T(R, T(B,c,zk,z,e), wk, w, T(B,f,yk,y,b)) + | d => T(B, T(R,c,zk,z,d), yk, y, b) + (* end case *)) + | _ => T(B, ins a, yk, y, b) + (* end case *)) + else if (xk = yk) + then T(color, a, xk, comb(xk, y, x), b) + else (case b + of T(R, c, zk, z, d) => + if (xk < zk) + then (case ins c + of T(R, e, wk, w, f) => T(R, T(B,a,yk,y,e), wk, w, T(B,f,zk,z,d)) + | c => T(B, a, yk, y, T(R,c,zk,z,d)) + (* end case *)) + else if (xk = zk) + then T(color, a, yk, y, T(R, c, xk, comb(xk, z, x), d)) + else (case ins d + of T(R, e, wk, w, f) => T(R, T(B,a,yk,y,c), zk, z, T(B,e,wk,w,f)) + | d => T(B, a, yk, y, T(R,c,zk,z,d)) + (* end case *)) + | _ => T(B, a, yk, y, ins b) + (* end case *)) + in + case ins m of + E => raise Fail "cannot be empty here" + | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) + end + fun insertWith comb = insertWithi (fn (_, x1, x2) => comb(x1, x2)) + (* Is a key in the domain of the map? *) fun inDomain (MAP(_, t), k) = let fun find' E = false @@ -225,7 +269,7 @@ * left child recolored to black. *) (y, zip(p, T(B, a', yk', y', b'))) - | (_, E, T(_, a', yk', y', b')) => + | (_, E, T(_, a', yk', y', b')) => (* node is black and right child is red; we replace the node with its * right child recolored to black. *) diff --git a/lib-base-sig.sml b/lib-base-sig.sml --- a/lib-base-sig.sml +++ b/lib-base-sig.sml @@ -1,6 +1,7 @@ (* lib-base-sig.sml * - * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. *) signature LIB_BASE = @@ -18,4 +19,3 @@ (* raise the exception Fail with a standard format message. *) end (* LIB_BASE *) - diff --git a/lib-base.sml b/lib-base.sml --- a/lib-base.sml +++ b/lib-base.sml @@ -1,6 +1,7 @@ (* lib-base.sml * - * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. *) structure LibBase : LIB_BASE = @@ -20,4 +21,3 @@ raise (Fail(concat[module, ".", func, ": ", msg])) end (* LibBase *) - diff --git a/listsort-sig.sml b/listsort-sig.sml --- a/listsort-sig.sml +++ b/listsort-sig.sml @@ -1,6 +1,7 @@ (* listsort-sig.sml * - * COPYRIGHT (c) 1989 by AT&T Bell Laboratories + * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * The generic list sorting interface. Taken from the SML/NJ compiler. *) @@ -8,17 +9,17 @@ signature LIST_SORT = sig - val sort : ('a * 'a -> bool) -> 'a list -> 'a list + val sort : ('a * 'a -> bool) -> 'a list -> 'a list (* (sort gt l) sorts the list l in ascending order using the * ``greater-than'' relationship defined by gt. *) val uniqueSort : ('a * 'a -> order) -> 'a list -> 'a list - (* uniquesort produces an increasing list, removing equal + (* uniquesort produces an increasing list, removing equal * elements *) - val sorted : ('a * 'a -> bool) -> 'a list -> bool + val sorted : ('a * 'a -> bool) -> 'a list -> bool (* (sorted gt l) returns true if the list is sorted in ascending * order under the ``greater-than'' predicate gt. *) diff --git a/mono-hash-table-sig.sml b/mono-hash-table-sig.sml --- a/mono-hash-table-sig.sml +++ b/mono-hash-table-sig.sml @@ -1,13 +1,13 @@ (* mono-hash-table-sig.sml * - * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. + * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * The result signature of the hash table functor (see hash-table.sml). * * AUTHOR: John Reppy - * AT&T Bell Laboratories - * Murray Hill, NJ 07974 - * jhr@research.att.com + * University of Chicago + * https://cs.uchicago.edu/~jhr *) signature MONO_HASH_TABLE = diff --git a/ord-key-sig.sml b/ord-key-sig.sml --- a/ord-key-sig.sml +++ b/ord-key-sig.sml @@ -1,15 +1,18 @@ (* ord-key-sig.sml * - * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. * * Abstract linearly ordered keys. - * *) signature ORD_KEY = sig + + (* the type of keys *) type ord_key + (* defines a total ordering on the ord_key type *) val compare : ord_key * ord_key -> order end (* ORD_KEY *) diff --git a/ord-map-sig.sml b/ord-map-sig.sml --- a/ord-map-sig.sml +++ b/ord-map-sig.sml @@ -1,6 +1,6 @@ (* ord-map-sig.sml * - * COPYRIGHT (c) 2012 The Fellowship of SML/NJ (http://www.smlnj.org) + * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org) * All rights reserved. * * COPYRIGHT (c) 1996 by AT&T Research. See COPYRIGHT file for details. @@ -13,6 +13,7 @@ sig structure Key : ORD_KEY + (* the map's domain and its comparison function *) type 'a map @@ -29,6 +30,16 @@ val insert' : ((Key.ord_key * 'a) * 'a map) -> 'a map (* Insert an item. *) + val insertWith : ('a * 'a -> 'a) -> 'a map * Key.ord_key * 'a -> 'a map + (* Insert an item with a combining function to resolve collisions. + * The first argument to the combining function is the existing value, + * and the second argument is the value being inserted into the map. + *) + val insertWithi : (Key.ord_key * 'a * 'a -> 'a) -> 'a map * Key.ord_key * 'a -> 'a map + (* Like insertWith, except that the combining function also takes the + * key as an argument. + *) + val find : 'a map * Key.ord_key -> 'a option (* Look for an item, return NONE if the item doesn't exist *) diff --git a/ord-set-sig.sml b/ord-set-sig.sml --- a/ord-set-sig.sml +++ b/ord-set-sig.sml @@ -9,6 +9,7 @@ sig structure Key : ORD_KEY + (* the set elements and their comparison function *) type item = Key.ord_key type set @@ -22,6 +23,11 @@ val fromList : item list -> set (* create a set from a list of items *) + val toList : set -> item list + (* Return an ordered list of the items in the set. + * Added in SML/NJ 110.80. + *) + val add : set * item -> set val add' : (item * set) -> set (* Add an item. *) @@ -45,6 +51,16 @@ val isEmpty : set -> bool (* Return true if and only if the set is empty *) + val minItem : set -> item + (* return the smallest element of the set (raises Empty if the set is empty). + * Added in SML/NJ 110.80. + *) + + val maxItem : set -> item + (* return the largest element of the set (raises Empty if the set is empty). + * Added in SML/NJ 110.80. + *) + val equal : (set * set) -> bool (* Return true if and only if the two sets are equal *) @@ -54,12 +70,12 @@ val isSubset : (set * set) -> bool (* Return true if and only if the first set is a subset of the second *) + val disjoint : set * set -> bool + (* are the two sets disjoint? *) + val numItems : set -> int (* Return the number of items in the table *) - val listItems : set -> item list - (* Return an ordered list of the items in the set *) - val union : set * set -> set (* Union *) @@ -73,25 +89,38 @@ (* Create a new set by applying a map function to the elements * of the set. *) - + + val mapPartial : (item -> item option) -> set -> set + (* Create a new set by mapping a partial function over the + * items in the set. + *) + val app : (item -> unit) -> set -> unit - (* Apply a function to the entries of the set + (* Apply a function to the entries of the set * in increasing order *) val foldl : (item * 'b -> 'b) -> 'b -> set -> 'b - (* Apply a folding function to the entries of the set + (* Apply a folding function to the entries of the set * in increasing order *) val foldr : (item * 'b -> 'b) -> 'b -> set -> 'b - (* Apply a folding function to the entries of the set + (* Apply a folding function to the entries of the set * in decreasing order *) val partition : (item -> bool) -> set -> (set * set) + (* partition a set into two based using the given predicate. Returns two + * sets, where the first contains those elements for which the predicate is + * true and the second contains those elements for which the predicate is + * false. + *) val filter : (item -> bool) -> set -> set + (* filter a set by the given predicate returning only those elements for + * which the predicate is true. + *) val exists : (item -> bool) -> set -> bool (* check the elements of a set with a predicate and return true if @@ -106,5 +135,9 @@ *) val find : (item -> bool) -> set -> item option + (* find an element in the set for which the predicate is true *) + + (* DEPRECATED FUNCTIONS *) + val listItems : set -> item list end (* ORD_SET *) diff --git a/redblack-map-fn.sml b/redblack-map-fn.sml --- a/redblack-map-fn.sml +++ b/redblack-map-fn.sml @@ -3,8 +3,6 @@ * COPYRIGHT (c) 2014 The Fellowship of SML/NJ (http://www.smlnj.org) * All rights reserved. * - * COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies. - * * This code is based on Chris Okasaki's implementation of * red-black trees. The linear-time tree construction code is * based on the paper "Constructing red-black trees" by Hinze, @@ -81,13 +79,66 @@ | _ => T(B, a, yk, y, ins b) (* end case *)) (* end case *)) - in - case ins m - of E => raise Fail "cannot be empty here" - | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) - end + in + case ins m of + E => raise Fail "cannot be empty here" + | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) + end fun insert' ((xk, x), m) = insert (m, xk, x) + fun insertWithi comb (MAP(nItems, m), xk, x) = let + val nItems' = ref nItems + fun ins E = (nItems' := nItems+1; T(R, E, xk, x, E)) + | ins (s as T(color, a, yk, y, b)) = (case K.compare(xk, yk) + of LESS => (case a + of T(R, c, zk, z, d) => (case K.compare(xk, zk) + of LESS => (case ins c + of T(R, e, wk, w, f) => + T(R, T(B,e,wk, w,f), zk, z, T(B,d,yk,y,b)) + | c => T(B, T(R,c,zk,z,d), yk, y, b) + (* end case *)) + | EQUAL => let + val x' = comb(xk, z, x) + in + T(color, T(R, c, xk, x', d), yk, y, b) + end + | GREATER => (case ins d + of T(R, e, wk, w, f) => + T(R, T(B,c,zk,z,e), wk, w, T(B,f,yk,y,b)) + | d => T(B, T(R,c,zk,z,d), yk, y, b) + (* end case *)) + (* end case *)) + | _ => T(B, ins a, yk, y, b) + (* end case *)) + | EQUAL => T(color, a, xk, comb(xk, y, x), b) + | GREATER => (case b + of T(R, c, zk, z, d) => (case K.compare(xk, zk) + of LESS => (case ins c + of T(R, e, wk, w, f) => + T(R, T(B,a,yk,y,e), wk, w, T(B,f,zk,z,d)) + | c => T(B, a, yk, y, T(R,c,zk,z,d)) + (* end case *)) + | EQUAL => let + val x' = comb(xk, z, x) + in + T(color, a, yk, y, T(R, c, xk, x', d)) + end + | GREATER => (case ins d + of T(R, e, wk, w, f) => + T(R, T(B,a,yk,y,c), zk, z, T(B,e,wk,w,f)) + | d => T(B, a, yk, y, T(R,c,zk,z,d)) + (* end case *)) + (* end case *)) + | _ => T(B, a, yk, y, ins b) + (* end case *)) + (* end case *)) + in + case ins m of + E => raise Fail "cannot be empty here" + | T(_, a, yk, y, b) => MAP(!nItems', T(B, a, yk, y, b)) + end + fun insertWith comb = insertWithi (fn (_, x1, x2) => comb(x1, x2)) + (* Is a key in the domain of the map? *) fun inDomain (MAP(_, t), k) = let fun find' E = false @@ -221,7 +272,7 @@ * left child recolored to black. *) (y, zip(p, T(B, a', yk', y', b'))) - | (_, E, T(_, a', yk', y', b')) => + | (_, E, T(_, a', yk', y', b')) => (* node is black and right child is red; we replace the node with its * right child recolored to black. *) diff --git a/redblack-set-fn.sml b/redblack-set-fn.sml --- a/redblack-set-fn.sml +++ b/redblack-set-fn.sml @@ -3,8 +3,6 @@ * COPYRIGHT (c) 2014 The Fellowship of SML/NJ (http://www.smlnj.org) * All rights reserved. * - * COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies. - * * This code is based on Chris Okasaki's implementation of * red-black trees. The linear-time tree construction code is * based on the paper "Constructing red-black trees" by Hinze, @@ -43,6 +41,22 @@ val empty = SET(0, E) + fun minItem (SET(_, tr)) = let + fun min E = raise Empty + | min (T(_, E, item, _)) = item + | min (T(_, tr, _, _)) = min tr + in + min tr + end + + fun maxItem (SET(_, tr)) = let + fun max E = raise Empty + | max (T(_, _, item, E)) = item + | max (T(_, _, _, tr)) = max tr + in + max tr + end + fun singleton x = SET(1, T(B, E, x, E)) fun add (SET(nItems, m), x) = let @@ -79,11 +93,11 @@ | _ => T(B, a, y, ins b) (* end case *)) (* end case *)) - in - case ins m - of E => raise Fail "cannot be empty here" - | T(_, a, y, b) => SET(!nItems', T(B, a, y, b)) - end + in + case ins m + of E => raise Fail "cannot be empty here" + | T(_, a, y, b) => SET(!nItems', T(B, a, y, b)) + end fun add' (x, m) = add (m, x) fun addList (s, []) = s @@ -97,7 +111,7 @@ | RIGHT of (color * tree * item * zipper) in fun delete (SET(nItems, t), k) = let - (* zip the zipper *) + (* zip the zipper *) fun zip (TOP, t) = t | zip (LEFT(color, x, b, p), a) = zip(p, T(color, a, x, b)) | zip (RIGHT(color, a, x, p), b) = zip(p, T(color, a, x, b)) @@ -184,7 +198,7 @@ * left child recolored to black. *) zip(p, T(B, a', y', b')) - | (_, E, T(_, a', y', b')) => + | (_, E, T(_, a', y', b')) => (* node is black and right child is red; we replace the node with its * right child recolored to black. *) @@ -239,7 +253,7 @@ end (* return an ordered list of the items in the set. *) - fun listItems s = foldr (fn (x, l) => x::l) [] s + fun toList s = foldr (fn (x, l) => x::l) [] s (* functions for walking the tree while keeping a stack of parents * to be visited. @@ -299,6 +313,22 @@ cmp (start s1, start s2) end + (* Return true if the two sets are disjoint *) + fun disjoint (SET(0, _), _) = true + | disjoint (_, SET(0, _)) = true + | disjoint (SET(_, s1), SET(_, s2)) = let + fun walk ((E, _), _) = true + | walk (_, (E, _)) = true + | walk (t1 as (T(_, _, x, _), r1), t2 as (T(_, _, y, _), r2)) = ( + case Key.compare(x, y) + of LESS => walk (next r1, t2) + | EQUAL => false + | GREATER => walk (t1, next r2) + (* end case *)) + in + walk (next (start s1), next (start s2)) + end + (* support for constructing red-black trees in linear time from increasing * ordered sequences (based on a description by R. Hinze). Note that the * elements in the digits are ordered with the largest on the left, whereas @@ -421,6 +451,12 @@ foldl addf empty end + fun mapPartial f = let + fun f' (x, acc) = (case f x of SOME x' => add(acc, x') | NONE => acc) + in + foldl f' empty + end + (* Filter out those elements of the set that do not satisfy the * predicate. The filtering is done in increasing map order. *) @@ -476,4 +512,7 @@ fn (SET(_, t)) => test t end + (* DEPRECATED FUNCTIONS *) + val listItems = toList + end;