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