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