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