Mercurial > hg > xemacs-beta

comparison lisp/oobr/hasht.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hasht.el
4 ;; SUMMARY: Create hash tables from lists and operate on them.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: extensions, tools
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 16-Mar-90 at 03:38:48
12 ;; LAST-MOD: 27-Sep-95 at 21:31:20 by Bob Weiner
13 ;;
14 ;; Copyright (C) 1990-1995 Free Software Foundation, Inc.
15 ;; See the file BR-COPY for license information.
16 ;;
17 ;; This file is part of the OO-Browser.
18 ;;
19 ;; DESCRIPTION:
20 ;;
21 ;; Featureful set of hash table operators for use in personal programs.
22 ;;
23 ;; 'hash-make' creates a hash table from an association list, 'hash-add'
24 ;; adds a value-key pair to a hash table, and 'hash-lookup' finds the value
25 ;; associated with a given key in a hash table, if any.
26 ;;
27 ;; 'hash-map' does the same thing as 'mapcar' but operates on hash tables
28 ;; instead.
29 ;;
30 ;; For a list of 300 items, these hash tables improve lookup times by a
31 ;; factor of between 8 and 10 to 1 over those for an unsorted list.
32 ;;
33 ;; Public and private function names are alphabetized for easy location.
34 ;;
35 ;; DESCRIP-END.
36
37 ;;; ************************************************************************
38 ;;; Public variables
39 ;;; ************************************************************************
40
41 (defvar hash-merge-values-function 'hash-merge-values
42 "*Function to call in hash-merge to merge the values from 2 hash tables that contain the same key.
43 It is sent the two values as arguments.")
44
45 ;;; ************************************************************************
46 ;;; Public functions
47 ;;; ************************************************************************
48
49 (defun hash-add (value key hash-table)
50 "Add VALUE, any lisp object, referenced by KEY, a string, to HASH-TABLE.
51 Replaces any VALUE previously referenced by KEY."
52 (if (hashp hash-table)
53 (let* ((obarray (hash-obarray hash-table))
54 (sym (intern key obarray)))
55 (if sym (set sym value)))))
56
57 (defun hash-copy (hash-table)
58 "Return a copy of HASH-TABLE, list and vector elements are shared across both tables."
59 (if (not (hashp hash-table))
60 (error "(hash-copy): Invalid hash-table: '%s'" hash-table))
61 (let ((htable-copy (hash-make (length (hash-obarray hash-table)))))
62 (hash-map
63 (function (lambda (elt) (hash-add (car elt) (cdr elt) htable-copy)))
64 hash-table)
65 htable-copy))
66
67 (defun hash-count (hash-table)
68 "Return number of elements stored in HASH-TABLE or nil if not a valid hash table."
69 (if (hashp hash-table)
70 (let ((obarray (hash-obarray hash-table))
71 (count 0))
72 (mapatoms (function
73 (lambda (sym)
74 (and (boundp sym) sym (setq count (1+ count)))))
75 obarray)
76 count)))
77
78 (defun hash-delete (key hash-table)
79 "Delete element referenced by KEY, a string, from HASH-TABLE.
80 Return nil if KEY is not in HASH-TABLE or non-nil otherwise."
81 (if (hashp hash-table)
82 (let* ((obarray (hash-obarray hash-table))
83 (sym (intern-soft key obarray)))
84 (and sym (boundp sym) (makunbound sym)))))
85
86 (defun hash-deep-copy (obj)
87 "Return a copy of OBJ with new copies of all elements, except symbols."
88 (cond ((null obj) nil)
89 ((stringp obj)
90 (copy-sequence obj))
91 ((hashp obj)
92 (let ((htable-copy (hash-make (length (hash-obarray obj)))))
93 (mapcar
94 (function
95 (lambda (elt) (hash-add (car elt) (cdr elt) htable-copy)))
96 (hash-map 'hash-deep-copy obj))
97 htable-copy))
98 ((vectorp obj)
99 ;; convert to list for mapping
100 (setq obj (append obj nil))
101 ;; Return as a vector
102 (vconcat (mapcar 'hash-deep-copy obj)))
103 ((atom obj) obj)
104 ((nlistp obj)
105 (error "(hash-deep-copy): Invalid type, '%s'" obj))
106 (t ;; list
107 (cons (hash-deep-copy (car obj)) (hash-deep-copy (cdr obj))))))
108
109 (fset 'hash-get 'hash-lookup)
110 (defun hash-key-p (key hash-table)
111 "Return non-nil iff KEY is in HASH-TABLE. KEY's hash table symbol is returned."
112 (if (hashp hash-table)
113 (let* ((obarray (hash-obarray hash-table))
114 (sym (intern-soft key obarray)))
115 (if (boundp sym) sym))))
116
117 (defun hash-lookup (key hash-table)
118 "Lookup KEY in HASH-TABLE and return associated value.
119 If value is nil, this function does not tell you whether or not KEY is in the
120 hash table. Use 'hash-key-p' instead for that function."
121 (if (hashp hash-table)
122 (let* ((obarray (hash-obarray hash-table))
123 (sym (intern-soft key obarray)))
124 (if (boundp sym) (symbol-value sym)))))
125
126 (defun hash-make (initializer &optional reverse)
127 "Create a hash table from INITIALIZER.
128 INITIALIZER may be an alist with elements of the form (<value> . <key>) from
129 which the hash table is built. Alternatively, it may be a non-negative
130 integer which is used as the minimum size of a new, empty hash table.
131 Optional non-nil second argument REVERSE means INITIALIZER has elements of
132 form (<key> . <value>)."
133 (if (integerp initializer)
134 (if (>= initializer 0)
135 (cons 'hasht (make-vector (hash-next-prime initializer) 0))
136 (error "(hash-make): Initializer must be >= 0, not '%s'"
137 initializer))
138 (let* ((vlen (hash-next-prime (length initializer)))
139 (obarray (make-vector vlen 0))
140 sym)
141 (mapcar
142 (function
143 (lambda (cns)
144 (let ((key) (value))
145 (if (consp cns)
146 (if reverse
147 (setq key (car cns) value (cdr cns))
148 (setq key (cdr cns) value (car cns))))
149 (if (setq sym (intern key))
150 (set sym value)))))
151 initializer)
152 (cons 'hasht obarray))))
153
154 (defun hash-map (func hash-table)
155 "Return result of application of FUNC to each (<value> . <key>) element of HASH-TABLE."
156 (if (not (hashp hash-table))
157 (error "(hash-map): Invalid hash-table: '%s'" hash-table))
158 (let ((result))
159 (mapatoms (function
160 (lambda (sym)
161 (and (boundp sym)
162 sym
163 (setq result (cons (funcall
164 func
165 (cons (symbol-value sym)
166 (symbol-name sym)))
167 result)))))
168 (hash-obarray hash-table))
169 result))
170
171 (defun hash-merge (&rest hash-tables)
172 "Merge any number of HASH-TABLES. Return resultant hash table.
173 A single argument consisting of a list of hash tables may also be given.
174 Return an empty hash table if any argument from the merge list is other
175 than nil or a hash table."
176 (let ((empty-ht (hash-make 1)))
177 (and (not (hashp (car hash-tables)))
178 (listp (car hash-tables))
179 ;; Handle situation where a list of hash-tables is passed in as a
180 ;; single argument, rather than as multiple arguments.
181 (setq hash-tables (car hash-tables)))
182 (if (memq nil (mapcar (function (lambda (ht) (or (null ht) (hashp ht))))
183 hash-tables))
184 empty-ht
185 (setq hash-tables
186 (delq nil (mapcar (function (lambda (ht)
187 (if (equal ht empty-ht)
188 nil ht)))
189 hash-tables)))
190 (let ((len (length hash-tables)))
191 (cond ((= len 0) empty-ht)
192 ((= len 1) (car hash-tables))
193 (t (let ((htable (hash-make
194 (apply '+ (mapcar 'hash-count hash-tables))))
195 key value)
196 (mapcar
197 (function
198 (lambda (ht)
199 (hash-map (function
200 (lambda (val-key-cons)
201 (setq value (car val-key-cons)
202 key (cdr val-key-cons))
203 (if (not (hash-key-p key htable))
204 (hash-add value key htable)
205 ;; Merge values
206 (hash-add
207 (funcall hash-merge-values-function
208 (hash-get key htable)
209 value)
210 key htable))))
211 ht)))
212 hash-tables)
213 htable)))))))
214
215 (defun hash-merge-values (value1 value2)
216 "Return a list from merging VALUE1 and VALUE2 or creating a new list.
217 Nil values are thrown away. If both arguments are lists, their elements are
218 assumed to be strings and the result is a set of ordered strings."
219 (cond ((and (listp value1) (listp value2))
220 ;; Assume desired result is a set of strings.
221 (br-set-of-strings (sort (append value1 value2) 'string<)))
222 ((null value1)
223 value2)
224 ((null value2)
225 value1)
226 ((listp value1)
227 (cons value2 value1))
228 ((listp value2)
229 (cons value1 value2))
230 (t (list value1 value2))))
231
232 (make-obsolete 'hash-new 'hash-make)
233 (defun hash-new (size)
234 "Return a new hash table of SIZE elements.
235 This is obsolete. Use 'hash-make' instead."
236 (hash-make size))
237
238 (defun hash-prin1 (hash-table &optional stream)
239 "Output the printed representation of HASH-TABLE.
240 Quoting characters are printed when needed to make output that `read'
241 can handle, whenever this is possible.
242 Output stream is STREAM, or value of `standard-output'."
243 (if (not (hashp hash-table))
244 (progn (prin1 hash-table stream)
245 (princ "\n" stream))
246 (princ "\(\n" stream)
247 (hash-map
248 (function (lambda (val-key-cons)
249 (prin1 val-key-cons stream)
250 (princ "\n" stream)))
251 hash-table)
252 (princ "\)\n" stream)))
253
254 (defun hash-replace (value key hash-table)
255 "Replace VALUE referenced by KEY, a string, in HASH-TABLE.
256 An error will occur if KEY is not found in HASH-TABLE."
257 (if (hashp hash-table)
258 (let* ((obarray (hash-obarray hash-table))
259 (sym (intern-soft key obarray)))
260 (if (and (boundp sym) sym)
261 (set sym value)
262 (error "(hash-replace): '%s' key not found in hash table." key)))))
263
264 (defun hash-resize (hash-table new-size)
265 "Resize HASH-TABLE to NEW-SIZE without losing any elements and return new table.
266 NEW-SIZE must be greater than 0. Hashing works best if NEW-SIZE is a prime
267 number. See also 'hash-next-prime'."
268 (if (< new-size 1)
269 (error "(hash-resize): Cannot resize hash table to size %d" new-size))
270 (let ((htable (hash-make new-size)))
271 (hash-map (function
272 (lambda (elt)
273 (hash-add (car elt) (cdr elt) htable)))
274 hash-table)
275 htable))
276
277 (defun hash-resize-p (hash-table)
278 "Resizes HASH-TABLE to 1.5 times its size if above 80% full.
279 Returns new hash table when resized, else nil."
280 (if (hashp hash-table)
281 (let ((count (hash-count hash-table))
282 (size (length (hash-obarray hash-table))))
283 (if (> (* count (/ count 5)) size)
284 (hash-resize hash-table (hash-next-prime (+ size (/ size 2))))))))
285
286 (defun hash-size (hash-table)
287 "Return size of HASH-TABLE which is >= number of elements in the table.
288 Return nil if not a valid hash table."
289 (if (hashp hash-table)
290 (length (hash-obarray hash-table))))
291 (fset 'hash-length 'hash-size)
292
293 (defun hashp (object)
294 "Return non-nil if OBJECT is a hash-table."
295 (and (listp object) (eq (car object) 'hasht)
296 (vectorp (cdr object))))
297
298 ;;; ************************************************************************
299 ;;; Private functions
300 ;;; ************************************************************************
301
302 (defun hash-next-prime (n)
303 "Return next prime number >= N."
304 (if (<= n 2)
305 2
306 (and (= (% n 2) 0) (setq n (1+ n)))
307 (while (not (hash-prime-p n))
308 (setq n (+ n 2)))
309 n))
310
311 (defun hash-obarray (hash-table)
312 "Return symbol table (object array) portion of HASH-TABLE."
313 (cdr hash-table))
314
315 (defun hash-prime-p (n)
316 "Return non-nil iff N is prime."
317 (if (< n 0) (setq n (- n)))
318 (let ((small-primes '(1 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67
319 71 73 79 83 89)))
320 (cond ((< n 91) (memq n small-primes))
321 ((< n 7921) ;; 89, max small-prime, squared
322 (let ((prime t)
323 (pr-list small-primes))
324 (while (and (setq pr-list (cdr pr-list))
325 (setq prime (/= (% n (car pr-list)) 0))))
326 prime))
327 ((or (= (% n 3) 0) (= (% n 2) 0)) nil)
328 ((let ((factor1 5)
329 (factor2 7)
330 (is-prime))
331 (while (and (<= (* factor1 factor1) n)
332 (setq is-prime (and (/= (% n factor1) 0)
333 (/= (% n factor2) 0))))
334 (setq factor1 (+ factor1 6)
335 factor2 (+ factor2 6)))
336 is-prime)))))
337
338 (provide 'hasht)