lispdoc: implemented the whole URI syntax; updated URIs in all docstrings to be writt...
[com-informatimago:com-informatimago.git] / common-lisp / cesarum / utility.lisp
1 ;;;; -*- mode:lisp; coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:              utility.lisp
4 ;;;;LANGUAGE:          common-lisp
5 ;;;;SYSTEM:            UNIX
6 ;;;;USER-INTERFACE:    UNIX
7 ;;;;DESCRIPTION
8 ;;;;    This package exports some utility & syntactic sugar functions & macros.
9 ;;;;AUTHORS
10 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
11 ;;;;MODIFICATIONS
12 ;;;;    2008-06-24 <PJB> Added INCF-MOD and DECF-MOD.
13 ;;;;    2007-12-01 <PJB> Removed PJB-ATTRIB macro (made it a flet of PJB-DEFCLASS).
14 ;;;;    2007-07-07 <PJB> Added TRACING.
15 ;;;;    2007-03-19 <PJB> Added HASHTABLE and PRINT-HASHTABLE (typo on purpose).
16 ;;;;    2007-02-18 <PJB> Added NSUBSEQ.
17 ;;;;    2005-03-30 <PJB> Added SIGN.
18 ;;;;    2005-03-17 <PJB> Added DEFINE-IF-UNDEFINED
19 ;;;;    2005-03-17 <PJB> Added COMPOSE & COMPOSE-AND-CALL.
20 ;;;;    2005-03-09 <PJB> Added DEFENUM.
21 ;;;;    2004-12-13 <PJB> Removed UNREADABLE-OBJECT (use PRINT-UNREADABLE-OBJECT).
22 ;;;;    2004-10-10 <PJB> Added UNREADABLE-OBJECT class, & reordered definitions.
23 ;;;;    2004-03-31 <PJB> Renamed DEFINE-WITH-STRUCTURE to DEFINE-WITH-OBJECT,
24 ;;;;                     since behavior of WITH-SLOT on structures is undefined.
25 ;;;;    2004-02-27 <PJB> Added DEFINE-WITH-STRUCTURE, FOR, VECTOR-INIT;
26 ;;;;                     removed (REPEAT ...) --> (LOOP ...).
27 ;;;;    2004-01-19 <PJB> Added INCLUDE.
28 ;;;;    2003-10-23 <PJB> Added COMPUTE-CLOSURE.
29 ;;;;    2003-01-08 <PJB> Created.
30 ;;;;BUGS
31 ;;;;LEGAL
32 ;;;;    AGPL3
33 ;;;;    
34 ;;;;    Copyright Pascal J. Bourguignon 2003 - 2012
35 ;;;;    
36 ;;;;    This program is free software: you can redistribute it and/or modify
37 ;;;;    it under the terms of the GNU Affero General Public License as published by
38 ;;;;    the Free Software Foundation, either version 3 of the License, or
39 ;;;;    (at your option) any later version.
40 ;;;;    
41 ;;;;    This program is distributed in the hope that it will be useful,
42 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
43 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
44 ;;;;    GNU Affero General Public License for more details.
45 ;;;;    
46 ;;;;    You should have received a copy of the GNU Affero General Public License
47 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
48 ;;;;****************************************************************************
49
50 (in-package "COMMON-LISP-USER")
51 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
52   (:use "COMMON-LISP"
53         "COM.INFORMATIMAGO.COMMON-LISP.LISP-SEXP.SOURCE-FORM" )
54   (:export
55    ;; 3 - EVALUATION AND COMPILATION
56    "WITH-GENSYMS" "WSIOSBP" "COMPOSE" "COMPOSE-AND-CALL"
57    "DEFINE-IF-UNDEFINED"  "INCLUDE" "FUNCTIONAL-PIPE"
58    "FIRST-ARG" "SECOND-ARG" "THIRD-ARG" "FOURTH-ARG" "FIFTH-ARG"
59    "SIXTH-ARG" "SEVENTH-ARG" "EIGHTH-ARG" "NINTH-ARG" "TENTH-ARG"
60    ;; 4 - TYPES AND CLASSES
61    "DEFENUM" "OP-TYPE-OF"
62    ;; 5 - DATA AND CONTROL FLOW
63    "SAFE-APPLY" "WHILE" "UNTIL" "FOR"
64    ;; 7 - OBJECTS
65    "DEFINE-STRUCTURE-CLASS" "DEFINE-WITH-OBJECT" "PJB-DEFCLASS"
66    ;; 8 - STRUCTURES
67    "DEFINE-WITH-STRUCTURE"
68    ;; 9 - CONDITIONS
69    "HANDLING-ERRORS"
70    ;; 10 - SYMBOLS
71    "MAKE-KEYWORD" "CONC-SYMBOL"
72    ;; 12 - NUMBERS
73    "SIGN"
74    ;; 14 - CONSES
75    "MAXIMIZE" "COMPUTE-CLOSURE" "TOPOLOGICAL-SORT"
76    ;; 15 - ARRAYS
77    "VECTOR-INIT" "UNDISPLACE-ARRAY" "DICHOTOMY-SEARCH"
78    ;; 16 - STRINGS
79    "CONCAT" "SCONC" "SCASE"
80    ;; 17 - SEQUENCES
81    "NSUBSEQ"
82    ;; 18 - HASH-TABLES
83    "HASH-TABLE-KEYS" "HASH-TABLE-VALUES"
84    "HASH-TABLE-ENTRIES" "HASH-TABLE-PATH"
85    "COPY-HASH-TABLE"
86    "HASHTABLE" "PRINT-HASHTABLE" 
87    ;;
88    "DICHOTOMY"
89    "TRACING" "TRACING-LET" "TRACING-LET*" "TRACING-LABELS"
90    ;;
91    "XOR" "EQUIV" "IMPLY" "SET-EQUAL"
92    )
93   (:documentation
94    "
95
96 This package exports some utility & syntactic sugar functions and macros.
97
98
99
100 License:
101
102     AGPL3
103     
104     Copyright Pascal J. Bourguignon 2003 - 2012
105     
106     This program is free software: you can redistribute it and/or modify
107     it under the terms of the GNU Affero General Public License as published by
108     the Free Software Foundation, either version 3 of the License, or
109     (at your option) any later version.
110     
111     This program is distributed in the hope that it will be useful,
112     but WITHOUT ANY WARRANTY; without even the implied warranty of
113     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
114     GNU Affero General Public License for more details.
115     
116     You should have received a copy of the GNU Affero General Public License
117     along with this program.
118     If not, see <http://www.gnu.org/licenses/>
119
120 "))
121 (in-package "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY")
122
123
124
125
126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127 ;; 3 - EVALUATION AND COMPILATION
128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129
130
131 #-:with-debug-gensym
132 (defmacro with-gensyms (syms &body body)
133   "
134 DO:      Replaces given symbols with gensyms. Useful for creating macros.
135 NOTE:    This version by Paul Graham in On Lisp."
136   `(let ,(mapcar (lambda (s) `(,s (gensym ,(string s)))) syms) ,@body))
137
138
139 #+:with-debug-gensym
140 (defpackage "COM.INFORMATIMAGO.GENSYMS" (:use))
141 #+:with-debug-gensym
142 (defmacro with-gensyms (syms &body body)
143   "
144 DO:      Replaces given symbols with gensyms. Useful for creating macros.
145 NOTE:    This version by Paul Graham in On Lisp."
146   `(let ,(mapcar
147           (lambda (s) `(,s (intern (string (gensym ,(string s)))
148                                    "COM.INFORMATIMAGO.GENSYMS"))) syms) ,@body))
149
150
151 (defmacro wsiosbp (&body body)
152   "
153 Like with-standard-io-syntax but with the current package.
154 The *PACKAGE* is kept bound to the current package.
155 "
156   (let ((vpack (gensym)))
157     `(let ((,vpack *package*))
158        (with-standard-io-syntax
159          (let ((*package* ,vpack))
160            ,@body)))))
161
162
163 (defmacro define-argument-selector (name argument-number)
164   (let ((arguments (loop :for i :from 0 :to argument-number :collect (gensym))))
165     `(defun ,name (,@(cdr arguments) &rest ,(car arguments))
166        ,(format nil "RETURN: The ~:R argument." argument-number)
167        (declare (ignore ,@(butlast arguments)))
168        ,(car (last arguments)))))
169 (define-argument-selector first-arg   1)
170 (define-argument-selector second-arg  2)
171 (define-argument-selector third-arg   3)
172 (define-argument-selector fourth-arg  4)
173 (define-argument-selector fifth-arg   5)
174 (define-argument-selector sixth-arg   6)
175 (define-argument-selector seventh-arg 7)
176 (define-argument-selector eighth-arg  8)
177 (define-argument-selector ninth-arg   9)
178 (define-argument-selector tenth-arg   10)
179
180
181 (defun compose-sexp (functions var)
182   (if (null functions)
183       var
184       (list (car functions) (compose-sexp (cdr functions) var))))
185
186
187 (defmacro compose (&rest functions)
188   "
189 RETURN:     The functional composition of the FUNCTIONS.
190 EXAMPLE:    (compose abs sin cos) = (lambda (x) (abs (sin (cos x))))
191 "
192   `(lambda (x) ,(compose-sexp functions 'x)))
193
194
195 (defmacro compose-and-call (&rest functions-and-arg)
196   "
197 DO:         Call the functionnal composition of the functions, on the
198             argument.
199 EXAMPLE:    (compose-and-call abs sin cos 0.234) --> 0.8264353
200 "
201   `(funcall ,((lambda (functions) (list 'lambda '(x) (compose-sexp functions 'x))) 
202               (butlast functions-and-arg))
203             ,(car (last functions-and-arg))))
204
205 ;; (funcall (compose 1+ sin 1-) 0)
206 ;; (compose-and-call 1+ sin 1- 0)
207
208
209
210 (defmacro define-if-undefined (&rest definitions)
211   "Use this to conditionally define functions, variables, or macros that
212   may or may not be pre-defined in this Lisp.  This can be used to provide
213   CLtL2 compatibility for older Lisps.
214   WHO'S THE AUTHOR?"
215   `(progn
216      ,@(mapcar #'(lambda (def)
217                    (let ((name (second def)))
218                      `(unless (or (boundp ',name)
219                                   (fboundp ',name)
220                                   (special-form-p ',name)
221                                   (macro-function ',name))
222                         ,def)))
223                definitions)))
224
225 #||
226 (define-if-undefined
227            
228     (defmacro with-simple-restart (restart &rest body)
229       "Like PROGN, except provides control over restarts if there is an error."
230       (declare (ignore restart))
231       `(progn ,@body))
232
233     (defmacro done-mac () nil)
234   )
235
236 (defmacro uncond-mac () nil)
237
238 ||#
239
240
241 (defun include (path)
242   "
243 NOTE:    Untasty, but sometimes useful.
244 DO:      Read from the file at PATH all the sexps and returns a list of them
245          prefixed with 'progn.
246 USAGE:   #.(include \"source.lisp\")
247 "
248   (cons 'progn
249         (with-open-file (file path :direction :input :if-does-not-exist :error)
250           (do ((result '())
251                (eof (gensym)))
252               ((eq eof (car result)) (nreverse (cdr result)))
253             (push (read file nil eof) result)))))
254
255
256
257 (defmacro functional-pipe (&body forms)
258   "
259 Execute forms in sequence each in a lexical scope where *, ** and *** are bound
260 to the results of the last three previous forms.
261 Return the results of the last form.
262 "
263   (let ((bindings (mapcar (lambda (form) (list (gensym) form)) forms)))
264     `(let* ,(loop
265                for (*** ** * current) on (list* '(nil) '(nil) '(nil) bindings)
266                unless (null current)
267                collect (list (first current)
268                              (subst (first ***) '***
269                                     (subst (first **) '**
270                                            (subst (first *) '* 
271                                                   (second current))))))
272        ,(first (first (last bindings))))))
273
274 ;; (let ((*** nil) (** nil) (* nil))
275 ;;   (let ((*** **) (** *) (* ,form))
276 ;;     ...
277 ;;     *))
278
279
280
281 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
282 ;; 4 - TYPES AND CLASSES
283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
284
285
286 (defmacro defenum (name-and-options &rest constants)
287   "
288 Define an named enumeration type, a set of constants with integer
289 values, and a lable function to produce the name of the constants from
290 the numerical value.
291 "
292   (let ((name (if (consp name-and-options)
293                   (first name-and-options)
294                   name-and-options)))
295     (when (stringp (first constants))
296       (pop constants))
297     `(eval-when (:compile-toplevel :load-toplevel :execute)
298        ;; define a ({NAME}-LABEL value) function.
299        (defun ,(intern (wsiosbp (format nil "~A-LABEL" name))) (value)
300          ,(format nil "Produce the name of the constant having the given VALUE.")
301          (case value
302            ,@(loop
303                 for cname in constants
304                 with val = -1
305                 do (if (consp cname)
306                        (setf val (second cname))
307                        (incf val))
308                 collect `((,val) ',(if (consp cname)
309                                        (first cname)
310                                        cname)))
311            (otherwise (format nil "#<~A:~D>" ',name value))))
312        ;; define the constants.
313        ,@(loop
314             for cname in constants
315             with val = -1
316             do (when (consp cname)
317                  (setf val (1- (second cname)) cname (first cname)))
318             collect `(defconstant ,cname ,(incf val)
319                        ,(format nil "~A enumeration value." name)))
320        ;; define the type.
321        (deftype ,name ()
322          "An enumeration type." ;; TODO: get a docstring from the parameters.
323          '(member ,@(loop
324                        for cname in constants
325                        with val = -1
326                        do (if (consp cname)
327                               (setf val (second cname))
328                               (incf val))
329                        collect val))))))
330
331
332 (defun op-type-of (symbol &optional env)
333   "
334 From: nikodemus@random-state.net
335 Newsgroups: comp.lang.lisp
336 Date: 29 Jul 2004 03:59:50 GMT
337 Message-ID: <ce9snm$4bp8o$1@midnight.cs.hut.fi>
338 "
339   (if (fboundp symbol)
340       (cond ((macro-function symbol env) 
341              'macro)
342             ((special-operator-p symbol) 
343              'special-operator)
344             ((compiled-function-p (symbol-function symbol))
345              'compiled-function)
346             (t
347              'interpreted-function))
348       (error "Symbol ~S is not an operator." symbol)))
349
350
351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352 ;; 5 - DATA AND CONTROL FLOW
353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
354
355
356 (defun safe-apply (fun &rest args)
357   "
358 DO:    Call APPLY or REDUCE depending on the length of ARGS.
359 NOTE:  No prefix argument are allowed for REDUCE!
360        (safe-apply 'concatenate 'string list-of-sequence) doesn't work!
361        Use instead:
362        (safe-apply (lambda (a b) (concatenate 'string a b)) list-of-sequence)
363 "
364   (let ((arg-list (car (last args))))
365     (if (< (+ (length args) (length arg-list)) call-arguments-limit)
366       (apply  fun (nconc (butlast args) arg-list))
367       (reduce fun (nconc (butlast args) arg-list)))))
368
369
370 (defmacro while (condition &body body)
371   "While loop."
372   `(do () ((not ,condition))  ,@body))
373
374
375
376 (defmacro until (condition &body body)
377   "Until loop."
378   `(do () (,condition)        ,@body))
379
380
381
382 (defmacro for ((var first last . rest) &body body)
383   "For loop.
384 DO:    Repeat BODY with VAR bound to successive integer values from 
385        FIRST to LAST inclusive.
386        If the optional STEP argument is abstent, then it is taken as 1 or -1
387        depending on the order of FIRST and LAST.
388        VAR is incremented by STEP and it stops when VAR goes above
389        or below LAST depending on the sign of STEP.
390 "
391   (let ((firstvar (gensym "FIRST"))
392         (lastvar  (gensym "LAST"))
393         (stepvar  (gensym "STEP"))
394         (step     (and rest (car rest))))
395     (when (cdr rest) (error "Too many forms in FOR parameters."))
396     `(let ((,firstvar ,first)
397            (,lastvar ,last)
398            (,stepvar ,step))
399        (if (if ,stepvar (< 0 ,stepvar) (<= ,firstvar ,lastvar))
400            (progn  (setf ,stepvar (or ,stepvar 1))
401                    (do ((,var ,firstvar (incf ,var ,stepvar)))
402                        ((> ,var ,lastvar))
403                      ,@body))
404            (progn  (setf ,stepvar (or ,stepvar -1))
405                    (do ((,var ,firstvar (incf ,var ,stepvar)))
406                        ((< ,var ,lastvar))
407                      ,@body))))))
408
409
410 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
411 ;; 7 - OBJECTS
412 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
413
414   
415 (defmacro pjb-defclass (name super &rest args)
416   "
417 This macro encapsulate DEFCLASS and allow the declaration of the attributes
418 in a shorter syntax.
419 ARGS  is a list of s-expr, whose car is either :ATT (to declare an attribute)
420       or :DOC to give the documentation string of the class.
421       (:OPT ...) is not implemented yet.
422       (:ATT name type [ init-value [doc-string] | doc-string ]) defines
423       an attribute named NAME, of type TYPE, with the given initial value
424       and documentation strings.  An accessor and an initarg keyword of
425       same NAME are also defined.
426 "
427   (flet ((attrib (name type &rest args)
428            "
429 This function outputs an attribute s-exp as used in defclass.
430 ARGS  may be of length 1 or 2.
431       If (LENGTH ARGS) = 1 
432       then if the argument is a string, 
433            then it's taken as the documentation and the initial value is NIL
434            else it's taken as the initial value and the documentation is NIL.
435       else the first is the initial value and the second is the documentation.
436 The initarg an accessor are the same keyword built from the name.
437 "
438            (let ((iarg (intern (if (symbolp name) (symbol-name name) name)
439                                (find-package "KEYWORD")))
440                  init doc)
441              (cond  ((= 2 (length args))
442                      (setq init (car  args)
443                            doc  (cadr args)) )
444                     ((= 1 (length args))
445                      (if (stringp (car args))
446                        (setq init nil
447                              doc  (car args))
448                        (setq init (car args)
449                              doc  nil)) )
450                     (t (error "Invalid attribute ~S"
451                               `(:att ,name ,type ,@args))))
452              (when (and (symbolp type) (null init))
453                (setf type (list 'or 'null type)))
454              (when (null doc)
455                (setf doc (symbol-name name)))
456              `(,name 
457                :initform ,init 
458                :initarg  ,iarg
459                :accessor ,name
460                :type     ,type
461                :documentation ,doc))))
462     (let ((fields  nil)
463           (options nil))
464       (do () ( (not args) )
465         (cond ((eq :att (caar args))
466                (push (apply (function attrib) (cdar args)) fields))
467               ((eq :doc (caar args))
468                (push (cons :documentation (cdar args)) options)))
469         (setf args (cdr args)))
470       (setf fields (nreverse fields))
471       (setf options (nreverse options))
472       `(defclass ,name ,super ,fields ,@options)))) 
473
474
475
476
477 (defun get-option (key options &optional list)
478   (let ((opt (remove-if (lambda (x) (not (eq key (if (symbolp x) x (car x)))))
479                         options)))
480     (cond
481       (list opt)
482       ((null opt) nil)
483       ((null (cdr opt))
484        (if (symbolp (car opt)) t (cdar opt)))
485       (t (error "Expected only one ~A option."
486                 (if (symbolp (car opt)) (car opt) (caar opt))))))) ;;GET-OPTION
487
488
489 (defun make-name (option prefix name suffix)
490   (cond
491     ((or (null option) (and option (not (listp option))))
492      (intern (with-standard-io-syntax (format nil "~A~A~A" prefix name suffix))))
493     ((and option (listp option) (car option))
494      (car option))
495     (t nil)))
496
497
498 (defun get-name (option)
499   (if (and option (listp option))
500       (car option)
501       nil))
502
503 (declaim (ftype (function ((or string symbol character)) symbol) make-keyword))
504
505 (defmacro define-structure-class (name-and-options &rest doc-and-slots)
506   "
507 DO:     Define a class implementing the structure API.
508         This macro presents the same API as DEFSTRUCT, but instead of
509         defining a structure, it defines a class, and the same functions
510         as would be defined by DEFSTRUCT.
511         The DEFSTRUCT options: :TYPE and :INITIAL-OFFSET are not supported.
512 "
513   (let (name options documentation slots slot-names accessors
514              conc-name constructors copier
515              include initial-offset predicate
516              print-function print-object)
517     (if (symbolp name-and-options)
518         (setf name    name-and-options
519               options nil)
520         (setf name    (car name-and-options)
521               options (cdr name-and-options)))
522     (if (stringp (car doc-and-slots))
523         (setf documentation (car doc-and-slots)
524               slots         (cdr doc-and-slots))
525         (setf documentation nil
526               slots         doc-and-slots))
527     (setf conc-name      (get-option :conc-name      options)
528           constructors   (get-option :constructor    options :list)
529           copier         (get-option :copier         options)
530           predicate      (get-option :predicate      options)
531           include        (get-option :include        options)
532           initial-offset (get-option :initial-offset options)
533           print-function (get-option :print-function options)
534           print-object   (get-option :print-object   options))
535     (when (and print-object print-function)
536       (error "Cannot have :print-object and :print-function options."))
537     (when (cdr include)
538       (setf slots   (append (cddr include) slots)
539             include (list (car include))))
540     (setf conc-name (make-name conc-name ""      name "-")
541           copier    (make-name copier    "COPY-" name "")
542           predicate (make-name predicate ""      name "-P")
543           print-function (get-name print-function)
544           print-object   (get-name print-object))
545     (setf slot-names (mapcar (lambda (s) (if (symbolp s) s (car s))) slots))
546     (setf accessors  (mapcar
547                       (lambda (s) (make-name nil (or conc-name "")
548                                              (if (symbolp s) s (car s)) "")) slots))
549     (if (null constructors)
550         (setf constructors (list (make-name nil "MAKE-" name "")))
551         (setf constructors
552               (mapcan (lambda (x)
553                         (cond
554                           ((or (symbolp x) (= 1 (length x)))
555                            (list (make-name nil "MAKE-" name "")))
556                           ((null (second x))
557                            nil)
558                           ((= 2 (length x))
559                            (list (second x)))
560                           (t
561                            (list (list (second x) (third x)))))) constructors)))
562     `(progn
563        (defclass ,name ,include
564          ,(mapcar
565            (lambda (slot accessor)
566              (if (symbolp slot)
567                  `(,slot :accessor  ,accessor)
568                  (let* ((name        (first slot))
569                         (initform-p  (cdr slot))
570                         (initform    (car initform-p))
571                         (type-p      (member :type (cddr slot)))
572                         (type        (cadr type-p))
573                         (read-only-p (member :read-only (cddr slot)))
574                         (read-only   (cadr read-only-p)))
575                    `(,name
576                      ,(if (and read-only-p read-only) :reader :accessor)
577                      ,accessor
578                      ,@(when initform-p  (list :initform initform))
579                      ,@(when type-p      (list :type     type))))))
580            slots accessors)
581          ,@(when documentation (list `(:documentation ,documentation))))
582        ,@(mapcar
583           (lambda (constructor)
584             ;; generate a constructor.
585             (if (symbolp constructor)
586                 (let ((preds (mapcar (lambda (x) (declare (ignore x)) (gensym))
587                                      slot-names)))
588                   `(defun ,constructor
589                        (&key ,@(mapcar (lambda (s p) (list s nil p)) slot-names preds))
590                      (let ((args nil))
591                        ,@(mapcar
592                           (lambda (s p)
593                             `(when ,p
594                                (push ,s args)
595                                (push ,(make-keyword s) args)))
596                           slot-names preds)
597                        (apply (function make-instance) ',name args))))
598                 (let ((cname  (first  constructor))
599                       (pospar (second constructor)))
600                   (declare (ignore pospar))
601                   (warn "pjb-defclass does not implement this case yet.")
602                   `(defun ,cname (&rest args)
603                      (declare (ignore args))
604                      (error "pjb-defclass does not implement this yet.")))))
605           constructors)
606        ,@(when copier
607                (list `(defmethod ,copier ((self ,name))
608                         (make-instance ',name
609                           ,@(mapcan
610                              (lambda (slot accessor)
611                                (list (make-keyword slot) (list accessor 'self)))
612                              slot-names accessors)))))
613        ,@(when predicate
614                (list `(defmethod ,predicate (object)
615                         (eq (type-of object) ',name))))
616        ,@(when print-function
617                (list `(defmethod print-object ((self ,name) stream)
618                         (,print-function self stream 0))))
619        ,@(when print-object
620                (list `(defmethod print-object ((self ,name) stream)
621                         (,print-object self stream)))))))
622
623
624
625 (defmacro define-with-object (class-name slots)
626   "
627 DO:       Define a macro: (WITH-{CLASS-NAME} object &body body)
628           expanding to:   (with-slots ({slots}) object @body)
629 "
630   `(defmacro
631        ,(intern (with-standard-io-syntax (format nil "WITH-~A" class-name)))
632        (object &body body)
633      `(with-slots (quote ,,(mapcar (lambda (slot) (list slot slot)) slots))
634           ,object ,@body)))
635
636
637
638
639 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
640 ;; 8 - STRUCTURES
641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
642
643
644 ;; (DEFMACRO DEFINE-WITH-STRUCTURE (NAME-AND-OPTIONS SLOTS)
645 ;;   "
646 ;; NAME-AND-OPTIONS:  Either a structure name or a list (name . options).
647 ;;           Valid options are: (:conc-name prefix).
648 ;; DO:       Define a macro: (WITH-{NAME} object &body body)
649 ;;           expanding to a symbol-macrolet embedding body where
650 ;;           symbol macros are defined to access the slots.
651 ;; "
652 ;;   (LET* ((NAME      (IF (SYMBOLP NAME-AND-OPTIONS)
653 ;;                         NAME-AND-OPTIONS (CAR NAME-AND-OPTIONS)))
654 ;;          (CONC-NAME (IF (SYMBOLP NAME-AND-OPTIONS)
655 ;;                         (CONCATENATE 'STRING (STRING NAME) "-")
656 ;;                         (LET ((CONC-OPT (CAR (MEMBER :CONC-NAME
657 ;;                                                      (CDR NAME-AND-OPTIONS)
658 ;;                                                      :KEY (FUNCTION CAR)))))
659 ;;                           (IF CONC-OPT
660 ;;                               (SECOND CONC-OPT)
661 ;;                               (CONCATENATE 'STRING (STRING NAME) "-"))))))
662 ;;     `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
663 ;;        (DEFMACRO
664 ;;            ,(INTERN (WITH-STANDARD-IO-SYNTAX (FORMAT NIL "WITH-~A" NAME)))
665 ;;            (OBJECT &BODY BODY)
666 ;;          (IF (SYMBOLP OBJECT)
667 ;;              `(SYMBOL-MACROLET
668 ;;                   ,(MAPCAR
669 ;;                     (LAMBDA (SLOT)
670 ;;                       (LIST SLOT
671 ;;                             (LIST
672 ;;                              (INTERN (WITH-STANDARD-IO-SYNTAX 
673 ;;                                        (CONCATENATE 'STRING
674 ;;                                          (STRING ',CONC-NAME) (STRING SLOT))))
675 ;;                              OBJECT))) ',SLOTS)
676 ;;                 ,@BODY)
677 ;;              (LET ((OBJV (GENSYM)))
678 ;;                `(LET ((,OBJV ,OBJECT))
679 ;;                   (SYMBOL-MACROLET
680 ;;                       ,(MAPCAR
681 ;;                         (LAMBDA (SLOT)
682 ;;                           (LIST SLOT
683 ;;                                 (LIST
684 ;;                                  (INTERN (WITH-STANDARD-IO-SYNTAX
685 ;;                                            (CONCATENATE 'STRING
686 ;;                                              (STRING ',CONC-NAME) (STRING SLOT))))
687 ;;                                         
688 ;;                                  OBJV))) ',SLOTS)
689 ;;                     ,@BODY)))))))) ;;DEFINE-WITH-STRUCTURE
690
691 (defmacro define-with-structure (name-and-options &rest slots)
692   "
693 NAME-AND-OPTIONS:  Either a structure name or a list (name . options).
694           Valid options are: (:conc-name prefix).
695 DO:       Define a macro: (WITH-{NAME} object &body body)
696           expanding to a symbol-macrolet embedding body where
697           symbol macros are defined to access the slots.
698 "
699   (let* ((name      (if (symbolp name-and-options)
700                       name-and-options (car name-and-options)))
701          (conc-name (if (symbolp name-and-options)
702                       (concatenate 'string (string name) "-")
703                       (let ((conc-opt (car (member :conc-name
704                                                    (cdr name-and-options)
705                                                    :key (function car)))))
706                         (if conc-opt
707                           (second conc-opt)
708                           (concatenate 'string (string name) "-")))))
709          (slot-names (mapcar (lambda (slot) (if (listp slot) (car slot) slot)) 
710                              slots)))
711     `(progn
712        (defstruct ,name-and-options ,@slots)
713        (defmacro
714          ,(intern (with-standard-io-syntax (format nil "WITH-~A" name)))
715          (object &body body)
716          (if (symbolp object)
717            `(symbol-macrolet
718              ,(mapcar
719                (lambda (slot)
720                  (list slot
721                        (list
722                         (intern (concatenate 'string (string ',conc-name) (string slot)))
723                         object))) ',slot-names)
724              ,@body)
725            (let ((objv (gensym)))
726              `(let ((,objv ,object))
727                 (symbol-macrolet
728                  ,(mapcar
729                    (lambda (slot)
730                      (list slot
731                            (list
732                             (intern (concatenate 'string (string ',conc-name) (string slot)))
733                             objv))) ',slot-names)
734                  ,@body))))))))
735
736 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
737 ;; 9 - CONDITIONS
738 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
739
740
741 (defmacro handling-errors (&body body)
742   "
743 DO:       Execute the BODY with a handler for CONDITION and
744           SIMPLE-CONDITION reporting the conditions.
745 "
746   `(handler-case (progn ,@body)
747      (simple-condition  (err) 
748        (format *error-output* "~&~A: ~%" (class-name (class-of err)))
749        (apply (function format) *error-output*
750               (simple-condition-format-control   err)
751               (simple-condition-format-arguments err))
752        (format *error-output* "~&")
753        (finish-output))
754      (condition (err) 
755        (format *error-output* "~&~A: ~%  ~S~%" (class-name (class-of err)) err)
756        (finish-output))))
757
758
759
760 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
761 ;; 10 - SYMBOLS
762 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
763
764 (defun make-keyword (sym)
765   "
766 RETURN: A new keyword with SYM as name.
767 "
768   (intern (string sym) (find-package "KEYWORD")))
769
770
771 (defun conc-symbol (&rest args)
772   "
773 DO:      Concatenate the arguments and INTERN the resulting string.
774 NOTE:    The last two arguments maybe :PACKAGE <a-package>
775          in which case the symbol is interned into the given package
776          instead of *PACKAGE*.
777 "
778   (let ((package *package*))
779     (when (and (<= 2 (length args))
780                (eq :package (car (last args 2))))
781       (setf package (car (last args))
782             args (butlast args 2)))
783     (intern (apply (function concatenate) 'string (mapcar (function string) args))
784             package)))
785
786
787 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
788 ;; 12 - NUMBERS
789 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
790
791 (defun sign (n)
792   "
793 RETURN: -1 if N is negative,
794         +1 if N is positive,
795          0 if N is 0.
796 "
797   (cond ((zerop n) 0) ((plusp n) 1) (t -1)))
798
799
800 (defmacro incf-mod (&environment env place modulo &optional (increment 1))
801   "INCF modulo MODULO"
802   (multiple-value-bind (vars vals store-vars writer-form reader-form)
803       (get-setf-expansion place env)
804     (when (cdr store-vars) (error "Can't expand this."))
805     `(let* (,@(mapcar (function list) vars vals))
806        (let ((,(car store-vars) (mod (+ ,reader-form ,increment) ,modulo)))
807          ,writer-form))))
808
809
810 (defmacro decf-mod (&environment env place modulo &optional (decrement 1))
811   "DECF modulo MODULO"
812   (multiple-value-bind (vars vals store-vars writer-form reader-form)
813       (get-setf-expansion place env)
814     (when (cdr store-vars) (error "Can't expand this."))
815     `(let* (,@(mapcar (function list) vars vals))
816        (let ((,(car store-vars) (mod (- ,reader-form ,decrement) ,modulo)))
817          ,writer-form))))
818
819
820 (defun +epsilon (float)
821   "Returns the float incremented by the smallest increment possible."
822   (multiple-value-bind (significand exponent sign) (decode-float float)
823     (* sign (scale-float
824              (if (minusp sign)
825                  (- significand (etypecase float
826                                   (long-float   long-float-negative-epsilon)
827                                   (double-float double-float-negative-epsilon)
828                                   (single-float single-float-negative-epsilon)
829                                   (short-float  short-float-negative-epsilon)))
830                  (+ significand (etypecase float
831                                   (long-float   long-float-epsilon)
832                                   (double-float double-float-epsilon)
833                                   (single-float single-float-epsilon)
834                                   (short-float  short-float-epsilon))))
835              exponent))))
836
837 (defun -epsilon (float)
838    "Returns the float incremented by the smallest increment possible."
839    (multiple-value-bind (significand exponent sign) (decode-float float)
840      (* sign (scale-float
841               (if (minusp sign)
842                   (+ significand (etypecase float
843                                    (long-float   long-float-negative-epsilon)
844                                    (double-float double-float-negative-epsilon)
845                                    (single-float single-float-negative-epsilon)
846                                    (short-float  short-float-negative-epsilon)))
847                   (- significand (etypecase float
848                                    (long-float   long-float-epsilon)
849                                    (double-float double-float-epsilon)
850                                    (single-float single-float-epsilon)
851                                    (short-float  short-float-epsilon))))
852               exponent))))
853
854
855 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
856 ;; 14 - CONSES
857 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
858
859
860 (defun maximize (predicate list)
861   "
862 RETURN: The maximum value and the item in list for which predicate
863          is the maximum.
864 "
865   (do ((max-value nil)
866        (max-item  nil)
867        (list list (cdr list))
868        (value))
869       ((null list) (values max-value max-item))
870     (setq value (funcall predicate (car list)))
871     (when (or (null max-value) (> value max-value))
872       (setq max-value value
873             max-item (car list))))) ;;MAXIMIZE
874
875
876 ;; (DEFUN COMPUTE-CLOSURE (FUN SET)
877 ;;   "
878 ;; FUN:     set --> P(set)
879 ;;           x |--> { y }
880 ;; RETURN:  The closure of fun on the set.
881 ;; NOTE:    Not a lisp closure!
882 ;; EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1)
883 ;; "
884 ;;   (LOOP
885 ;;      :FOR NEW-SET = (DELETE-DUPLICATES (UNION SET (MAPCAN FUN SET)))
886 ;;      :WHILE (SET-EXCLUSIVE-OR NEW-SET SET)
887 ;;      :DO (SETF SET NEW-SET)
888 ;;      :FINALLY (RETURN NEW-SET)))
889
890
891 (defun compute-closure (fun set)
892   "
893 FUN:     set --> P(set)
894           x |--> { y }
895 RETURN:  The closure of fun on the set.
896 NOTE:    Not a lisp closure!
897 EXAMPLE: (compute-closure (lambda (x) (list (mod (* x 2) 5))) '(1)) --> (2 4 3 1)
898 NOTE:    This version avoids calling FUN twice with the same argument.
899 "
900   (flet ((join (lists)
901            (loop
902              :with result = '()
903              :for list :in lists
904              :do (loop :for item :in list :do (push item result))
905              :finally (return result))))
906     (loop
907       :for follows = (delete-duplicates (join (mapcar fun set)))
908       :then (delete-duplicates (join (cons follows (mapcar fun newbies))))
909       :for newbies = (set-difference follows set)
910       :while newbies
911        ;; :do (print (list 'newbies newbies))
912       :do (setf set (append newbies set))
913       :finally (return set))))
914
915
916 ;; (array->list array) --> (coerce array 'list)
917 ;; (DEFUN ARRAY->LIST (A) (MAP 'LIST (FUNCTION IDENTITY) A));;ARRAY->LIST
918
919
920 (defun topological-sort (nodes lessp)
921   "
922 RETURN: A list of NODES sorted topologically according to 
923         the partial order function LESSP.
924         If there are cycles (discounting reflexivity), 
925         then the list returned won't contain all the NODES.
926 "
927   (loop
928      :with sorted = '()
929      :with incoming = (map 'vector (lambda (to)
930                                      (loop
931                                         :for from :in nodes
932                                         :when (and (not (eq from to))
933                                                    (funcall lessp from to))
934                                         :sum 1))
935                            nodes)
936      :with q = (loop
937                   :for node :in nodes
938                   :for inco :across incoming
939                   :when (zerop inco)
940                   :collect node) 
941      :while q
942      :do (let ((n (pop q)))
943            (push n sorted)
944            (loop
945               :for m :in nodes
946               :for i :from 0
947               :do (when (and (and (not (eq n m))
948                                   (funcall lessp n m))
949                              (zerop (decf (aref incoming i))))
950                     (push m q))))
951      :finally (return (nreverse sorted))))
952
953
954 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
955 ;; 15 - ARRAYS
956 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
957
958
959 (defun vector-init (vector constructor)
960   "
961 DO:      Sets all the slots in vector to the successive results of
962          the function CONSTRUCTOR called with integers from 0 up
963          to the dimension of the VECTOR.
964 RETURN:  VECTOR
965 "
966   (do ((index 0 (1+ index)))
967       ((>= index (array-dimension vector 0)))
968     (setf (aref vector index) (funcall constructor index)))
969   vector) ;;VECTOR-INIT
970
971
972 (defun undisplace-array (array)
973   "
974 RETURN:  The fundamental array and the start and end positions into
975          it of a displaced array.
976 AUTHOR:  Erik Naggum <erik@naggum.no>
977 "
978   (let ((length (length array))
979         (start 0))
980     (loop
981        (multiple-value-bind (to offset) (array-displacement array)
982          (if to
983              (setq array to
984                    start (+ start offset))
985              (return (values array start (+ start length)))))))
986   ) ;;UNDISPLACE-ARRAY
987
988
989 (defun dichotomy (matchp min max)
990     "
991
992 MATCHP: A function taking an integer between START and END, and
993         returning an order (signed integer).
994 MIN:    The minimum integer.
995 MAX:    The maximum integer.
996 RETURN: (values found index order)
997 POST:   (<= min index max)
998         +-------------------+----------+-------+----------+----------------+
999         | Case              |  found   | index |  order   |     Error      |
1000         +-------------------+----------+-------+----------+----------------+
1001         | x < a[i]          |   FALSE  |  min  |  less    |      0         |
1002         | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |      0         |
1003         | x = a[i]          |   TRUE   |   i   |  equal   |      0         |
1004         | a[max] < x        |   FALSE  |  max  |  greater |      0         |
1005         +-------------------+----------+-------+----------+----------------+
1006 "
1007     (let* ((curmin min)
1008            (curmax max)
1009            (index  (truncate (+ curmin curmax) 2))
1010            (order  (funcall matchp index)))
1011       (loop :while (and (/= 0 order) (/= curmin index)) :do
1012          ;; (FORMAT T "~&min=~S  cur=~S  max=~S   key=~S <~S> [cur]=~S ~%" CURMIN INDEX CURMAX VALUE (FUNCALL COMPARE VALUE (FUNCALL KEY (AREF VECTOR INDEX))) (AREF VECTOR INDEX))
1013          (if (< order 0)
1014              (setf curmax index)
1015              (setf curmin index))
1016          (setf index (truncate (+ curmin curmax) 2))
1017          (setf order (funcall matchp index)))
1018       (when (and (< min index) (< order 0))
1019         (setf order 1)
1020         (decf index))
1021       (assert
1022        (or (< (funcall matchp index) 0)
1023            (and (> (funcall matchp index) 0)
1024                 (or (>= (1+ index) max)
1025                     (< (funcall matchp (1+ index)) 0)))
1026            (= (funcall matchp index) 0)))
1027       (values (= order 0) index order)))
1028
1029
1030 (defun dichotomy-search (vector value compare &key
1031                          (start 0) (end (length vector))
1032                          (key (function identity)))
1033   "
1034 PRE:    entry is the element to be searched in the table.
1035         (<= start end)
1036 RETURN: (values found index order)
1037 POST:   (<= start index end)
1038         +-------------------+----------+-------+----------+----------------+
1039         | Case              |  found   | index |  order   |     Error      |
1040         +-------------------+----------+-------+----------+----------------+
1041         | x < a[min]        |   FALSE  |  min  |  less    |      0         |
1042         | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |      0         |
1043         | x = a[i]          |   TRUE   |   i   |  equal   |      0         |
1044         | a[max] < x        |   FALSE  |  max  |  greater |      0         |
1045         +-------------------+----------+-------+----------+----------------+
1046 "
1047   (let* ((curmin start)
1048          (curmax end)
1049          (index    (truncate (+ curmin curmax) 2))
1050          (order  (funcall compare value (funcall key (aref vector index)))) )
1051     (loop :while (and (/= 0 order) (/= curmin index)) :do
1052        ;; (FORMAT T "~&min=~S  cur=~S  max=~S   key=~S <~S> [cur]=~S ~%" CURMIN INDEX CURMAX VALUE (FUNCALL COMPARE VALUE (FUNCALL KEY (AREF VECTOR INDEX))) (AREF VECTOR INDEX))
1053        (if (< order 0)
1054            (setf curmax index)
1055            (setf curmin index))
1056        (setf index (truncate (+ curmin curmax) 2))
1057        (setf order  (funcall compare value (funcall key (aref vector index)))))
1058     (when (and (< start index) (< order 0))
1059       (setf order 1)
1060       (decf index))
1061     (assert
1062      (or (< (funcall compare value (funcall key (aref vector index))) 0)
1063          (and (> (funcall compare value (funcall key (aref vector index))) 0)
1064               (or (>= (1+ index) end)
1065                   (< (funcall compare value
1066                               (funcall key (aref vector (1+  index)))) 0)))
1067          (= (funcall compare value (funcall key (aref vector index))) 0)))
1068     (values (= order 0) index order)))
1069
1070
1071 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1072 ;; 16 - STRINGS
1073 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1074
1075
1076 (defmacro sconc (&rest args)
1077   "Concatenate strings."
1078   `(concatenate 'string ,@args))
1079
1080
1081 (defun concat (&rest args)
1082   "Concatenate anything into a string."
1083   (apply (function concatenate) 'string
1084          (mapcar (lambda (item)
1085                    (if (typep item 'sequence) 
1086                        item
1087                        (format nil "~A" item))) args)))
1088
1089
1090 (defmacro scase (keyform &rest clauses)
1091   "
1092 DO:         A CASE, but for string keys. That is, it uses STRING= as test
1093             insteand of the ''being the same'' test.
1094 "
1095   (let ((key (gensym "KEY")))
1096     `(let ((,key ,keyform))
1097        (cond
1098          ,@(mapcar (lambda (clause)
1099                      (if (or (eq (car clause) 'otherwise) (eq (car clause) 't))
1100                          `(t ,@(cdr clause))
1101                          `((member ,key ',(car clause) :test (function string=))
1102                            ,@(cdr clause))))
1103                    clauses)))))
1104
1105
1106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1107 ;; 17 - SEQUENCES
1108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1109
1110 (defun nsubseq (sequence start &optional (end nil))
1111   "
1112 RETURN:  When the SEQUENCE is a vector, the SEQUENCE itself, or a dispaced
1113          array to the SEQUENCE.
1114          When the SEQUENCE is a list, it may destroy the list and reuse the
1115          cons cells to make the subsequence.
1116 "
1117   (if (vectorp sequence)
1118       (if (and (zerop start) (or (null end) (= end (length sequence))))
1119           sequence
1120           (make-array (- (if end
1121                              (min end (length sequence))
1122                              (length sequence))
1123                          start)
1124                       :element-type (array-element-type sequence)
1125                       :displaced-to sequence
1126                       :displaced-index-offset start))
1127       (let ((result (nthcdr start sequence)))
1128         (when end
1129           (setf (cdr (nthcdr (- end start -1) sequence)) nil))
1130         result)))
1131
1132
1133
1134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1135 ;; 18 - HASH-TABLES
1136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1137
1138 (defun hash-table-keys (hash)
1139   "Returns a list of the keys in the hash-table."
1140   (let ((result '()))
1141     (maphash (lambda (k v) (declare (ignore v)) (push k result)) hash)
1142     result))
1143
1144 (defun hash-table-values (table)
1145   "Returns a list of the values in the hash-table."
1146   (let ((result '()))
1147     (maphash (lambda (k v) (declare (ignore k)) (push v result)) table)
1148     result))
1149
1150 (defun hash-table-entries (hash)
1151   "Returns an a-list of the entries (key . val) in the hash-table."
1152   (let ((result '()))
1153     (maphash (lambda (k v) (push (cons k v) result)) hash)
1154     result))
1155
1156 (defun hash-table-path (htable &rest keys)
1157   "Given a hash-table that may contain other hash-table, walks down
1158 the path of KEYS, returning the ultimate value"
1159   (if (null keys)
1160       htable
1161       (apply (function hash-table-path) (gethash (first keys) htable) (rest keys))))
1162
1163 (defun copy-hash-table (table)
1164   "
1165 TABLE:  (OR NULL HASH-TABLE)
1166 RETURN: If TABLE is NIL, then NIL, 
1167         else a new HASH-TABLE with the same TEST, SIZE, REHASH-THRESHOLD 
1168         REHASH-SIZE and KEY->VALUE associations than TABLE.
1169         (Neither the keys nor the values are copied).
1170 "
1171   (check-type table (or null hash-table))
1172   (when table
1173     (let ((copy (make-hash-table
1174                  :test             (hash-table-test             table)
1175                  :size             (hash-table-size             table)
1176                  :rehash-threshold (hash-table-rehash-threshold table)
1177                  :rehash-size      (hash-table-rehash-size      table))))
1178       (maphash (lambda (k v) (setf (gethash k copy) v)) table)
1179       copy)))
1180
1181
1182 (defun hashtable (&key (test (function eql))
1183                   (size nil sizep)
1184                   (rehash-size nil rehash-size-p)
1185                   (rehash-threshold nil rehash-threshold-p)
1186                   elements)
1187   "Creates a new hash-table, filled with the given ELEMENTS.
1188 ELEMENTS must be a list of lists of two items, the key and the value.
1189 Note: we use the name HASHTABLE to avoid name collision."
1190   (let ((table (apply (function make-hash-table)
1191                 :test test
1192                 (append (when sizep
1193                           (list :size size))
1194                         (when rehash-size-p
1195                           (list :rehash-size rehash-size))
1196                         (when rehash-threshold-p
1197                           (list :rehash-threshold rehash-threshold))))))
1198     (dolist (item elements table)
1199       (setf (gethash (first item) table) (second item)))))
1200
1201
1202 (defun print-hashtable (table &optional (stream *standard-output*))
1203   "Prints readably the hash-table, using #. and the HASHTABLE function."
1204   (format stream "#.(HASHTABLE :TEST (FUNCTION ~S)  :SIZE ~D ~%~
1205                 ~&             :REHASH-SIZE ~A :REHASH-THRESHOLD ~A~%~
1206                 ~&   :ELEMENTS '("
1207           (hash-table-test table) (hash-table-count table)
1208           (hash-table-rehash-size table) (hash-table-rehash-threshold table))
1209   (maphash (lambda (k v) (format stream "~%(~S ~S)" k v)) table)
1210   (format stream "))")
1211   ;; (format stream "#.~S"
1212   ;;         `(let ((table (make-hash-table
1213   ;;                        :test (function
1214   ;;                               ,(case (hash-table-test table)
1215   ;;                                      #+clisp (EXT:FASTHASH-EQ 'eq)
1216   ;;                                      #+clisp (EXT:FASTHASH-EQL 'eql)
1217   ;;                                      #+clisp (EXT:FASTHASH-EQUAL 'equal)
1218   ;;                                      (otherwise  (hash-table-test table))))
1219   ;;                        :size ,(hash-table-size table))))
1220   ;;            (setf ,@(let ((assignments '()))
1221   ;;                         (maphash (lambda (k v)
1222   ;;                                      (push `(quote ,v) assignments)
1223   ;;                                    (push `(gethash ',k table) assignments))
1224   ;;                                  table)
1225   ;;                         assignments))
1226   ;;            table))
1227   table)
1228
1229
1230
1231 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1232 ;; TRACING
1233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1234
1235
1236 (defmacro tracing (&body body)
1237   "
1238 TRACE works only on non-CL functions.
1239 This macro will work somewhat on any form in body. 
1240 "
1241   `(progn
1242      ,@(mapcan
1243         (lambda (form)
1244           (let ((results (gensym)))
1245             (list
1246              `(format *trace-output* "~&~S~%" ',form)
1247              `(let ((,results (multiple-value-list ,form)))
1248                 (format *trace-output* "~&--> ~{~S~^~%    ~}" ,results)
1249                 (values-list ,results)))))
1250         body)))
1251
1252
1253
1254 ;; (let ((a (1+ b))
1255 ;;       (b (1+ a)))
1256 ;;   (print (list a b)))
1257 ;; 
1258 ;; (let ((#:a1 (let ((r (1+ b)))
1259 ;;               (format t "~S = ~S = ~S~%" '#:a1 '(1+ b) r)
1260 ;;               r))
1261 ;;       (#:b1 (let ((r (1+ a)))
1262 ;;               (format t "~S = ~S = ~S~%" '#:b1 '(1+ a) r)
1263 ;;               r))
1264 ;;       (a    (progn
1265 ;;               (format t "~S = ~S = ~S~%" 'a '#:a1 #:a1)
1266 ;;               #:a1))
1267 ;;       (b    (progn
1268 ;;               (format t "~S = ~S = ~S~%" 'b '#:b1 #:b1)
1269 ;;               #:b1)))
1270 ;;   (print (list a b)))
1271
1272 (defmacro tracing-let (clauses &body body)
1273   "
1274 Like LET, but prints on the *trace-output* the value of the bindings.
1275 "
1276   (let ((vals (mapcar (lambda (clause)
1277                         (gensym (symbol-name
1278                                   (if (symbolp clause) clause (first clause)))))
1279                       clauses))
1280         (res (gensym)))
1281     `(let ,(mapcar
1282             (lambda (val expr)
1283               `(,val (let ((,res ,expr))
1284                        (format *trace-output* "~&LET ~S = ~S --> ~S~%"
1285                                ',val ',expr ,res)
1286                        ,res)))
1287             vals
1288             (mapcar (lambda (clause) (if (symbolp clause) nil (second clause)))
1289                     clauses))
1290        (let ,(mapcar
1291               (lambda (var val)
1292                 `(,var (progn
1293                          (format *trace-output* "~&LET ~S = ~S --> ~S~%"
1294                                  ',var ',val ,val)
1295                          ,val)))
1296               (mapcar (lambda (clause) (if (symbolp clause) clause (first clause)))
1297                       clauses)
1298               vals)
1299          ,@body))))
1300
1301
1302 (defmacro tracing-let* (clauses &body body)
1303     "
1304 Like LET*, but prints on the *trace-output* the value of the bindings.
1305 "
1306   (if (null clauses)
1307       `(progn ,@body)
1308       `(tracing-let (,(first clauses))
1309                     (tracing-let* ,(rest clauses) ,@body))))
1310
1311
1312 (defmacro tracing-labels (defs &body body)
1313   "This macro is a replacement for LABELS that traces the calls of 
1314 the local functions."
1315   `(cl:labels
1316        ,(mapcar
1317          (lambda (def)
1318            (let ((arguments (make-argument-list
1319                              (parse-lambda-list (second def) :ordinary)))
1320                  (res (gensym "RESULTS")))
1321              `(,(first def) ,(second def)
1322                 ,@(when (stringp (third def))
1323                         (list (third def)))
1324                 (format *trace-output*
1325                   "~&Entering ~A (~@{:~A ~S~^ ~})~%" ',(first def)
1326                   ,@(mapcan (lambda (arg) (list `',arg arg)) arguments))
1327                 (unwind-protect
1328                      (progn (format *trace-output*
1329                               "~&Exiting ~A --> ~{~S~^; ~}~%"
1330                               ',(first def)
1331                               (setf ,res (multiple-value-list
1332                                           (progn ,@(cddr def)))))
1333                             (values-list ,res))
1334                   (format *trace-output*
1335                     "~&Unwinding ~A~%" ',(first def))))))
1336          defs)
1337      ,@body))
1338
1339
1340 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1341 ;;; Binary decision tree
1342 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1343
1344
1345 (eval-when (:compile-toplevel :load-toplevel :execute)
1346
1347   (defun infix-to-tree (sequence)
1348     (labels ((itt (items start end)
1349                (cond
1350                  ((= start end)       nil)
1351                  ((= (1+ start) end)  (list (aref items start)))
1352                  (t (let ((pivot (truncate (/ (+ start end) 2))))
1353                       (list (aref items pivot)
1354                             (itt items start pivot)
1355                             (itt items (1+ pivot) end)))))))
1356       (let ((vect (coerce sequence 'vector)))
1357         (itt vect 0 (length vect)))))
1358     
1359   (defun map-tree-postfix (fun tree)
1360     (if (null tree)
1361         nil 
1362         (funcall fun
1363                  (first tree)
1364                  (map-tree-postfix fun (second tree))
1365                  (map-tree-postfix fun (third  tree))))))
1366
1367
1368
1369 (defmacro decision-tree (expression &rest clauses)
1370   "
1371 CLAUSES:  Each clause is of the forms: 
1372           (less|:less . <body>)
1373           (<real> . <body>)
1374 DO:       Evaluate the expression, which must be a real,
1375           and generate a binary decision tree to select the <body>
1376           of the clause whose limit is <= the expression and 
1377           the next clause limit is > the expression.
1378 "
1379   (let ((vexpr (gensym))
1380         (less (when (and (symbolp (first (first clauses)))
1381                          (string-equal 'less (first (first clauses))))
1382                 (pop clauses)))
1383         (clauses (sort (coerce clauses 'vector) (function <)
1384                        :key (function car))))
1385     `(let ((,vexpr ,expression))
1386        ,(map-tree-postfix
1387          (let ((index -1))
1388            (flet ((gen-case ()
1389                     (incf index)
1390                     (if (zerop index)
1391                        `(progn ,@(cdr less))
1392                        `(progn ,@(cdr (aref clauses (1- index)))))))
1393              (lambda (node left right)
1394                (if (and (null left) (null right))
1395                    `(if (< ,vexpr ,(car node))
1396                         ,(gen-case)
1397                         ,(gen-case))
1398                    `(if (< ,vexpr ,(car node))
1399                         ,left
1400                         ,(if (null right)
1401                              (gen-case)
1402                              right))))))
1403          (infix-to-tree clauses)))))
1404
1405
1406 (defun xor (a b)
1407   "Return A ⊻ B"
1408   (or (and a (not b)) (and (not a) b)))
1409
1410 (defun equiv (a b)
1411   "Return A ⇔ B"
1412   (eql (not a) (not b)))
1413
1414 (defun imply (p q)
1415   "Return P ⇒ Q"
1416   (or (not p) q))
1417
1418 (defun set-equal (a b)
1419   "Return A ⊂ B ∧ A ⊃ B"
1420   (and (subsetp a b) (subsetp b a)))
1421
1422
1423 ;;;; THE END ;;;;